diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +The Glasgow Haskell Compiler License + +Copyright 2002, The University Court of the University of Glasgow. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +- Neither name of the University nor the names of its contributors may be +used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF +GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/compiler/HsVersions.h b/compiler/HsVersions.h new file mode 100644 --- /dev/null +++ b/compiler/HsVersions.h @@ -0,0 +1,65 @@ +#pragma once + +#if 0 + +IMPORTANT! If you put extra tabs/spaces in these macro definitions, +you will screw up the layout where they are used in case expressions! + +(This is cpp-dependent, of course) + +#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_TARGET_ARCH etc.) */ +#include "ghc_boot_platform.h" + +/* Pull in the autoconf defines (HAVE_FOO), but don't include + * ghcconfig.h, because that will include ghcplatform.h which has the + * wrong platform settings for the compiler (it has the platform + * settings for the target plat instead). */ +#include "ghcautoconf.h" + +#define GLOBAL_VAR(name,value,ty) \ +{-# NOINLINE name #-}; \ +name :: IORef (ty); \ +name = Util.global (value); + +#define GLOBAL_VAR_M(name,value,ty) \ +{-# NOINLINE name #-}; \ +name :: IORef (ty); \ +name = Util.globalM (value); + + +#define SHARED_GLOBAL_VAR(name,accessor,saccessor,value,ty) \ +{-# NOINLINE name #-}; \ +name :: IORef (ty); \ +name = Util.sharedGlobal (value) (accessor); \ +foreign import ccall unsafe saccessor \ + accessor :: Ptr (IORef a) -> IO (Ptr (IORef a)); + +#define SHARED_GLOBAL_VAR_M(name,accessor,saccessor,value,ty) \ +{-# NOINLINE name #-}; \ +name :: IORef (ty); \ +name = Util.sharedGlobalM (value) (accessor); \ +foreign import ccall unsafe saccessor \ + accessor :: Ptr (IORef a) -> IO (Ptr (IORef a)); + + +#define ASSERT(e) if debugIsOn && not (e) then (assertPanic __FILE__ __LINE__) else +#define ASSERT2(e,msg) if debugIsOn && not (e) then (assertPprPanic __FILE__ __LINE__ (msg)) else +#define WARN( e, msg ) (warnPprTrace (e) __FILE__ __LINE__ (msg)) $ + +-- Examples: Assuming flagSet :: String -> m Bool +-- +-- do { c <- getChar; MASSERT( isUpper c ); ... } +-- do { c <- getChar; MASSERT2( isUpper c, text "Bad" ); ... } +-- do { str <- getStr; ASSERTM( flagSet str ); .. } +-- do { str <- getStr; ASSERTM2( flagSet str, text "Bad" ); .. } +-- do { str <- getStr; WARNM2( flagSet str, text "Flag is set" ); .. } +#define MASSERT(e) ASSERT(e) return () +#define MASSERT2(e,msg) ASSERT2(e,msg) return () +#define ASSERTM(e) do { bool <- e; MASSERT(bool) } +#define ASSERTM2(e,msg) do { bool <- e; MASSERT2(bool,msg) } +#define WARNM2(e,msg) do { bool <- e; WARN(bool, msg) return () } diff --git a/compiler/Unique.h b/compiler/Unique.h new file mode 100644 --- /dev/null +++ b/compiler/Unique.h @@ -0,0 +1,5 @@ +/* unique has the following structure: + * HsInt unique = + * (unique_tag << (sizeof (HsInt) - UNIQUE_TAG_BITS)) | unique_number + */ +#define UNIQUE_TAG_BITS 8 diff --git a/compiler/backpack/BkpSyn.hs b/compiler/backpack/BkpSyn.hs new file mode 100644 --- /dev/null +++ b/compiler/backpack/BkpSyn.hs @@ -0,0 +1,84 @@ +-- | This is the syntax for bkp files which are parsed in 'ghc --backpack' +-- mode. This syntax is used purely for testing purposes. + +module BkpSyn ( + -- * Backpack abstract syntax + HsUnitId(..), + LHsUnitId, + HsModuleSubst, + LHsModuleSubst, + HsModuleId(..), + LHsModuleId, + HsComponentId(..), + LHsUnit, HsUnit(..), + LHsUnitDecl, HsUnitDecl(..), + HsDeclType(..), + IncludeDecl(..), + LRenaming, Renaming(..), + ) where + +import GhcPrelude + +import HsSyn +import SrcLoc +import Outputable +import Module +import PackageConfig + +{- +************************************************************************ +* * + User syntax +* * +************************************************************************ +-} + +data HsComponentId = HsComponentId { + hsPackageName :: PackageName, + hsComponentId :: ComponentId + } + +instance Outputable HsComponentId where + ppr (HsComponentId _pn cid) = ppr cid -- todo debug with pn + +data HsUnitId n = HsUnitId (Located n) [LHsModuleSubst n] +type LHsUnitId n = Located (HsUnitId n) + +type HsModuleSubst n = (Located ModuleName, LHsModuleId n) +type LHsModuleSubst n = Located (HsModuleSubst n) + +data HsModuleId n = HsModuleVar (Located ModuleName) + | HsModuleId (LHsUnitId n) (Located ModuleName) +type LHsModuleId n = Located (HsModuleId n) + +-- | Top level @unit@ declaration in a Backpack file. +data HsUnit n = HsUnit { + hsunitName :: Located n, + hsunitBody :: [LHsUnitDecl n] + } +type LHsUnit n = Located (HsUnit n) + +-- | A declaration in a package, e.g. a module or signature definition, +-- or an include. +data HsDeclType = ModuleD | SignatureD +data HsUnitDecl n + = DeclD HsDeclType (Located ModuleName) (Maybe (Located (HsModule GhcPs))) + | IncludeD (IncludeDecl n) +type LHsUnitDecl n = Located (HsUnitDecl n) + +-- | An include of another unit +data IncludeDecl n = IncludeDecl { + idUnitId :: LHsUnitId n, + idModRenaming :: Maybe [ LRenaming ], + -- | Is this a @dependency signature@ include? If so, + -- we don't compile this include when we instantiate this + -- unit (as there should not be any modules brought into + -- scope.) + idSignatureInclude :: Bool + } + +-- | Rename a module from one name to another. The identity renaming +-- means that the module should be brought into scope. +data Renaming = Renaming { renameFrom :: Located ModuleName + , renameTo :: Maybe (Located ModuleName) } +type LRenaming = Located Renaming diff --git a/compiler/basicTypes/Avail.hs b/compiler/basicTypes/Avail.hs new file mode 100644 --- /dev/null +++ b/compiler/basicTypes/Avail.hs @@ -0,0 +1,286 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +-- +-- (c) The University of Glasgow +-- + +#include "HsVersions.h" + +module Avail ( + Avails, + AvailInfo(..), + avail, + availsToNameSet, + availsToNameSetWithSelectors, + availsToNameEnv, + availName, availNames, availNonFldNames, + availNamesWithSelectors, + availFlds, + availsNamesWithOccs, + availNamesWithOccs, + stableAvailCmp, + plusAvail, + trimAvail, + filterAvail, + filterAvails, + nubAvails + + + ) where + +import GhcPrelude + +import Name +import NameEnv +import NameSet + +import FieldLabel +import Binary +import ListSetOps +import Outputable +import Util + +import Data.Data ( Data ) +import Data.List ( find ) +import Data.Function + +-- ----------------------------------------------------------------------------- +-- The AvailInfo type + +-- | Records what things are \"available\", i.e. in scope +data AvailInfo + + -- | An ordinary identifier in scope + = Avail Name + + -- | A type or class in scope + -- + -- The __AvailTC Invariant__: If the type or class is itself to be in scope, + -- it must be /first/ in this list. Thus, typically: + -- + -- > AvailTC Eq [Eq, ==, \/=] [] + | AvailTC + Name -- ^ The name of the type or class + [Name] -- ^ The available pieces of type or class, + -- excluding field selectors. + [FieldLabel] -- ^ The record fields of the type + -- (see Note [Representing fields in AvailInfo]). + + deriving ( Eq -- ^ Used when deciding if the interface has changed + , Data ) + +-- | A collection of 'AvailInfo' - several things that are \"available\" +type Avails = [AvailInfo] + +{- +Note [Representing fields in AvailInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When -XDuplicateRecordFields is disabled (the normal case), a +datatype like + + data T = MkT { foo :: Int } + +gives rise to the AvailInfo + + AvailTC T [T, MkT] [FieldLabel "foo" False foo] + +whereas if -XDuplicateRecordFields is enabled it gives + + AvailTC T [T, MkT] [FieldLabel "foo" True $sel:foo:MkT] + +since the label does not match the selector name. + +The labels in a field list are not necessarily unique: +data families allow the same parent (the family tycon) to have +multiple distinct fields with the same label. For example, + + data family F a + data instance F Int = MkFInt { foo :: Int } + data instance F Bool = MkFBool { foo :: Bool} + +gives rise to + + AvailTC F [ F, MkFInt, MkFBool ] + [ FieldLabel "foo" True $sel:foo:MkFInt + , FieldLabel "foo" True $sel:foo:MkFBool ] + +Moreover, note that the flIsOverloaded flag need not be the same for +all the elements of the list. In the example above, this occurs if +the two data instances are defined in different modules, one with +`-XDuplicateRecordFields` enabled and one with it disabled. Thus it +is possible to have + + AvailTC F [ F, MkFInt, MkFBool ] + [ FieldLabel "foo" True $sel:foo:MkFInt + , FieldLabel "foo" False foo ] + +If the two data instances are defined in different modules, both +without `-XDuplicateRecordFields`, it will be impossible to export +them from the same module (even with `-XDuplicateRecordfields` +enabled), because they would be represented identically. The +workaround here is to enable `-XDuplicateRecordFields` on the defining +modules. +-} + +-- | Compare lexicographically +stableAvailCmp :: AvailInfo -> AvailInfo -> Ordering +stableAvailCmp (Avail n1) (Avail n2) = n1 `stableNameCmp` n2 +stableAvailCmp (Avail {}) (AvailTC {}) = LT +stableAvailCmp (AvailTC n ns nfs) (AvailTC m ms mfs) = + (n `stableNameCmp` m) `thenCmp` + (cmpList stableNameCmp ns ms) `thenCmp` + (cmpList (stableNameCmp `on` flSelector) nfs mfs) +stableAvailCmp (AvailTC {}) (Avail {}) = GT + +avail :: Name -> AvailInfo +avail n = Avail n + +-- ----------------------------------------------------------------------------- +-- Operations on AvailInfo + +availsToNameSet :: [AvailInfo] -> NameSet +availsToNameSet avails = foldr add emptyNameSet avails + where add avail set = extendNameSetList set (availNames avail) + +availsToNameSetWithSelectors :: [AvailInfo] -> NameSet +availsToNameSetWithSelectors avails = foldr add emptyNameSet avails + where add avail set = extendNameSetList set (availNamesWithSelectors avail) + +availsToNameEnv :: [AvailInfo] -> NameEnv AvailInfo +availsToNameEnv avails = foldr add emptyNameEnv avails + where add avail env = extendNameEnvList env + (zip (availNames avail) (repeat avail)) + +-- | Just the main name made available, i.e. not the available pieces +-- of type or class brought into scope by the 'GenAvailInfo' +availName :: AvailInfo -> Name +availName (Avail n) = n +availName (AvailTC n _ _) = n + +-- | All names made available by the availability information (excluding overloaded selectors) +availNames :: AvailInfo -> [Name] +availNames (Avail n) = [n] +availNames (AvailTC _ ns fs) = ns ++ [ flSelector f | f <- fs, not (flIsOverloaded f) ] + +-- | All names made available by the availability information (including overloaded selectors) +availNamesWithSelectors :: AvailInfo -> [Name] +availNamesWithSelectors (Avail n) = [n] +availNamesWithSelectors (AvailTC _ ns fs) = ns ++ map flSelector fs + +-- | Names for non-fields made available by the availability information +availNonFldNames :: AvailInfo -> [Name] +availNonFldNames (Avail n) = [n] +availNonFldNames (AvailTC _ ns _) = ns + +-- | Fields made available by the availability information +availFlds :: AvailInfo -> [FieldLabel] +availFlds (AvailTC _ _ fs) = fs +availFlds _ = [] + +availsNamesWithOccs :: [AvailInfo] -> [(Name, OccName)] +availsNamesWithOccs = concatMap availNamesWithOccs + +-- | 'Name's made available by the availability information, paired with +-- the 'OccName' used to refer to each one. +-- +-- When @DuplicateRecordFields@ is in use, the 'Name' may be the +-- mangled name of a record selector (e.g. @$sel:foo:MkT@) while the +-- 'OccName' will be the label of the field (e.g. @foo@). +-- +-- See Note [Representing fields in AvailInfo]. +availNamesWithOccs :: AvailInfo -> [(Name, OccName)] +availNamesWithOccs (Avail n) = [(n, nameOccName n)] +availNamesWithOccs (AvailTC _ ns fs) + = [ (n, nameOccName n) | n <- ns ] ++ + [ (flSelector fl, mkVarOccFS (flLabel fl)) | fl <- fs ] + +-- ----------------------------------------------------------------------------- +-- Utility + +plusAvail :: AvailInfo -> AvailInfo -> AvailInfo +plusAvail a1 a2 + | debugIsOn && availName a1 /= availName a2 + = pprPanic "RnEnv.plusAvail names differ" (hsep [ppr a1,ppr a2]) +plusAvail a1@(Avail {}) (Avail {}) = a1 +plusAvail (AvailTC _ [] []) a2@(AvailTC {}) = a2 +plusAvail a1@(AvailTC {}) (AvailTC _ [] []) = a1 +plusAvail (AvailTC n1 (s1:ss1) fs1) (AvailTC n2 (s2:ss2) fs2) + = case (n1==s1, n2==s2) of -- Maintain invariant the parent is first + (True,True) -> AvailTC n1 (s1 : (ss1 `unionLists` ss2)) + (fs1 `unionLists` fs2) + (True,False) -> AvailTC n1 (s1 : (ss1 `unionLists` (s2:ss2))) + (fs1 `unionLists` fs2) + (False,True) -> AvailTC n1 (s2 : ((s1:ss1) `unionLists` ss2)) + (fs1 `unionLists` fs2) + (False,False) -> AvailTC n1 ((s1:ss1) `unionLists` (s2:ss2)) + (fs1 `unionLists` fs2) +plusAvail (AvailTC n1 ss1 fs1) (AvailTC _ [] fs2) + = AvailTC n1 ss1 (fs1 `unionLists` fs2) +plusAvail (AvailTC n1 [] fs1) (AvailTC _ ss2 fs2) + = AvailTC n1 ss2 (fs1 `unionLists` fs2) +plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2]) + +-- | trims an 'AvailInfo' to keep only a single name +trimAvail :: AvailInfo -> Name -> AvailInfo +trimAvail (Avail n) _ = Avail n +trimAvail (AvailTC n ns fs) m = case find ((== m) . flSelector) fs of + Just x -> AvailTC n [] [x] + Nothing -> ASSERT( m `elem` ns ) AvailTC n [m] [] + +-- | filters 'AvailInfo's by the given predicate +filterAvails :: (Name -> Bool) -> [AvailInfo] -> [AvailInfo] +filterAvails keep avails = foldr (filterAvail keep) [] avails + +-- | filters an 'AvailInfo' by the given predicate +filterAvail :: (Name -> Bool) -> AvailInfo -> [AvailInfo] -> [AvailInfo] +filterAvail keep ie rest = + case ie of + Avail n | keep n -> ie : rest + | otherwise -> rest + AvailTC tc ns fs -> + let ns' = filter keep ns + fs' = filter (keep . flSelector) fs in + if null ns' && null fs' then rest else AvailTC tc ns' fs' : rest + + +-- | Combines 'AvailInfo's from the same family +-- 'avails' may have several items with the same availName +-- E.g import Ix( Ix(..), index ) +-- will give Ix(Ix,index,range) and Ix(index) +-- We want to combine these; addAvail does that +nubAvails :: [AvailInfo] -> [AvailInfo] +nubAvails avails = nameEnvElts (foldl' add emptyNameEnv avails) + where + add env avail = extendNameEnv_C plusAvail env (availName avail) avail + +-- ----------------------------------------------------------------------------- +-- Printing + +instance Outputable AvailInfo where + ppr = pprAvail + +pprAvail :: AvailInfo -> SDoc +pprAvail (Avail n) + = ppr n +pprAvail (AvailTC n ns fs) + = ppr n <> braces (sep [ fsep (punctuate comma (map ppr ns)) <> semi + , fsep (punctuate comma (map (ppr . flLabel) fs))]) + +instance Binary AvailInfo where + put_ bh (Avail aa) = do + putByte bh 0 + put_ bh aa + put_ bh (AvailTC ab ac ad) = do + putByte bh 1 + put_ bh ab + put_ bh ac + put_ bh ad + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + return (Avail aa) + _ -> do ab <- get bh + ac <- get bh + ad <- get bh + return (AvailTC ab ac ad) diff --git a/compiler/basicTypes/BasicTypes.hs b/compiler/basicTypes/BasicTypes.hs new file mode 100644 --- /dev/null +++ b/compiler/basicTypes/BasicTypes.hs @@ -0,0 +1,1614 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1997-1998 + +\section[BasicTypes]{Miscellanous types} + +This module defines a miscellaneously collection of very simple +types that + +\begin{itemize} +\item have no other obvious home +\item don't depend on any other complicated types +\item are used in more than one "part" of the compiler +\end{itemize} +-} + +{-# LANGUAGE DeriveDataTypeable #-} + +module BasicTypes( + Version, bumpVersion, initialVersion, + + LeftOrRight(..), + pickLR, + + ConTag, ConTagZ, fIRST_TAG, + + Arity, RepArity, JoinArity, + + Alignment, + + PromotionFlag(..), isPromoted, + FunctionOrData(..), + + WarningTxt(..), pprWarningTxtForMsg, StringLiteral(..), + + Fixity(..), FixityDirection(..), + defaultFixity, maxPrecedence, minPrecedence, + negateFixity, funTyFixity, + compareFixity, + LexicalFixity(..), + + RecFlag(..), isRec, isNonRec, boolToRecFlag, + Origin(..), isGenerated, + + RuleName, pprRuleName, + + TopLevelFlag(..), isTopLevel, isNotTopLevel, + + OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe, + hasOverlappingFlag, hasOverlappableFlag, hasIncoherentFlag, + + Boxity(..), isBoxed, + + PprPrec(..), topPrec, sigPrec, opPrec, funPrec, appPrec, maybeParen, + + TupleSort(..), tupleSortBoxity, boxityTupleSort, + tupleParens, + + sumParens, pprAlternative, + + -- ** The OneShotInfo type + OneShotInfo(..), + noOneShotInfo, hasNoOneShotInfo, isOneShotInfo, + bestOneShot, worstOneShot, + + OccInfo(..), noOccInfo, seqOccInfo, zapFragileOcc, isOneOcc, + isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, isManyOccs, + strongLoopBreaker, weakLoopBreaker, + + InsideLam, insideLam, notInsideLam, + OneBranch, oneBranch, notOneBranch, + InterestingCxt, + TailCallInfo(..), tailCallInfo, zapOccTailCallInfo, + isAlwaysTailCalled, + + EP(..), + + DefMethSpec(..), + SwapFlag(..), flipSwap, unSwap, isSwapped, + + CompilerPhase(..), PhaseNum, + + Activation(..), isActive, isActiveIn, competesWith, + isNeverActive, isAlwaysActive, isEarlyActive, + activeAfterInitial, activeDuringFinal, + + RuleMatchInfo(..), isConLike, isFunLike, + InlineSpec(..), noUserInlineSpec, + InlinePragma(..), defaultInlinePragma, alwaysInlinePragma, + neverInlinePragma, dfunInlinePragma, + isDefaultInlinePragma, + isInlinePragma, isInlinablePragma, isAnyInlinePragma, + inlinePragmaSpec, inlinePragmaSat, + inlinePragmaActivation, inlinePragmaRuleMatchInfo, + setInlinePragmaActivation, setInlinePragmaRuleMatchInfo, + pprInline, pprInlineDebug, + + SuccessFlag(..), succeeded, failed, successIf, + + IntegralLit(..), FractionalLit(..), + negateIntegralLit, negateFractionalLit, + mkIntegralLit, mkFractionalLit, + integralFractionalLit, + + SourceText(..), pprWithSourceText, + + IntWithInf, infinity, treatZeroAsInf, mkIntWithInf, intGtLimit, + + SpliceExplicitFlag(..) + ) where + +import GhcPrelude + +import FastString +import Outputable +import SrcLoc ( Located,unLoc ) +import Data.Data hiding (Fixity, Prefix, Infix) +import Data.Function (on) + +{- +************************************************************************ +* * + Binary choice +* * +************************************************************************ +-} + +data LeftOrRight = CLeft | CRight + deriving( Eq, Data ) + +pickLR :: LeftOrRight -> (a,a) -> a +pickLR CLeft (l,_) = l +pickLR CRight (_,r) = r + +instance Outputable LeftOrRight where + ppr CLeft = text "Left" + ppr CRight = text "Right" + +{- +************************************************************************ +* * +\subsection[Arity]{Arity} +* * +************************************************************************ +-} + +-- | The number of value arguments that can be applied to a value before it does +-- "real work". So: +-- fib 100 has arity 0 +-- \x -> fib x has arity 1 +-- See also Note [Definition of arity] in CoreArity +type Arity = Int + +-- | Representation Arity +-- +-- The number of represented arguments that can be applied to a value before it does +-- "real work". So: +-- fib 100 has representation arity 0 +-- \x -> fib x has representation arity 1 +-- \(# x, y #) -> fib (x + y) has representation arity 2 +type RepArity = Int + +-- | The number of arguments that a join point takes. Unlike the arity of a +-- function, this is a purely syntactic property and is fixed when the join +-- point is created (or converted from a value). Both type and value arguments +-- are counted. +type JoinArity = Int + +{- +************************************************************************ +* * + Constructor tags +* * +************************************************************************ +-} + +-- | Constructor Tag +-- +-- Type of the tags associated with each constructor possibility or superclass +-- selector +type ConTag = Int + +-- | A *zero-indexed* constructor tag +type ConTagZ = Int + +fIRST_TAG :: ConTag +-- ^ Tags are allocated from here for real constructors +-- or for superclass selectors +fIRST_TAG = 1 + +{- +************************************************************************ +* * +\subsection[Alignment]{Alignment} +* * +************************************************************************ +-} + +type Alignment = Int -- align to next N-byte boundary (N must be a power of 2). + +{- +************************************************************************ +* * + One-shot information +* * +************************************************************************ +-} + +-- | If the 'Id' is a lambda-bound variable then it may have lambda-bound +-- variable info. Sometimes we know whether the lambda binding this variable +-- is a \"one-shot\" lambda; that is, whether it is applied at most once. +-- +-- This information may be useful in optimisation, as computations may +-- safely be floated inside such a lambda without risk of duplicating +-- work. +data OneShotInfo + = NoOneShotInfo -- ^ No information + | OneShotLam -- ^ The lambda is applied at most once. + deriving (Eq) + +-- | It is always safe to assume that an 'Id' has no lambda-bound variable information +noOneShotInfo :: OneShotInfo +noOneShotInfo = NoOneShotInfo + +isOneShotInfo, hasNoOneShotInfo :: OneShotInfo -> Bool +isOneShotInfo OneShotLam = True +isOneShotInfo _ = False + +hasNoOneShotInfo NoOneShotInfo = True +hasNoOneShotInfo _ = False + +worstOneShot, bestOneShot :: OneShotInfo -> OneShotInfo -> OneShotInfo +worstOneShot NoOneShotInfo _ = NoOneShotInfo +worstOneShot OneShotLam os = os + +bestOneShot NoOneShotInfo os = os +bestOneShot OneShotLam _ = OneShotLam + +pprOneShotInfo :: OneShotInfo -> SDoc +pprOneShotInfo NoOneShotInfo = empty +pprOneShotInfo OneShotLam = text "OneShot" + +instance Outputable OneShotInfo where + ppr = pprOneShotInfo + +{- +************************************************************************ +* * + Swap flag +* * +************************************************************************ +-} + +data SwapFlag + = NotSwapped -- Args are: actual, expected + | IsSwapped -- Args are: expected, actual + +instance Outputable SwapFlag where + ppr IsSwapped = text "Is-swapped" + ppr NotSwapped = text "Not-swapped" + +flipSwap :: SwapFlag -> SwapFlag +flipSwap IsSwapped = NotSwapped +flipSwap NotSwapped = IsSwapped + +isSwapped :: SwapFlag -> Bool +isSwapped IsSwapped = True +isSwapped NotSwapped = False + +unSwap :: SwapFlag -> (a->a->b) -> a -> a -> b +unSwap NotSwapped f a b = f a b +unSwap IsSwapped f a b = f b a + + +{- ********************************************************************* +* * + Promotion flag +* * +********************************************************************* -} + +-- | Is a TyCon a promoted data constructor or just a normal type constructor? +data PromotionFlag + = NotPromoted + | IsPromoted + deriving ( Eq, Data ) + +isPromoted :: PromotionFlag -> Bool +isPromoted IsPromoted = True +isPromoted NotPromoted = False + + +{- +************************************************************************ +* * +\subsection[FunctionOrData]{FunctionOrData} +* * +************************************************************************ +-} + +data FunctionOrData = IsFunction | IsData + deriving (Eq, Ord, Data) + +instance Outputable FunctionOrData where + ppr IsFunction = text "(function)" + ppr IsData = text "(data)" + +{- +************************************************************************ +* * +\subsection[Version]{Module and identifier version numbers} +* * +************************************************************************ +-} + +type Version = Int + +bumpVersion :: Version -> Version +bumpVersion v = v+1 + +initialVersion :: Version +initialVersion = 1 + +{- +************************************************************************ +* * + Deprecations +* * +************************************************************************ +-} + +-- | A String Literal in the source, including its original raw format for use by +-- source to source manipulation tools. +data StringLiteral = StringLiteral + { sl_st :: SourceText, -- literal raw source. + -- See not [Literal source text] + sl_fs :: FastString -- literal string value + } deriving Data + +instance Eq StringLiteral where + (StringLiteral _ a) == (StringLiteral _ b) = a == b + +instance Outputable StringLiteral where + ppr sl = pprWithSourceText (sl_st sl) (ftext $ sl_fs sl) + +-- | Warning Text +-- +-- reason/explanation from a WARNING or DEPRECATED pragma +data WarningTxt = WarningTxt (Located SourceText) + [Located StringLiteral] + | DeprecatedTxt (Located SourceText) + [Located StringLiteral] + deriving (Eq, Data) + +instance Outputable WarningTxt where + ppr (WarningTxt lsrc ws) + = case unLoc lsrc of + NoSourceText -> pp_ws ws + SourceText src -> text src <+> pp_ws ws <+> text "#-}" + + ppr (DeprecatedTxt lsrc ds) + = case unLoc lsrc of + NoSourceText -> pp_ws ds + SourceText src -> text src <+> pp_ws ds <+> text "#-}" + +pp_ws :: [Located StringLiteral] -> SDoc +pp_ws [l] = ppr $ unLoc l +pp_ws ws + = text "[" + <+> vcat (punctuate comma (map (ppr . unLoc) ws)) + <+> text "]" + + +pprWarningTxtForMsg :: WarningTxt -> SDoc +pprWarningTxtForMsg (WarningTxt _ ws) + = doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ws)) +pprWarningTxtForMsg (DeprecatedTxt _ ds) + = text "Deprecated:" <+> + doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ds)) + +{- +************************************************************************ +* * + Rules +* * +************************************************************************ +-} + +type RuleName = FastString + +pprRuleName :: RuleName -> SDoc +pprRuleName rn = doubleQuotes (ftext rn) + +{- +************************************************************************ +* * +\subsection[Fixity]{Fixity info} +* * +************************************************************************ +-} + +------------------------ +data Fixity = Fixity SourceText Int FixityDirection + -- Note [Pragma source text] + deriving Data + +instance Outputable Fixity where + ppr (Fixity _ prec dir) = hcat [ppr dir, space, int prec] + +instance Eq Fixity where -- Used to determine if two fixities conflict + (Fixity _ p1 dir1) == (Fixity _ p2 dir2) = p1==p2 && dir1 == dir2 + +------------------------ +data FixityDirection = InfixL | InfixR | InfixN + deriving (Eq, Data) + +instance Outputable FixityDirection where + ppr InfixL = text "infixl" + ppr InfixR = text "infixr" + ppr InfixN = text "infix" + +------------------------ +maxPrecedence, minPrecedence :: Int +maxPrecedence = 9 +minPrecedence = 0 + +defaultFixity :: Fixity +defaultFixity = Fixity NoSourceText maxPrecedence InfixL + +negateFixity, funTyFixity :: Fixity +-- Wired-in fixities +negateFixity = Fixity NoSourceText 6 InfixL -- Fixity of unary negate +funTyFixity = Fixity NoSourceText (-1) InfixR -- Fixity of '->', see #15235 + +{- +Consider + +\begin{verbatim} + a `op1` b `op2` c +\end{verbatim} +@(compareFixity op1 op2)@ tells which way to arrange application, or +whether there's an error. +-} + +compareFixity :: Fixity -> Fixity + -> (Bool, -- Error please + Bool) -- Associate to the right: a op1 (b op2 c) +compareFixity (Fixity _ prec1 dir1) (Fixity _ prec2 dir2) + = case prec1 `compare` prec2 of + GT -> left + LT -> right + EQ -> case (dir1, dir2) of + (InfixR, InfixR) -> right + (InfixL, InfixL) -> left + _ -> error_please + where + right = (False, True) + left = (False, False) + error_please = (True, False) + +-- |Captures the fixity of declarations as they are parsed. This is not +-- necessarily the same as the fixity declaration, as the normal fixity may be +-- overridden using parens or backticks. +data LexicalFixity = Prefix | Infix deriving (Data,Eq) + +instance Outputable LexicalFixity where + ppr Prefix = text "Prefix" + ppr Infix = text "Infix" + +{- +************************************************************************ +* * +\subsection[Top-level/local]{Top-level/not-top level flag} +* * +************************************************************************ +-} + +data TopLevelFlag + = TopLevel + | NotTopLevel + +isTopLevel, isNotTopLevel :: TopLevelFlag -> Bool + +isNotTopLevel NotTopLevel = True +isNotTopLevel TopLevel = False + +isTopLevel TopLevel = True +isTopLevel NotTopLevel = False + +instance Outputable TopLevelFlag where + ppr TopLevel = text "" + ppr NotTopLevel = text "" + +{- +************************************************************************ +* * + Boxity flag +* * +************************************************************************ +-} + +data Boxity + = Boxed + | Unboxed + deriving( Eq, Data ) + +isBoxed :: Boxity -> Bool +isBoxed Boxed = True +isBoxed Unboxed = False + +instance Outputable Boxity where + ppr Boxed = text "Boxed" + ppr Unboxed = text "Unboxed" + +{- +************************************************************************ +* * + Recursive/Non-Recursive flag +* * +************************************************************************ +-} + +-- | Recursivity Flag +data RecFlag = Recursive + | NonRecursive + deriving( Eq, Data ) + +isRec :: RecFlag -> Bool +isRec Recursive = True +isRec NonRecursive = False + +isNonRec :: RecFlag -> Bool +isNonRec Recursive = False +isNonRec NonRecursive = True + +boolToRecFlag :: Bool -> RecFlag +boolToRecFlag True = Recursive +boolToRecFlag False = NonRecursive + +instance Outputable RecFlag where + ppr Recursive = text "Recursive" + ppr NonRecursive = text "NonRecursive" + +{- +************************************************************************ +* * + Code origin +* * +************************************************************************ +-} + +data Origin = FromSource + | Generated + deriving( Eq, Data ) + +isGenerated :: Origin -> Bool +isGenerated Generated = True +isGenerated FromSource = False + +instance Outputable Origin where + ppr FromSource = text "FromSource" + ppr Generated = text "Generated" + +{- +************************************************************************ +* * + Instance overlap flag +* * +************************************************************************ +-} + +-- | The semantics allowed for overlapping instances for a particular +-- instance. See Note [Safe Haskell isSafeOverlap] (in `InstEnv.hs`) for a +-- explanation of the `isSafeOverlap` field. +-- +-- - 'ApiAnnotation.AnnKeywordId' : +-- 'ApiAnnotation.AnnOpen' @'\{-\# OVERLAPPABLE'@ or +-- @'\{-\# OVERLAPPING'@ or +-- @'\{-\# OVERLAPS'@ or +-- @'\{-\# INCOHERENT'@, +-- 'ApiAnnotation.AnnClose' @`\#-\}`@, + +-- For details on above see note [Api annotations] in ApiAnnotation +data OverlapFlag = OverlapFlag + { overlapMode :: OverlapMode + , isSafeOverlap :: Bool + } deriving (Eq, Data) + +setOverlapModeMaybe :: OverlapFlag -> Maybe OverlapMode -> OverlapFlag +setOverlapModeMaybe f Nothing = f +setOverlapModeMaybe f (Just m) = f { overlapMode = m } + +hasIncoherentFlag :: OverlapMode -> Bool +hasIncoherentFlag mode = + case mode of + Incoherent _ -> True + _ -> False + +hasOverlappableFlag :: OverlapMode -> Bool +hasOverlappableFlag mode = + case mode of + Overlappable _ -> True + Overlaps _ -> True + Incoherent _ -> True + _ -> False + +hasOverlappingFlag :: OverlapMode -> Bool +hasOverlappingFlag mode = + case mode of + Overlapping _ -> True + Overlaps _ -> True + Incoherent _ -> True + _ -> False + +data OverlapMode -- See Note [Rules for instance lookup] in InstEnv + = NoOverlap SourceText + -- See Note [Pragma source text] + -- ^ This instance must not overlap another `NoOverlap` instance. + -- However, it may be overlapped by `Overlapping` instances, + -- and it may overlap `Overlappable` instances. + + + | Overlappable SourceText + -- See Note [Pragma source text] + -- ^ Silently ignore this instance if you find a + -- more specific one that matches the constraint + -- you are trying to resolve + -- + -- Example: constraint (Foo [Int]) + -- instance Foo [Int] + -- instance {-# OVERLAPPABLE #-} Foo [a] + -- + -- Since the second instance has the Overlappable flag, + -- the first instance will be chosen (otherwise + -- its ambiguous which to choose) + + + | Overlapping SourceText + -- See Note [Pragma source text] + -- ^ Silently ignore any more general instances that may be + -- used to solve the constraint. + -- + -- Example: constraint (Foo [Int]) + -- instance {-# OVERLAPPING #-} Foo [Int] + -- instance Foo [a] + -- + -- Since the first instance has the Overlapping flag, + -- the second---more general---instance will be ignored (otherwise + -- it is ambiguous which to choose) + + + | Overlaps SourceText + -- See Note [Pragma source text] + -- ^ Equivalent to having both `Overlapping` and `Overlappable` flags. + + | Incoherent SourceText + -- See Note [Pragma source text] + -- ^ Behave like Overlappable and Overlapping, and in addition pick + -- an an arbitrary one if there are multiple matching candidates, and + -- don't worry about later instantiation + -- + -- Example: constraint (Foo [b]) + -- instance {-# INCOHERENT -} Foo [Int] + -- instance Foo [a] + -- Without the Incoherent flag, we'd complain that + -- instantiating 'b' would change which instance + -- was chosen. See also note [Incoherent instances] in InstEnv + + deriving (Eq, Data) + + +instance Outputable OverlapFlag where + ppr flag = ppr (overlapMode flag) <+> pprSafeOverlap (isSafeOverlap flag) + +instance Outputable OverlapMode where + ppr (NoOverlap _) = empty + ppr (Overlappable _) = text "[overlappable]" + ppr (Overlapping _) = text "[overlapping]" + ppr (Overlaps _) = text "[overlap ok]" + ppr (Incoherent _) = text "[incoherent]" + +pprSafeOverlap :: Bool -> SDoc +pprSafeOverlap True = text "[safe]" +pprSafeOverlap False = empty + +{- +************************************************************************ +* * + Precedence +* * +************************************************************************ +-} + +-- | A general-purpose pretty-printing precedence type. +newtype PprPrec = PprPrec Int deriving (Eq, Ord, Show) +-- See Note [Precedence in types] + +topPrec, sigPrec, funPrec, opPrec, appPrec :: PprPrec +topPrec = PprPrec 0 -- No parens +sigPrec = PprPrec 1 -- Explicit type signatures +funPrec = PprPrec 2 -- Function args; no parens for constructor apps + -- See [Type operator precedence] for why both + -- funPrec and opPrec exist. +opPrec = PprPrec 2 -- Infix operator +appPrec = PprPrec 3 -- Constructor args; no parens for atomic + +maybeParen :: PprPrec -> PprPrec -> SDoc -> SDoc +maybeParen ctxt_prec inner_prec pretty + | ctxt_prec < inner_prec = pretty + | otherwise = parens pretty + +{- Note [Precedence in types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Many pretty-printing functions have type + ppr_ty :: PprPrec -> Type -> SDoc + +The PprPrec gives the binding strength of the context. For example, in + T ty1 ty2 +we will pretty-print 'ty1' and 'ty2' with the call + (ppr_ty appPrec ty) +to indicate that the context is that of an argument of a TyConApp. + +We use this consistently for Type and HsType. + +Note [Type operator precedence] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't keep the fixity of type operators in the operator. So the +pretty printer follows the following precedence order: + + TyConPrec Type constructor application + TyOpPrec/FunPrec Operator application and function arrow + +We have funPrec and opPrec to represent the precedence of function +arrow and type operators respectively, but currently we implement +funPrec == opPrec, so that we don't distinguish the two. Reason: +it's hard to parse a type like + a ~ b => c * d -> e - f + +By treating opPrec = funPrec we end up with more parens + (a ~ b) => (c * d) -> (e - f) + +But the two are different constructors of PprPrec so we could make +(->) bind more or less tightly if we wanted. +-} + +{- +************************************************************************ +* * + Tuples +* * +************************************************************************ +-} + +data TupleSort + = BoxedTuple + | UnboxedTuple + | ConstraintTuple + deriving( Eq, Data ) + +tupleSortBoxity :: TupleSort -> Boxity +tupleSortBoxity BoxedTuple = Boxed +tupleSortBoxity UnboxedTuple = Unboxed +tupleSortBoxity ConstraintTuple = Boxed + +boxityTupleSort :: Boxity -> TupleSort +boxityTupleSort Boxed = BoxedTuple +boxityTupleSort Unboxed = UnboxedTuple + +tupleParens :: TupleSort -> SDoc -> SDoc +tupleParens BoxedTuple p = parens p +tupleParens UnboxedTuple p = text "(#" <+> p <+> ptext (sLit "#)") +tupleParens ConstraintTuple p -- In debug-style write (% Eq a, Ord b %) + = ifPprDebug (text "(%" <+> p <+> ptext (sLit "%)")) + (parens p) + +{- +************************************************************************ +* * + Sums +* * +************************************************************************ +-} + +sumParens :: SDoc -> SDoc +sumParens p = ptext (sLit "(#") <+> p <+> ptext (sLit "#)") + +-- | Pretty print an alternative in an unboxed sum e.g. "| a | |". +pprAlternative :: (a -> SDoc) -- ^ The pretty printing function to use + -> a -- ^ The things to be pretty printed + -> ConTag -- ^ Alternative (one-based) + -> Arity -- ^ Arity + -> SDoc -- ^ 'SDoc' where the alternative havs been pretty + -- printed and finally packed into a paragraph. +pprAlternative pp x alt arity = + fsep (replicate (alt - 1) vbar ++ [pp x] ++ replicate (arity - alt) vbar) + +{- +************************************************************************ +* * +\subsection[Generic]{Generic flag} +* * +************************************************************************ + +This is the "Embedding-Projection pair" datatype, it contains +two pieces of code (normally either RenamedExpr's or Id's) +If we have a such a pair (EP from to), the idea is that 'from' and 'to' +represents functions of type + + from :: T -> Tring + to :: Tring -> T + +And we should have + + to (from x) = x + +T and Tring are arbitrary, but typically T is the 'main' type while +Tring is the 'representation' type. (This just helps us remember +whether to use 'from' or 'to'. +-} + +-- | Embedding Projection pair +data EP a = EP { fromEP :: a, -- :: T -> Tring + toEP :: a } -- :: Tring -> T + +{- +Embedding-projection pairs are used in several places: + +First of all, each type constructor has an EP associated with it, the +code in EP converts (datatype T) from T to Tring and back again. + +Secondly, when we are filling in Generic methods (in the typechecker, +tcMethodBinds), we are constructing bimaps by induction on the structure +of the type of the method signature. + + +************************************************************************ +* * +\subsection{Occurrence information} +* * +************************************************************************ + +This data type is used exclusively by the simplifier, but it appears in a +SubstResult, which is currently defined in VarEnv, which is pretty near +the base of the module hierarchy. So it seemed simpler to put the +defn of OccInfo here, safely at the bottom +-} + +-- | identifier Occurrence Information +data OccInfo + = ManyOccs { occ_tail :: !TailCallInfo } + -- ^ There are many occurrences, or unknown occurrences + + | IAmDead -- ^ Marks unused variables. Sometimes useful for + -- lambda and case-bound variables. + + | OneOcc { occ_in_lam :: !InsideLam + , occ_one_br :: !OneBranch + , occ_int_cxt :: !InterestingCxt + , occ_tail :: !TailCallInfo } + -- ^ Occurs exactly once (per branch), not inside a rule + + -- | This identifier breaks a loop of mutually recursive functions. The field + -- marks whether it is only a loop breaker due to a reference in a rule + | IAmALoopBreaker { occ_rules_only :: !RulesOnly + , occ_tail :: !TailCallInfo } + -- Note [LoopBreaker OccInfo] + + deriving (Eq) + +type RulesOnly = Bool + +{- +Note [LoopBreaker OccInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~~ + IAmALoopBreaker True <=> A "weak" or rules-only loop breaker + Do not preInlineUnconditionally + + IAmALoopBreaker False <=> A "strong" loop breaker + Do not inline at all + +See OccurAnal Note [Weak loop breakers] +-} + +noOccInfo :: OccInfo +noOccInfo = ManyOccs { occ_tail = NoTailCallInfo } + +isManyOccs :: OccInfo -> Bool +isManyOccs ManyOccs{} = True +isManyOccs _ = False + +seqOccInfo :: OccInfo -> () +seqOccInfo occ = occ `seq` () + +----------------- +-- | Interesting Context +type InterestingCxt = Bool -- True <=> Function: is applied + -- Data value: scrutinised by a case with + -- at least one non-DEFAULT branch + +----------------- +-- | Inside Lambda +type InsideLam = Bool -- True <=> Occurs inside a non-linear lambda + -- Substituting a redex for this occurrence is + -- dangerous because it might duplicate work. +insideLam, notInsideLam :: InsideLam +insideLam = True +notInsideLam = False + +----------------- +type OneBranch = Bool -- True <=> Occurs in only one case branch + -- so no code-duplication issue to worry about +oneBranch, notOneBranch :: OneBranch +oneBranch = True +notOneBranch = False + +----------------- +data TailCallInfo = AlwaysTailCalled JoinArity -- See Note [TailCallInfo] + | NoTailCallInfo + deriving (Eq) + +tailCallInfo :: OccInfo -> TailCallInfo +tailCallInfo IAmDead = NoTailCallInfo +tailCallInfo other = occ_tail other + +zapOccTailCallInfo :: OccInfo -> OccInfo +zapOccTailCallInfo IAmDead = IAmDead +zapOccTailCallInfo occ = occ { occ_tail = NoTailCallInfo } + +isAlwaysTailCalled :: OccInfo -> Bool +isAlwaysTailCalled occ + = case tailCallInfo occ of AlwaysTailCalled{} -> True + NoTailCallInfo -> False + +instance Outputable TailCallInfo where + ppr (AlwaysTailCalled ar) = sep [ text "Tail", int ar ] + ppr _ = empty + +----------------- +strongLoopBreaker, weakLoopBreaker :: OccInfo +strongLoopBreaker = IAmALoopBreaker False NoTailCallInfo +weakLoopBreaker = IAmALoopBreaker True NoTailCallInfo + +isWeakLoopBreaker :: OccInfo -> Bool +isWeakLoopBreaker (IAmALoopBreaker{}) = True +isWeakLoopBreaker _ = False + +isStrongLoopBreaker :: OccInfo -> Bool +isStrongLoopBreaker (IAmALoopBreaker { occ_rules_only = False }) = True + -- Loop-breaker that breaks a non-rule cycle +isStrongLoopBreaker _ = False + +isDeadOcc :: OccInfo -> Bool +isDeadOcc IAmDead = True +isDeadOcc _ = False + +isOneOcc :: OccInfo -> Bool +isOneOcc (OneOcc {}) = True +isOneOcc _ = False + +zapFragileOcc :: OccInfo -> OccInfo +-- Keep only the most robust data: deadness, loop-breaker-hood +zapFragileOcc (OneOcc {}) = noOccInfo +zapFragileOcc occ = zapOccTailCallInfo occ + +instance Outputable OccInfo where + -- only used for debugging; never parsed. KSW 1999-07 + ppr (ManyOccs tails) = pprShortTailCallInfo tails + ppr IAmDead = text "Dead" + ppr (IAmALoopBreaker rule_only tails) + = text "LoopBreaker" <> pp_ro <> pprShortTailCallInfo tails + where + pp_ro | rule_only = char '!' + | otherwise = empty + ppr (OneOcc inside_lam one_branch int_cxt tail_info) + = text "Once" <> pp_lam <> pp_br <> pp_args <> pp_tail + where + pp_lam | inside_lam = char 'L' + | otherwise = empty + pp_br | one_branch = empty + | otherwise = char '*' + pp_args | int_cxt = char '!' + | otherwise = empty + pp_tail = pprShortTailCallInfo tail_info + +pprShortTailCallInfo :: TailCallInfo -> SDoc +pprShortTailCallInfo (AlwaysTailCalled ar) = char 'T' <> brackets (int ar) +pprShortTailCallInfo NoTailCallInfo = empty + +{- +Note [TailCallInfo] +~~~~~~~~~~~~~~~~~~~ +The occurrence analyser determines what can be made into a join point, but it +doesn't change the binder into a JoinId because then it would be inconsistent +with the occurrences. Thus it's left to the simplifier (or to simpleOptExpr) to +change the IdDetails. + +The AlwaysTailCalled marker actually means slightly more than simply that the +function is always tail-called. See Note [Invariants on join points]. + +This info is quite fragile and should not be relied upon unless the occurrence +analyser has *just* run. Use 'Id.isJoinId_maybe' for the permanent state of +the join-point-hood of a binder; a join id itself will not be marked +AlwaysTailCalled. + +Note that there is a 'TailCallInfo' on a 'ManyOccs' value. One might expect that +being tail-called would mean that the variable could only appear once per branch +(thus getting a `OneOcc { occ_one_br = True }` occurrence info), but a join +point can also be invoked from other join points, not just from case branches: + + let j1 x = ... + j2 y = ... j1 z {- tail call -} ... + in case w of + A -> j1 v + B -> j2 u + C -> j2 q + +Here both 'j1' and 'j2' will get marked AlwaysTailCalled, but j1 will get +ManyOccs and j2 will get `OneOcc { occ_one_br = True }`. + +************************************************************************ +* * + Default method specification +* * +************************************************************************ + +The DefMethSpec enumeration just indicates what sort of default method +is used for a class. It is generated from source code, and present in +interface files; it is converted to Class.DefMethInfo before begin put in a +Class object. +-} + +-- | Default Method Specification +data DefMethSpec ty + = VanillaDM -- Default method given with polymorphic code + | GenericDM ty -- Default method given with code of this type + +instance Outputable (DefMethSpec ty) where + ppr VanillaDM = text "{- Has default method -}" + ppr (GenericDM {}) = text "{- Has generic default method -}" + +{- +************************************************************************ +* * +\subsection{Success flag} +* * +************************************************************************ +-} + +data SuccessFlag = Succeeded | Failed + +instance Outputable SuccessFlag where + ppr Succeeded = text "Succeeded" + ppr Failed = text "Failed" + +successIf :: Bool -> SuccessFlag +successIf True = Succeeded +successIf False = Failed + +succeeded, failed :: SuccessFlag -> Bool +succeeded Succeeded = True +succeeded Failed = False + +failed Succeeded = False +failed Failed = True + +{- +************************************************************************ +* * +\subsection{Source Text} +* * +************************************************************************ +Keeping Source Text for source to source conversions + +Note [Pragma source text] +~~~~~~~~~~~~~~~~~~~~~~~~~ +The lexer does a case-insensitive match for pragmas, as well as +accepting both UK and US spelling variants. + +So + + {-# SPECIALISE #-} + {-# SPECIALIZE #-} + {-# Specialize #-} + +will all generate ITspec_prag token for the start of the pragma. + +In order to be able to do source to source conversions, the original +source text for the token needs to be preserved, hence the +`SourceText` field. + +So the lexer will then generate + + ITspec_prag "{ -# SPECIALISE" + ITspec_prag "{ -# SPECIALIZE" + ITspec_prag "{ -# Specialize" + +for the cases above. + [without the space between '{' and '-', otherwise this comment won't parse] + + +Note [Literal source text] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +The lexer/parser converts literals from their original source text +versions to an appropriate internal representation. This is a problem +for tools doing source to source conversions, so the original source +text is stored in literals where this can occur. + +Motivating examples for HsLit + + HsChar '\n' == '\x20` + HsCharPrim '\x41`# == `A` + HsString "\x20\x41" == " A" + HsStringPrim "\x20"# == " "# + HsInt 001 == 1 + HsIntPrim 002# == 2# + HsWordPrim 003## == 3## + HsInt64Prim 004## == 4## + HsWord64Prim 005## == 5## + HsInteger 006 == 6 + +For OverLitVal + + HsIntegral 003 == 0x003 + HsIsString "\x41nd" == "And" +-} + + -- Note [Literal source text],[Pragma source text] +data SourceText = SourceText String + | NoSourceText -- ^ For when code is generated, e.g. TH, + -- deriving. The pretty printer will then make + -- its own representation of the item. + deriving (Data, Show, Eq ) + +instance Outputable SourceText where + ppr (SourceText s) = text "SourceText" <+> text s + ppr NoSourceText = text "NoSourceText" + +-- | Special combinator for showing string literals. +pprWithSourceText :: SourceText -> SDoc -> SDoc +pprWithSourceText NoSourceText d = d +pprWithSourceText (SourceText src) _ = text src + +{- +************************************************************************ +* * +\subsection{Activation} +* * +************************************************************************ + +When a rule or inlining is active +-} + +-- | Phase Number +type PhaseNum = Int -- Compilation phase + -- Phases decrease towards zero + -- Zero is the last phase + +data CompilerPhase + = Phase PhaseNum + | InitialPhase -- The first phase -- number = infinity! + +instance Outputable CompilerPhase where + ppr (Phase n) = int n + ppr InitialPhase = text "InitialPhase" + +activeAfterInitial :: Activation +-- Active in the first phase after the initial phase +-- Currently we have just phases [2,1,0] +activeAfterInitial = ActiveAfter NoSourceText 2 + +activeDuringFinal :: Activation +-- Active in the final simplification phase (which is repeated) +activeDuringFinal = ActiveAfter NoSourceText 0 + +-- See note [Pragma source text] +data Activation = NeverActive + | AlwaysActive + | ActiveBefore SourceText PhaseNum + -- Active only *strictly before* this phase + | ActiveAfter SourceText PhaseNum + -- Active in this phase and later + deriving( Eq, Data ) + -- Eq used in comparing rules in HsDecls + +-- | Rule Match Information +data RuleMatchInfo = ConLike -- See Note [CONLIKE pragma] + | FunLike + deriving( Eq, Data, Show ) + -- Show needed for Lexer.x + +data InlinePragma -- Note [InlinePragma] + = InlinePragma + { inl_src :: SourceText -- Note [Pragma source text] + , inl_inline :: InlineSpec -- See Note [inl_inline and inl_act] + + , inl_sat :: Maybe Arity -- Just n <=> Inline only when applied to n + -- explicit (non-type, non-dictionary) args + -- That is, inl_sat describes the number of *source-code* + -- arguments the thing must be applied to. We add on the + -- number of implicit, dictionary arguments when making + -- the Unfolding, and don't look at inl_sat further + + , inl_act :: Activation -- Says during which phases inlining is allowed + -- See Note [inl_inline and inl_act] + + , inl_rule :: RuleMatchInfo -- Should the function be treated like a constructor? + } deriving( Eq, Data ) + +-- | Inline Specification +data InlineSpec -- What the user's INLINE pragma looked like + = Inline -- User wrote INLINE + | Inlinable -- User wrote INLINABLE + | NoInline -- User wrote NOINLINE + | NoUserInline -- User did not write any of INLINE/INLINABLE/NOINLINE + -- e.g. in `defaultInlinePragma` or when created by CSE + deriving( Eq, Data, Show ) + -- Show needed for Lexer.x + +{- Note [InlinePragma] +~~~~~~~~~~~~~~~~~~~~~~ +This data type mirrors what you can write in an INLINE or NOINLINE pragma in +the source program. + +If you write nothing at all, you get defaultInlinePragma: + inl_inline = NoUserInline + inl_act = AlwaysActive + inl_rule = FunLike + +It's not possible to get that combination by *writing* something, so +if an Id has defaultInlinePragma it means the user didn't specify anything. + +If inl_inline = Inline or Inlineable, then the Id should have an InlineRule unfolding. + +If you want to know where InlinePragmas take effect: Look in DsBinds.makeCorePair + +Note [inl_inline and inl_act] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* inl_inline says what the user wrote: did she say INLINE, NOINLINE, + INLINABLE, or nothing at all + +* inl_act says in what phases the unfolding is active or inactive + E.g If you write INLINE[1] then inl_act will be set to ActiveAfter 1 + If you write NOINLINE[1] then inl_act will be set to ActiveBefore 1 + If you write NOINLINE[~1] then inl_act will be set to ActiveAfter 1 + So note that inl_act does not say what pragma you wrote: it just + expresses its consequences + +* inl_act just says when the unfolding is active; it doesn't say what + to inline. If you say INLINE f, then f's inl_act will be AlwaysActive, + but in addition f will get a "stable unfolding" with UnfoldingGuidance + that tells the inliner to be pretty eager about it. + +Note [CONLIKE pragma] +~~~~~~~~~~~~~~~~~~~~~ +The ConLike constructor of a RuleMatchInfo is aimed at the following. +Consider first + {-# RULE "r/cons" forall a as. r (a:as) = f (a+1) #-} + g b bs = let x = b:bs in ..x...x...(r x)... +Now, the rule applies to the (r x) term, because GHC "looks through" +the definition of 'x' to see that it is (b:bs). + +Now consider + {-# RULE "r/f" forall v. r (f v) = f (v+1) #-} + g v = let x = f v in ..x...x...(r x)... +Normally the (r x) would *not* match the rule, because GHC would be +scared about duplicating the redex (f v), so it does not "look +through" the bindings. + +However the CONLIKE modifier says to treat 'f' like a constructor in +this situation, and "look through" the unfolding for x. So (r x) +fires, yielding (f (v+1)). + +This is all controlled with a user-visible pragma: + {-# NOINLINE CONLIKE [1] f #-} + +The main effects of CONLIKE are: + + - The occurrence analyser (OccAnal) and simplifier (Simplify) treat + CONLIKE thing like constructors, by ANF-ing them + + - New function CoreUtils.exprIsExpandable is like exprIsCheap, but + additionally spots applications of CONLIKE functions + + - A CoreUnfolding has a field that caches exprIsExpandable + + - The rule matcher consults this field. See + Note [Expanding variables] in Rules.hs. +-} + +isConLike :: RuleMatchInfo -> Bool +isConLike ConLike = True +isConLike _ = False + +isFunLike :: RuleMatchInfo -> Bool +isFunLike FunLike = True +isFunLike _ = False + +noUserInlineSpec :: InlineSpec -> Bool +noUserInlineSpec NoUserInline = True +noUserInlineSpec _ = False + +defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma + :: InlinePragma +defaultInlinePragma = InlinePragma { inl_src = SourceText "{-# INLINE" + , inl_act = AlwaysActive + , inl_rule = FunLike + , inl_inline = NoUserInline + , inl_sat = Nothing } + +alwaysInlinePragma = defaultInlinePragma { inl_inline = Inline } +neverInlinePragma = defaultInlinePragma { inl_act = NeverActive } + +inlinePragmaSpec :: InlinePragma -> InlineSpec +inlinePragmaSpec = inl_inline + +-- A DFun has an always-active inline activation so that +-- exprIsConApp_maybe can "see" its unfolding +-- (However, its actual Unfolding is a DFunUnfolding, which is +-- never inlined other than via exprIsConApp_maybe.) +dfunInlinePragma = defaultInlinePragma { inl_act = AlwaysActive + , inl_rule = ConLike } + +isDefaultInlinePragma :: InlinePragma -> Bool +isDefaultInlinePragma (InlinePragma { inl_act = activation + , inl_rule = match_info + , inl_inline = inline }) + = noUserInlineSpec inline && isAlwaysActive activation && isFunLike match_info + +isInlinePragma :: InlinePragma -> Bool +isInlinePragma prag = case inl_inline prag of + Inline -> True + _ -> False + +isInlinablePragma :: InlinePragma -> Bool +isInlinablePragma prag = case inl_inline prag of + Inlinable -> True + _ -> False + +isAnyInlinePragma :: InlinePragma -> Bool +-- INLINE or INLINABLE +isAnyInlinePragma prag = case inl_inline prag of + Inline -> True + Inlinable -> True + _ -> False + +inlinePragmaSat :: InlinePragma -> Maybe Arity +inlinePragmaSat = inl_sat + +inlinePragmaActivation :: InlinePragma -> Activation +inlinePragmaActivation (InlinePragma { inl_act = activation }) = activation + +inlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo +inlinePragmaRuleMatchInfo (InlinePragma { inl_rule = info }) = info + +setInlinePragmaActivation :: InlinePragma -> Activation -> InlinePragma +setInlinePragmaActivation prag activation = prag { inl_act = activation } + +setInlinePragmaRuleMatchInfo :: InlinePragma -> RuleMatchInfo -> InlinePragma +setInlinePragmaRuleMatchInfo prag info = prag { inl_rule = info } + +instance Outputable Activation where + ppr AlwaysActive = empty + ppr NeverActive = brackets (text "~") + ppr (ActiveBefore _ n) = brackets (char '~' <> int n) + ppr (ActiveAfter _ n) = brackets (int n) + +instance Outputable RuleMatchInfo where + ppr ConLike = text "CONLIKE" + ppr FunLike = text "FUNLIKE" + +instance Outputable InlineSpec where + ppr Inline = text "INLINE" + ppr NoInline = text "NOINLINE" + ppr Inlinable = text "INLINABLE" + ppr NoUserInline = text "NOUSERINLINE" -- what is better? + +instance Outputable InlinePragma where + ppr = pprInline + +pprInline :: InlinePragma -> SDoc +pprInline = pprInline' True + +pprInlineDebug :: InlinePragma -> SDoc +pprInlineDebug = pprInline' False + +pprInline' :: Bool -- True <=> do not display the inl_inline field + -> InlinePragma + -> SDoc +pprInline' emptyInline (InlinePragma { inl_inline = inline, inl_act = activation + , inl_rule = info, inl_sat = mb_arity }) + = pp_inl inline <> pp_act inline activation <+> pp_sat <+> pp_info + where + pp_inl x = if emptyInline then empty else ppr x + + pp_act Inline AlwaysActive = empty + pp_act NoInline NeverActive = empty + pp_act _ act = ppr act + + pp_sat | Just ar <- mb_arity = parens (text "sat-args=" <> int ar) + | otherwise = empty + pp_info | isFunLike info = empty + | otherwise = ppr info + +isActive :: CompilerPhase -> Activation -> Bool +isActive InitialPhase AlwaysActive = True +isActive InitialPhase (ActiveBefore {}) = True +isActive InitialPhase _ = False +isActive (Phase p) act = isActiveIn p act + +isActiveIn :: PhaseNum -> Activation -> Bool +isActiveIn _ NeverActive = False +isActiveIn _ AlwaysActive = True +isActiveIn p (ActiveAfter _ n) = p <= n +isActiveIn p (ActiveBefore _ n) = p > n + +competesWith :: Activation -> Activation -> Bool +-- See Note [Activation competition] +competesWith NeverActive _ = False +competesWith _ NeverActive = False +competesWith AlwaysActive _ = True + +competesWith (ActiveBefore {}) AlwaysActive = True +competesWith (ActiveBefore {}) (ActiveBefore {}) = True +competesWith (ActiveBefore _ a) (ActiveAfter _ b) = a < b + +competesWith (ActiveAfter {}) AlwaysActive = False +competesWith (ActiveAfter {}) (ActiveBefore {}) = False +competesWith (ActiveAfter _ a) (ActiveAfter _ b) = a >= b + +{- Note [Competing activations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Sometimes a RULE and an inlining may compete, or two RULES. +See Note [Rules and inlining/other rules] in Desugar. + +We say that act1 "competes with" act2 iff + act1 is active in the phase when act2 *becomes* active +NB: remember that phases count *down*: 2, 1, 0! + +It's too conservative to ensure that the two are never simultaneously +active. For example, a rule might be always active, and an inlining +might switch on in phase 2. We could switch off the rule, but it does +no harm. +-} + +isNeverActive, isAlwaysActive, isEarlyActive :: Activation -> Bool +isNeverActive NeverActive = True +isNeverActive _ = False + +isAlwaysActive AlwaysActive = True +isAlwaysActive _ = False + +isEarlyActive AlwaysActive = True +isEarlyActive (ActiveBefore {}) = True +isEarlyActive _ = False + +-- | Integral Literal +-- +-- Used (instead of Integer) to represent negative zegative zero which is +-- required for NegativeLiterals extension to correctly parse `-0::Double` +-- as negative zero. See also #13211. +data IntegralLit + = IL { il_text :: SourceText + , il_neg :: Bool -- See Note [Negative zero] + , il_value :: Integer + } + deriving (Data, Show) + +mkIntegralLit :: Integral a => a -> IntegralLit +mkIntegralLit i = IL { il_text = SourceText (show i_integer) + , il_neg = i < 0 + , il_value = i_integer } + where + i_integer :: Integer + i_integer = toInteger i + +negateIntegralLit :: IntegralLit -> IntegralLit +negateIntegralLit (IL text neg value) + = case text of + SourceText ('-':src) -> IL (SourceText src) False (negate value) + SourceText src -> IL (SourceText ('-':src)) True (negate value) + NoSourceText -> IL NoSourceText (not neg) (negate value) + +-- | Fractional Literal +-- +-- Used (instead of Rational) to represent exactly the floating point literal that we +-- encountered in the user's source program. This allows us to pretty-print exactly what +-- the user wrote, which is important e.g. for floating point numbers that can't represented +-- as Doubles (we used to via Double for pretty-printing). See also #2245. +data FractionalLit + = FL { fl_text :: SourceText -- How the value was written in the source + , fl_neg :: Bool -- See Note [Negative zero] + , fl_value :: Rational -- Numeric value of the literal + } + deriving (Data, Show) + -- The Show instance is required for the derived Lexer.x:Token instance when DEBUG is on + +mkFractionalLit :: Real a => a -> FractionalLit +mkFractionalLit r = FL { fl_text = SourceText (show (realToFrac r::Double)) + -- Converting to a Double here may technically lose + -- precision (see #15502). We could alternatively + -- convert to a Rational for the most accuracy, but + -- it would cause Floats and Doubles to be displayed + -- strangely, so we opt not to do this. (In contrast + -- to mkIntegralLit, where we always convert to an + -- Integer for the highest accuracy.) + , fl_neg = r < 0 + , fl_value = toRational r } + +negateFractionalLit :: FractionalLit -> FractionalLit +negateFractionalLit (FL text neg value) + = case text of + SourceText ('-':src) -> FL (SourceText src) False value + SourceText src -> FL (SourceText ('-':src)) True value + NoSourceText -> FL NoSourceText (not neg) (negate value) + +integralFractionalLit :: Bool -> Integer -> FractionalLit +integralFractionalLit neg i = FL { fl_text = SourceText (show i), + fl_neg = neg, + fl_value = fromInteger i } + +-- Comparison operations are needed when grouping literals +-- for compiling pattern-matching (module MatchLit) + +instance Eq IntegralLit where + (==) = (==) `on` il_value + +instance Ord IntegralLit where + compare = compare `on` il_value + +instance Outputable IntegralLit where + ppr (IL (SourceText src) _ _) = text src + ppr (IL NoSourceText _ value) = text (show value) + +instance Eq FractionalLit where + (==) = (==) `on` fl_value + +instance Ord FractionalLit where + compare = compare `on` fl_value + +instance Outputable FractionalLit where + ppr f = pprWithSourceText (fl_text f) (rational (fl_value f)) + +{- +************************************************************************ +* * + IntWithInf +* * +************************************************************************ + +Represents an integer or positive infinity + +-} + +-- | An integer or infinity +data IntWithInf = Int {-# UNPACK #-} !Int + | Infinity + deriving Eq + +-- | A representation of infinity +infinity :: IntWithInf +infinity = Infinity + +instance Ord IntWithInf where + compare Infinity Infinity = EQ + compare (Int _) Infinity = LT + compare Infinity (Int _) = GT + compare (Int a) (Int b) = a `compare` b + +instance Outputable IntWithInf where + ppr Infinity = char '∞' + ppr (Int n) = int n + +instance Num IntWithInf where + (+) = plusWithInf + (*) = mulWithInf + + abs Infinity = Infinity + abs (Int n) = Int (abs n) + + signum Infinity = Int 1 + signum (Int n) = Int (signum n) + + fromInteger = Int . fromInteger + + (-) = panic "subtracting IntWithInfs" + +intGtLimit :: Int -> IntWithInf -> Bool +intGtLimit _ Infinity = False +intGtLimit n (Int m) = n > m + +-- | Add two 'IntWithInf's +plusWithInf :: IntWithInf -> IntWithInf -> IntWithInf +plusWithInf Infinity _ = Infinity +plusWithInf _ Infinity = Infinity +plusWithInf (Int a) (Int b) = Int (a + b) + +-- | Multiply two 'IntWithInf's +mulWithInf :: IntWithInf -> IntWithInf -> IntWithInf +mulWithInf Infinity _ = Infinity +mulWithInf _ Infinity = Infinity +mulWithInf (Int a) (Int b) = Int (a * b) + +-- | Turn a positive number into an 'IntWithInf', where 0 represents infinity +treatZeroAsInf :: Int -> IntWithInf +treatZeroAsInf 0 = Infinity +treatZeroAsInf n = Int n + +-- | Inject any integer into an 'IntWithInf' +mkIntWithInf :: Int -> IntWithInf +mkIntWithInf = Int + +data SpliceExplicitFlag + = ExplicitSplice | -- ^ <=> $(f x y) + ImplicitSplice -- ^ <=> f x y, i.e. a naked top level expression + deriving Data diff --git a/compiler/basicTypes/ConLike.hs b/compiler/basicTypes/ConLike.hs new file mode 100644 --- /dev/null +++ b/compiler/basicTypes/ConLike.hs @@ -0,0 +1,196 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1998 + +\section[ConLike]{@ConLike@: Constructor-like things} +-} + +{-# LANGUAGE CPP #-} + +module ConLike ( + ConLike(..) + , conLikeArity + , conLikeFieldLabels + , conLikeInstOrigArgTys + , conLikeExTyCoVars + , conLikeName + , conLikeStupidTheta + , conLikeWrapId_maybe + , conLikeImplBangs + , conLikeFullSig + , conLikeResTy + , conLikeFieldType + , conLikesWithFields + , conLikeIsInfix + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import DataCon +import PatSyn +import Outputable +import Unique +import Util +import Name +import BasicTypes +import TyCoRep (Type, ThetaType) +import Var +import Type (mkTyConApp) + +import qualified Data.Data as Data + +{- +************************************************************************ +* * +\subsection{Constructor-like things} +* * +************************************************************************ +-} + +-- | A constructor-like thing +data ConLike = RealDataCon DataCon + | PatSynCon PatSyn + +{- +************************************************************************ +* * +\subsection{Instances} +* * +************************************************************************ +-} + +instance Eq ConLike where + (==) = eqConLike + +eqConLike :: ConLike -> ConLike -> Bool +eqConLike x y = getUnique x == getUnique y + +-- There used to be an Ord ConLike instance here that used Unique for ordering. +-- It was intentionally removed to prevent determinism problems. +-- See Note [Unique Determinism] in Unique. + +instance Uniquable ConLike where + getUnique (RealDataCon dc) = getUnique dc + getUnique (PatSynCon ps) = getUnique ps + +instance NamedThing ConLike where + getName (RealDataCon dc) = getName dc + getName (PatSynCon ps) = getName ps + +instance Outputable ConLike where + ppr (RealDataCon dc) = ppr dc + ppr (PatSynCon ps) = ppr ps + +instance OutputableBndr ConLike where + pprInfixOcc (RealDataCon dc) = pprInfixOcc dc + pprInfixOcc (PatSynCon ps) = pprInfixOcc ps + pprPrefixOcc (RealDataCon dc) = pprPrefixOcc dc + pprPrefixOcc (PatSynCon ps) = pprPrefixOcc ps + +instance Data.Data ConLike where + -- don't traverse? + toConstr _ = abstractConstr "ConLike" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "ConLike" + +-- | Number of arguments +conLikeArity :: ConLike -> Arity +conLikeArity (RealDataCon data_con) = dataConSourceArity data_con +conLikeArity (PatSynCon pat_syn) = patSynArity pat_syn + +-- | Names of fields used for selectors +conLikeFieldLabels :: ConLike -> [FieldLabel] +conLikeFieldLabels (RealDataCon data_con) = dataConFieldLabels data_con +conLikeFieldLabels (PatSynCon pat_syn) = patSynFieldLabels pat_syn + +-- | Returns just the instantiated /value/ argument types of a 'ConLike', +-- (excluding dictionary args) +conLikeInstOrigArgTys :: ConLike -> [Type] -> [Type] +conLikeInstOrigArgTys (RealDataCon data_con) tys = + dataConInstOrigArgTys data_con tys +conLikeInstOrigArgTys (PatSynCon pat_syn) tys = + patSynInstArgTys pat_syn tys + +-- | Existentially quantified type/coercion variables +conLikeExTyCoVars :: ConLike -> [TyCoVar] +conLikeExTyCoVars (RealDataCon dcon1) = dataConExTyCoVars dcon1 +conLikeExTyCoVars (PatSynCon psyn1) = patSynExTyVars psyn1 + +conLikeName :: ConLike -> Name +conLikeName (RealDataCon data_con) = dataConName data_con +conLikeName (PatSynCon pat_syn) = patSynName pat_syn + +-- | The \"stupid theta\" of the 'ConLike', such as @data Eq a@ in: +-- +-- > data Eq a => T a = ... +-- It is empty for `PatSynCon` as they do not allow such contexts. +conLikeStupidTheta :: ConLike -> ThetaType +conLikeStupidTheta (RealDataCon data_con) = dataConStupidTheta data_con +conLikeStupidTheta (PatSynCon {}) = [] + +-- | Returns the `Id` of the wrapper. This is also known as the builder in +-- some contexts. The value is Nothing only in the case of unidirectional +-- pattern synonyms. +conLikeWrapId_maybe :: ConLike -> Maybe Id +conLikeWrapId_maybe (RealDataCon data_con) = Just $ dataConWrapId data_con +conLikeWrapId_maybe (PatSynCon pat_syn) = fst <$> patSynBuilder pat_syn + +-- | Returns the strictness information for each constructor +conLikeImplBangs :: ConLike -> [HsImplBang] +conLikeImplBangs (RealDataCon data_con) = dataConImplBangs data_con +conLikeImplBangs (PatSynCon pat_syn) = + replicate (patSynArity pat_syn) HsLazy + +-- | Returns the type of the whole pattern +conLikeResTy :: ConLike -> [Type] -> Type +conLikeResTy (RealDataCon con) tys = mkTyConApp (dataConTyCon con) tys +conLikeResTy (PatSynCon ps) tys = patSynInstResTy ps tys + +-- | The \"full signature\" of the 'ConLike' returns, in order: +-- +-- 1) The universally quantified type variables +-- +-- 2) The existentially quantified type/coercion variables +-- +-- 3) The equality specification +-- +-- 4) The provided theta (the constraints provided by a match) +-- +-- 5) The required theta (the constraints required for a match) +-- +-- 6) The original argument types (i.e. before +-- any change of the representation of the type) +-- +-- 7) The original result type +conLikeFullSig :: ConLike + -> ([TyVar], [TyCoVar], [EqSpec] + -- Why tyvars for universal but tycovars for existential? + -- See Note [Existential coercion variables] in DataCon + , ThetaType, ThetaType, [Type], Type) +conLikeFullSig (RealDataCon con) = + let (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty) = dataConFullSig con + -- Required theta is empty as normal data cons require no additional + -- constraints for a match + in (univ_tvs, ex_tvs, eq_spec, theta, [], arg_tys, res_ty) +conLikeFullSig (PatSynCon pat_syn) = + let (univ_tvs, req, ex_tvs, prov, arg_tys, res_ty) = patSynSig pat_syn + -- eqSpec is empty + in (univ_tvs, ex_tvs, [], prov, req, arg_tys, res_ty) + +-- | Extract the type for any given labelled field of the 'ConLike' +conLikeFieldType :: ConLike -> FieldLabelString -> Type +conLikeFieldType (PatSynCon ps) label = patSynFieldType ps label +conLikeFieldType (RealDataCon dc) label = dataConFieldType dc label + + +-- | The ConLikes that have *all* the given fields +conLikesWithFields :: [ConLike] -> [FieldLabelString] -> [ConLike] +conLikesWithFields con_likes lbls = filter has_flds con_likes + where has_flds dc = all (has_fld dc) lbls + has_fld dc lbl = any (\ fl -> flLabel fl == lbl) (conLikeFieldLabels dc) + +conLikeIsInfix :: ConLike -> Bool +conLikeIsInfix (RealDataCon dc) = dataConIsInfix dc +conLikeIsInfix (PatSynCon ps) = patSynIsInfix ps diff --git a/compiler/basicTypes/ConLike.hs-boot b/compiler/basicTypes/ConLike.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/basicTypes/ConLike.hs-boot @@ -0,0 +1,9 @@ +module ConLike where +import {-# SOURCE #-} DataCon (DataCon) +import {-# SOURCE #-} PatSyn (PatSyn) +import Name ( Name ) + +data ConLike = RealDataCon DataCon + | PatSynCon PatSyn + +conLikeName :: ConLike -> Name diff --git a/compiler/basicTypes/DataCon.hs b/compiler/basicTypes/DataCon.hs new file mode 100644 --- /dev/null +++ b/compiler/basicTypes/DataCon.hs @@ -0,0 +1,1515 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1998 + +\section[DataCon]{@DataCon@: Data Constructors} +-} + +{-# LANGUAGE CPP, DeriveDataTypeable #-} + +module DataCon ( + -- * Main data types + DataCon, DataConRep(..), + SrcStrictness(..), SrcUnpackedness(..), + HsSrcBang(..), HsImplBang(..), + StrictnessMark(..), + ConTag, + + -- ** Equality specs + EqSpec, mkEqSpec, eqSpecTyVar, eqSpecType, + eqSpecPair, eqSpecPreds, + substEqSpec, filterEqSpec, + + -- ** Field labels + FieldLbl(..), FieldLabel, FieldLabelString, + + -- ** Type construction + mkDataCon, buildAlgTyCon, buildSynTyCon, fIRST_TAG, + + -- ** Type deconstruction + dataConRepType, dataConSig, dataConInstSig, dataConFullSig, + dataConName, dataConIdentity, dataConTag, dataConTagZ, + dataConTyCon, dataConOrigTyCon, + dataConUserType, + dataConUnivTyVars, dataConExTyCoVars, dataConUnivAndExTyCoVars, + dataConUserTyVars, dataConUserTyVarBinders, + dataConEqSpec, dataConTheta, + dataConStupidTheta, + dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy, + dataConInstOrigArgTys, dataConRepArgTys, + dataConFieldLabels, dataConFieldType, dataConFieldType_maybe, + dataConSrcBangs, + dataConSourceArity, dataConRepArity, + dataConIsInfix, + dataConWorkId, dataConWrapId, dataConWrapId_maybe, + dataConImplicitTyThings, + dataConRepStrictness, dataConImplBangs, dataConBoxer, + + splitDataProductType_maybe, + + -- ** Predicates on DataCons + isNullarySrcDataCon, isNullaryRepDataCon, isTupleDataCon, isUnboxedTupleCon, + isUnboxedSumCon, + isVanillaDataCon, classDataCon, dataConCannotMatch, + dataConUserTyVarsArePermuted, + isBanged, isMarkedStrict, eqHsBang, isSrcStrict, isSrcUnpacked, + specialPromotedDc, + + -- ** Promotion related functions + promoteDataCon + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import {-# SOURCE #-} MkId( DataConBoxer ) +import Type +import ForeignCall ( CType ) +import Coercion +import Unify +import TyCon +import FieldLabel +import Class +import Name +import PrelNames +import Var +import VarSet( emptyVarSet ) +import Outputable +import Util +import BasicTypes +import FastString +import Module +import Binary +import UniqSet +import Unique( mkAlphaTyVarUnique ) + +import Data.ByteString (ByteString) +import qualified Data.ByteString.Builder as BSB +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Data as Data +import Data.Char +import Data.List( find ) + +{- +Data constructor representation +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following Haskell data type declaration + + data T = T !Int ![Int] + +Using the strictness annotations, GHC will represent this as + + data T = T Int# [Int] + +That is, the Int has been unboxed. Furthermore, the Haskell source construction + + T e1 e2 + +is translated to + + case e1 of { I# x -> + case e2 of { r -> + T x r }} + +That is, the first argument is unboxed, and the second is evaluated. Finally, +pattern matching is translated too: + + case e of { T a b -> ... } + +becomes + + case e of { T a' b -> let a = I# a' in ... } + +To keep ourselves sane, we name the different versions of the data constructor +differently, as follows. + + +Note [Data Constructor Naming] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Each data constructor C has two, and possibly up to four, Names associated with it: + + OccName Name space Name of Notes + --------------------------------------------------------------------------- + The "data con itself" C DataName DataCon In dom( GlobalRdrEnv ) + The "worker data con" C VarName Id The worker + The "wrapper data con" $WC VarName Id The wrapper + The "newtype coercion" :CoT TcClsName TyCon + +EVERY data constructor (incl for newtypes) has the former two (the +data con itself, and its worker. But only some data constructors have a +wrapper (see Note [The need for a wrapper]). + +Each of these three has a distinct Unique. The "data con itself" name +appears in the output of the renamer, and names the Haskell-source +data constructor. The type checker translates it into either the wrapper Id +(if it exists) or worker Id (otherwise). + +The data con has one or two Ids associated with it: + +The "worker Id", is the actual data constructor. +* Every data constructor (newtype or data type) has a worker + +* The worker is very like a primop, in that it has no binding. + +* For a *data* type, the worker *is* the data constructor; + it has no unfolding + +* For a *newtype*, the worker has a compulsory unfolding which + does a cast, e.g. + newtype T = MkT Int + The worker for MkT has unfolding + \\(x:Int). x `cast` sym CoT + Here CoT is the type constructor, witnessing the FC axiom + axiom CoT : T = Int + +The "wrapper Id", \$WC, goes as follows + +* Its type is exactly what it looks like in the source program. + +* It is an ordinary function, and it gets a top-level binding + like any other function. + +* The wrapper Id isn't generated for a data type if there is + nothing for the wrapper to do. That is, if its defn would be + \$wC = C + +Note [Data constructor workers and wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Algebraic data types + - Always have a worker, with no unfolding + - May or may not have a wrapper; see Note [The need for a wrapper] + +* Newtypes + - Always have a worker, which has a compulsory unfolding (just a cast) + - May or may not have a wrapper; see Note [The need for a wrapper] + +* INVARIANT: the dictionary constructor for a class + never has a wrapper. + +* Neither_ the worker _nor_ the wrapper take the dcStupidTheta dicts as arguments + +* The wrapper (if it exists) takes dcOrigArgTys as its arguments + The worker takes dataConRepArgTys as its arguments + If the worker is absent, dataConRepArgTys is the same as dcOrigArgTys + +* The 'NoDataConRep' case of DataConRep is important. Not only is it + efficient, but it also ensures that the wrapper is replaced by the + worker (because it *is* the worker) even when there are no + args. E.g. in + f (:) x + the (:) *is* the worker. This is really important in rule matching, + (We could match on the wrappers, but that makes it less likely that + rules will match when we bring bits of unfoldings together.) + +Note [The need for a wrapper] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Why might the wrapper have anything to do? The full story is +in wrapper_reqd in MkId.mkDataConRep. + +* Unboxing strict fields (with -funbox-strict-fields) + data T = MkT !(Int,Int) + \$wMkT :: (Int,Int) -> T + \$wMkT (x,y) = MkT x y + Notice that the worker has two fields where the wapper has + just one. That is, the worker has type + MkT :: Int -> Int -> T + +* Equality constraints for GADTs + data T a where { MkT :: a -> T [a] } + + The worker gets a type with explicit equality + constraints, thus: + MkT :: forall a b. (a=[b]) => b -> T a + + The wrapper has the programmer-specified type: + \$wMkT :: a -> T [a] + \$wMkT a x = MkT [a] a [a] x + The third argument is a coercion + [a] :: [a]~[a] + +* Data family instances may do a cast on the result + +* Type variables may be permuted; see MkId + Note [Data con wrappers and GADT syntax] + + +Note [The stupid context] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Data types can have a context: + + data (Eq a, Ord b) => T a b = T1 a b | T2 a + +and that makes the constructors have a context too +(notice that T2's context is "thinned"): + + T1 :: (Eq a, Ord b) => a -> b -> T a b + T2 :: (Eq a) => a -> T a b + +Furthermore, this context pops up when pattern matching +(though GHC hasn't implemented this, but it is in H98, and +I've fixed GHC so that it now does): + + f (T2 x) = x +gets inferred type + f :: Eq a => T a b -> a + +I say the context is "stupid" because the dictionaries passed +are immediately discarded -- they do nothing and have no benefit. +It's a flaw in the language. + + Up to now [March 2002] I have put this stupid context into the + type of the "wrapper" constructors functions, T1 and T2, but + that turned out to be jolly inconvenient for generics, and + record update, and other functions that build values of type T + (because they don't have suitable dictionaries available). + + So now I've taken the stupid context out. I simply deal with + it separately in the type checker on occurrences of a + constructor, either in an expression or in a pattern. + + [May 2003: actually I think this decision could easily be + reversed now, and probably should be. Generics could be + disabled for types with a stupid context; record updates now + (H98) needs the context too; etc. It's an unforced change, so + I'm leaving it for now --- but it does seem odd that the + wrapper doesn't include the stupid context.] + +[July 04] With the advent of generalised data types, it's less obvious +what the "stupid context" is. Consider + C :: forall a. Ord a => a -> a -> T (Foo a) +Does the C constructor in Core contain the Ord dictionary? Yes, it must: + + f :: T b -> Ordering + f = /\b. \x:T b. + case x of + C a (d:Ord a) (p:a) (q:a) -> compare d p q + +Note that (Foo a) might not be an instance of Ord. + +************************************************************************ +* * +\subsection{Data constructors} +* * +************************************************************************ +-} + +-- | A data constructor +-- +-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', +-- 'ApiAnnotation.AnnClose','ApiAnnotation.AnnComma' + +-- For details on above see note [Api annotations] in ApiAnnotation +data DataCon + = MkData { + dcName :: Name, -- This is the name of the *source data con* + -- (see "Note [Data Constructor Naming]" above) + dcUnique :: Unique, -- Cached from Name + dcTag :: ConTag, -- ^ Tag, used for ordering 'DataCon's + + -- Running example: + -- + -- *** As declared by the user + -- data T a b c where + -- MkT :: forall c y x b. (x~y,Ord x) => x -> y -> T (x,y) b c + + -- *** As represented internally + -- data T a b c where + -- MkT :: forall a b c. forall x y. (a~(x,y),x~y,Ord x) + -- => x -> y -> T a b c + -- + -- The next six fields express the type of the constructor, in pieces + -- e.g. + -- + -- dcUnivTyVars = [a,b,c] + -- dcExTyCoVars = [x,y] + -- dcUserTyVarBinders = [c,y,x,b] + -- dcEqSpec = [a~(x,y)] + -- dcOtherTheta = [x~y, Ord x] + -- dcOrigArgTys = [x,y] + -- dcRepTyCon = T + + -- In general, the dcUnivTyVars are NOT NECESSARILY THE SAME AS THE + -- TYVARS FOR THE PARENT TyCon. (This is a change (Oct05): previously, + -- vanilla datacons guaranteed to have the same type variables as their + -- parent TyCon, but that seems ugly.) They can be different in the case + -- where a GADT constructor uses different names for the universal + -- tyvars than does the tycon. For example: + -- + -- data H a where + -- MkH :: b -> H b + -- + -- Here, the tyConTyVars of H will be [a], but the dcUnivTyVars of MkH + -- will be [b]. + + dcVanilla :: Bool, -- True <=> This is a vanilla Haskell 98 data constructor + -- Its type is of form + -- forall a1..an . t1 -> ... tm -> T a1..an + -- No existentials, no coercions, nothing. + -- That is: dcExTyCoVars = dcEqSpec = dcOtherTheta = [] + -- NB 1: newtypes always have a vanilla data con + -- NB 2: a vanilla constructor can still be declared in GADT-style + -- syntax, provided its type looks like the above. + -- The declaration format is held in the TyCon (algTcGadtSyntax) + + -- Universally-quantified type vars [a,b,c] + -- INVARIANT: length matches arity of the dcRepTyCon + -- INVARIANT: result type of data con worker is exactly (T a b c) + -- COROLLARY: The dcUnivTyVars are always in one-to-one correspondence with + -- the tyConTyVars of the parent TyCon + dcUnivTyVars :: [TyVar], + + -- Existentially-quantified type and coercion vars [x,y] + -- For an example involving coercion variables, + -- Why tycovars? See Note [Existential coercion variables] + dcExTyCoVars :: [TyCoVar], + + -- INVARIANT: the UnivTyVars and ExTyCoVars all have distinct OccNames + -- Reason: less confusing, and easier to generate IfaceSyn + + -- The type/coercion vars in the order the user wrote them [c,y,x,b] + -- INVARIANT: the set of tyvars in dcUserTyVarBinders is exactly the set + -- of tyvars (*not* covars) of dcExTyCoVars unioned with the + -- set of dcUnivTyVars whose tyvars do not appear in dcEqSpec + -- See Note [DataCon user type variable binders] + dcUserTyVarBinders :: [TyVarBinder], + + dcEqSpec :: [EqSpec], -- Equalities derived from the result type, + -- _as written by the programmer_. + -- Only non-dependent GADT equalities (dependent + -- GADT equalities are in the covars of + -- dcExTyCoVars). + + -- This field allows us to move conveniently between the two ways + -- of representing a GADT constructor's type: + -- MkT :: forall a b. (a ~ [b]) => b -> T a + -- MkT :: forall b. b -> T [b] + -- Each equality is of the form (a ~ ty), where 'a' is one of + -- the universally quantified type variables + + -- The next two fields give the type context of the data constructor + -- (aside from the GADT constraints, + -- which are given by the dcExpSpec) + -- In GADT form, this is *exactly* what the programmer writes, even if + -- the context constrains only universally quantified variables + -- MkT :: forall a b. (a ~ b, Ord b) => a -> T a b + dcOtherTheta :: ThetaType, -- The other constraints in the data con's type + -- other than those in the dcEqSpec + + dcStupidTheta :: ThetaType, -- The context of the data type declaration + -- data Eq a => T a = ... + -- or, rather, a "thinned" version thereof + -- "Thinned", because the Report says + -- to eliminate any constraints that don't mention + -- tyvars free in the arg types for this constructor + -- + -- INVARIANT: the free tyvars of dcStupidTheta are a subset of dcUnivTyVars + -- Reason: dcStupidTeta is gotten by thinning the stupid theta from the tycon + -- + -- "Stupid", because the dictionaries aren't used for anything. + -- Indeed, [as of March 02] they are no longer in the type of + -- the wrapper Id, because that makes it harder to use the wrap-id + -- to rebuild values after record selection or in generics. + + dcOrigArgTys :: [Type], -- Original argument types + -- (before unboxing and flattening of strict fields) + dcOrigResTy :: Type, -- Original result type, as seen by the user + -- NB: for a data instance, the original user result type may + -- differ from the DataCon's representation TyCon. Example + -- data instance T [a] where MkT :: a -> T [a] + -- The OrigResTy is T [a], but the dcRepTyCon might be :T123 + + -- Now the strictness annotations and field labels of the constructor + dcSrcBangs :: [HsSrcBang], + -- See Note [Bangs on data constructor arguments] + -- + -- The [HsSrcBang] as written by the programmer. + -- + -- Matches 1-1 with dcOrigArgTys + -- Hence length = dataConSourceArity dataCon + + dcFields :: [FieldLabel], + -- Field labels for this constructor, in the + -- same order as the dcOrigArgTys; + -- length = 0 (if not a record) or dataConSourceArity. + + -- The curried worker function that corresponds to the constructor: + -- It doesn't have an unfolding; the code generator saturates these Ids + -- and allocates a real constructor when it finds one. + dcWorkId :: Id, + + -- Constructor representation + dcRep :: DataConRep, + + -- Cached; see Note [DataCon arities] + -- INVARIANT: dcRepArity == length dataConRepArgTys + count isCoVar (dcExTyCoVars) + -- INVARIANT: dcSourceArity == length dcOrigArgTys + dcRepArity :: Arity, + dcSourceArity :: Arity, + + -- Result type of constructor is T t1..tn + dcRepTyCon :: TyCon, -- Result tycon, T + + dcRepType :: Type, -- Type of the constructor + -- forall a x y. (a~(x,y), x~y, Ord x) => + -- x -> y -> T a + -- (this is *not* of the constructor wrapper Id: + -- see Note [Data con representation] below) + -- Notice that the existential type parameters come *second*. + -- Reason: in a case expression we may find: + -- case (e :: T t) of + -- MkT x y co1 co2 (d:Ord x) (v:r) (w:F s) -> ... + -- It's convenient to apply the rep-type of MkT to 't', to get + -- forall x y. (t~(x,y), x~y, Ord x) => x -> y -> T t + -- and use that to check the pattern. Mind you, this is really only + -- used in CoreLint. + + + dcInfix :: Bool, -- True <=> declared infix + -- Used for Template Haskell and 'deriving' only + -- The actual fixity is stored elsewhere + + dcPromoted :: TyCon -- The promoted TyCon + -- See Note [Promoted data constructors] in TyCon + } + + +{- Note [TyVarBinders in DataCons] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For the TyVarBinders in a DataCon and PatSyn: + + * Each argument flag is Inferred or Specified. + None are Required. (A DataCon is a term-level function; see + Note [No Required TyCoBinder in terms] in TyCoRep.) + +Why do we need the TyVarBinders, rather than just the TyVars? So that +we can construct the right type for the DataCon with its foralls +attributed the correct visibility. That in turn governs whether you +can use visible type application at a call of the data constructor. + +See also [DataCon user type variable binders] for an extended discussion on the +order in which TyVarBinders appear in a DataCon. + +Note [Existential coercion variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +For now (Aug 2018) we can't write coercion quantifications in source Haskell, but +we can in Core. Consider having: + + data T :: forall k. k -> k -> Constraint where + MkT :: forall k (a::k) (b::k). forall k' (c::k') (co::k'~k). (b~(c|>co)) + => T k a b + + dcUnivTyVars = [k,a,b] + dcExTyCoVars = [k',c,co] + dcUserTyVarBinders = [k,a,k',c] + dcEqSpec = [b~(c|>co)] + dcOtherTheta = [] + dcOrigArgTys = [] + dcRepTyCon = T + + Function call 'dataConKindEqSpec' returns [k'~k] + +Note [DataCon arities] +~~~~~~~~~~~~~~~~~~~~~~ +dcSourceArity does not take constraints into account, +but dcRepArity does. For example: + MkT :: Ord a => a -> T a + dcSourceArity = 1 + dcRepArity = 2 + +Note [DataCon user type variable binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In System FC, data constructor type signatures always quantify over all of +their universal type variables, followed by their existential type variables. +Normally, this isn't a problem, as most datatypes naturally quantify their type +variables in this order anyway. For example: + + data T a b = forall c. MkT b c + +Here, we have `MkT :: forall {k} (a :: k) (b :: *) (c :: *). b -> c -> T a b`, +where k, a, and b are universal and c is existential. (The inferred variable k +isn't available for TypeApplications, hence why it's in braces.) This is a +perfectly reasonable order to use, as the syntax of H98-style datatypes +(+ ExistentialQuantification) suggests it. + +Things become more complicated when GADT syntax enters the picture. Consider +this example: + + data X a where + MkX :: forall b a. b -> Proxy a -> X a + +If we adopt the earlier approach of quantifying all the universal variables +followed by all the existential ones, GHC would come up with this type +signature for MkX: + + MkX :: forall {k} (a :: k) (b :: *). b -> Proxy a -> X a + +But this is not what we want at all! After all, if a user were to use +TypeApplications on MkX, they would expect to instantiate `b` before `a`, +as that's the order in which they were written in the `forall`. (See #11721.) +Instead, we'd like GHC to come up with this type signature: + + MkX :: forall {k} (b :: *) (a :: k). b -> Proxy a -> X a + +In fact, even if we left off the explicit forall: + + data X a where + MkX :: b -> Proxy a -> X a + +Then a user should still expect `b` to be quantified before `a`, since +according to the rules of TypeApplications, in the absence of `forall` GHC +performs a stable topological sort on the type variables in the user-written +type signature, which would place `b` before `a`. + +But as noted above, enacting this behavior is not entirely trivial, as System +FC demands the variables go in universal-then-existential order under the hood. +Our solution is thus to equip DataCon with two different sets of type +variables: + +* dcUnivTyVars and dcExTyCoVars, for the universal type variable and existential + type/coercion variables, respectively. Their order is irrelevant for the + purposes of TypeApplications, and as a consequence, they do not come equipped + with visibilities (that is, they are TyVars/TyCoVars instead of + TyCoVarBinders). +* dcUserTyVarBinders, for the type variables binders in the order in which they + originally arose in the user-written type signature. Their order *does* matter + for TypeApplications, so they are full TyVarBinders, complete with + visibilities. + +This encoding has some redundancy. The set of tyvars in dcUserTyVarBinders +consists precisely of: + +* The set of tyvars in dcUnivTyVars whose type variables do not appear in + dcEqSpec, unioned with: +* The set of tyvars (*not* covars) in dcExTyCoVars + No covars here because because they're not user-written + +The word "set" is used above because the order in which the tyvars appear in +dcUserTyVarBinders can be completely different from the order in dcUnivTyVars or +dcExTyCoVars. That is, the tyvars in dcUserTyVarBinders are a permutation of +(tyvars of dcExTyCoVars + a subset of dcUnivTyVars). But aside from the +ordering, they in fact share the same type variables (with the same Uniques). We +sometimes refer to this as "the dcUserTyVarBinders invariant". + +dcUserTyVarBinders, as the name suggests, is the one that users will see most of +the time. It's used when computing the type signature of a data constructor (see +dataConUserType), and as a result, it's what matters from a TypeApplications +perspective. +-} + +-- | Data Constructor Representation +-- See Note [Data constructor workers and wrappers] +data DataConRep + = -- NoDataConRep means that the data con has no wrapper + NoDataConRep + + -- DCR means that the data con has a wrapper + | DCR { dcr_wrap_id :: Id -- Takes src args, unboxes/flattens, + -- and constructs the representation + + , dcr_boxer :: DataConBoxer + + , dcr_arg_tys :: [Type] -- Final, representation argument types, + -- after unboxing and flattening, + -- and *including* all evidence args + + , dcr_stricts :: [StrictnessMark] -- 1-1 with dcr_arg_tys + -- See also Note [Data-con worker strictness] in MkId.hs + + , dcr_bangs :: [HsImplBang] -- The actual decisions made (including failures) + -- about the original arguments; 1-1 with orig_arg_tys + -- See Note [Bangs on data constructor arguments] + + } + +------------------------- + +-- | Haskell Source Bang +-- +-- Bangs on data constructor arguments as the user wrote them in the +-- source code. +-- +-- @(HsSrcBang _ SrcUnpack SrcLazy)@ and +-- @(HsSrcBang _ SrcUnpack NoSrcStrict)@ (without StrictData) makes no sense, we +-- emit a warning (in checkValidDataCon) and treat it like +-- @(HsSrcBang _ NoSrcUnpack SrcLazy)@ +data HsSrcBang = + HsSrcBang SourceText -- Note [Pragma source text] in BasicTypes + SrcUnpackedness + SrcStrictness + deriving Data.Data + +-- | Haskell Implementation Bang +-- +-- Bangs of data constructor arguments as generated by the compiler +-- after consulting HsSrcBang, flags, etc. +data HsImplBang + = HsLazy -- ^ Lazy field, or one with an unlifted type + | HsStrict -- ^ Strict but not unpacked field + | HsUnpack (Maybe Coercion) + -- ^ Strict and unpacked field + -- co :: arg-ty ~ product-ty HsBang + deriving Data.Data + +-- | Source Strictness +-- +-- What strictness annotation the user wrote +data SrcStrictness = SrcLazy -- ^ Lazy, ie '~' + | SrcStrict -- ^ Strict, ie '!' + | NoSrcStrict -- ^ no strictness annotation + deriving (Eq, Data.Data) + +-- | Source Unpackedness +-- +-- What unpackedness the user requested +data SrcUnpackedness = SrcUnpack -- ^ {-# UNPACK #-} specified + | SrcNoUnpack -- ^ {-# NOUNPACK #-} specified + | NoSrcUnpack -- ^ no unpack pragma + deriving (Eq, Data.Data) + + + +------------------------- +-- StrictnessMark is internal only, used to indicate strictness +-- of the DataCon *worker* fields +data StrictnessMark = MarkedStrict | NotMarkedStrict + +-- | An 'EqSpec' is a tyvar/type pair representing an equality made in +-- rejigging a GADT constructor +data EqSpec = EqSpec TyVar + Type + +-- | Make a non-dependent 'EqSpec' +mkEqSpec :: TyVar -> Type -> EqSpec +mkEqSpec tv ty = EqSpec tv ty + +eqSpecTyVar :: EqSpec -> TyVar +eqSpecTyVar (EqSpec tv _) = tv + +eqSpecType :: EqSpec -> Type +eqSpecType (EqSpec _ ty) = ty + +eqSpecPair :: EqSpec -> (TyVar, Type) +eqSpecPair (EqSpec tv ty) = (tv, ty) + +eqSpecPreds :: [EqSpec] -> ThetaType +eqSpecPreds spec = [ mkPrimEqPred (mkTyVarTy tv) ty + | EqSpec tv ty <- spec ] + +-- | Substitute in an 'EqSpec'. Precondition: if the LHS of the EqSpec +-- is mapped in the substitution, it is mapped to a type variable, not +-- a full type. +substEqSpec :: TCvSubst -> EqSpec -> EqSpec +substEqSpec subst (EqSpec tv ty) + = EqSpec tv' (substTy subst ty) + where + tv' = getTyVar "substEqSpec" (substTyVar subst tv) + +-- | Filter out any 'TyVar's mentioned in an 'EqSpec'. +filterEqSpec :: [EqSpec] -> [TyVar] -> [TyVar] +filterEqSpec eq_spec + = filter not_in_eq_spec + where + not_in_eq_spec var = all (not . (== var) . eqSpecTyVar) eq_spec + +instance Outputable EqSpec where + ppr (EqSpec tv ty) = ppr (tv, ty) + +{- Note [Bangs on data constructor arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T = MkT !Int {-# UNPACK #-} !Int Bool + +When compiling the module, GHC will decide how to represent +MkT, depending on the optimisation level, and settings of +flags like -funbox-small-strict-fields. + +Terminology: + * HsSrcBang: What the user wrote + Constructors: HsSrcBang + + * HsImplBang: What GHC decided + Constructors: HsLazy, HsStrict, HsUnpack + +* If T was defined in this module, MkT's dcSrcBangs field + records the [HsSrcBang] of what the user wrote; in the example + [ HsSrcBang _ NoSrcUnpack SrcStrict + , HsSrcBang _ SrcUnpack SrcStrict + , HsSrcBang _ NoSrcUnpack NoSrcStrictness] + +* However, if T was defined in an imported module, the importing module + must follow the decisions made in the original module, regardless of + the flag settings in the importing module. + Also see Note [Bangs on imported data constructors] in MkId + +* The dcr_bangs field of the dcRep field records the [HsImplBang] + If T was defined in this module, Without -O the dcr_bangs might be + [HsStrict, HsStrict, HsLazy] + With -O it might be + [HsStrict, HsUnpack _, HsLazy] + With -funbox-small-strict-fields it might be + [HsUnpack, HsUnpack _, HsLazy] + With -XStrictData it might be + [HsStrict, HsUnpack _, HsStrict] + +Note [Data con representation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The dcRepType field contains the type of the representation of a constructor +This may differ from the type of the constructor *Id* (built +by MkId.mkDataConId) for two reasons: + a) the constructor Id may be overloaded, but the dictionary isn't stored + e.g. data Eq a => T a = MkT a a + + b) the constructor may store an unboxed version of a strict field. + +Here's an example illustrating both: + data Ord a => T a = MkT Int! a +Here + T :: Ord a => Int -> a -> T a +but the rep type is + Trep :: Int# -> a -> T a +Actually, the unboxed part isn't implemented yet! + + + +************************************************************************ +* * +\subsection{Instances} +* * +************************************************************************ +-} + +instance Eq DataCon where + a == b = getUnique a == getUnique b + a /= b = getUnique a /= getUnique b + +instance Uniquable DataCon where + getUnique = dcUnique + +instance NamedThing DataCon where + getName = dcName + +instance Outputable DataCon where + ppr con = ppr (dataConName con) + +instance OutputableBndr DataCon where + pprInfixOcc con = pprInfixName (dataConName con) + pprPrefixOcc con = pprPrefixName (dataConName con) + +instance Data.Data DataCon where + -- don't traverse? + toConstr _ = abstractConstr "DataCon" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "DataCon" + +instance Outputable HsSrcBang where + ppr (HsSrcBang _ prag mark) = ppr prag <+> ppr mark + +instance Outputable HsImplBang where + ppr HsLazy = text "Lazy" + ppr (HsUnpack Nothing) = text "Unpacked" + ppr (HsUnpack (Just co)) = text "Unpacked" <> parens (ppr co) + ppr HsStrict = text "StrictNotUnpacked" + +instance Outputable SrcStrictness where + ppr SrcLazy = char '~' + ppr SrcStrict = char '!' + ppr NoSrcStrict = empty + +instance Outputable SrcUnpackedness where + ppr SrcUnpack = text "{-# UNPACK #-}" + ppr SrcNoUnpack = text "{-# NOUNPACK #-}" + ppr NoSrcUnpack = empty + +instance Outputable StrictnessMark where + ppr MarkedStrict = text "!" + ppr NotMarkedStrict = empty + +instance Binary SrcStrictness where + put_ bh SrcLazy = putByte bh 0 + put_ bh SrcStrict = putByte bh 1 + put_ bh NoSrcStrict = putByte bh 2 + + get bh = + do h <- getByte bh + case h of + 0 -> return SrcLazy + 1 -> return SrcStrict + _ -> return NoSrcStrict + +instance Binary SrcUnpackedness where + put_ bh SrcNoUnpack = putByte bh 0 + put_ bh SrcUnpack = putByte bh 1 + put_ bh NoSrcUnpack = putByte bh 2 + + get bh = + do h <- getByte bh + case h of + 0 -> return SrcNoUnpack + 1 -> return SrcUnpack + _ -> return NoSrcUnpack + +-- | Compare strictness annotations +eqHsBang :: HsImplBang -> HsImplBang -> Bool +eqHsBang HsLazy HsLazy = True +eqHsBang HsStrict HsStrict = True +eqHsBang (HsUnpack Nothing) (HsUnpack Nothing) = True +eqHsBang (HsUnpack (Just c1)) (HsUnpack (Just c2)) + = eqType (coercionType c1) (coercionType c2) +eqHsBang _ _ = False + +isBanged :: HsImplBang -> Bool +isBanged (HsUnpack {}) = True +isBanged (HsStrict {}) = True +isBanged HsLazy = False + +isSrcStrict :: SrcStrictness -> Bool +isSrcStrict SrcStrict = True +isSrcStrict _ = False + +isSrcUnpacked :: SrcUnpackedness -> Bool +isSrcUnpacked SrcUnpack = True +isSrcUnpacked _ = False + +isMarkedStrict :: StrictnessMark -> Bool +isMarkedStrict NotMarkedStrict = False +isMarkedStrict _ = True -- All others are strict + +{- ********************************************************************* +* * +\subsection{Construction} +* * +********************************************************************* -} + +-- | Build a new data constructor +mkDataCon :: Name + -> Bool -- ^ Is the constructor declared infix? + -> TyConRepName -- ^ TyConRepName for the promoted TyCon + -> [HsSrcBang] -- ^ Strictness/unpack annotations, from user + -> [FieldLabel] -- ^ Field labels for the constructor, + -- if it is a record, otherwise empty + -> [TyVar] -- ^ Universals. + -> [TyCoVar] -- ^ Existentials. + -> [TyVarBinder] -- ^ User-written 'TyVarBinder's. + -- These must be Inferred/Specified. + -- See @Note [TyVarBinders in DataCons]@ + -> [EqSpec] -- ^ GADT equalities + -> KnotTied ThetaType -- ^ Theta-type occurring before the arguments proper + -> [KnotTied Type] -- ^ Original argument types + -> KnotTied Type -- ^ Original result type + -> RuntimeRepInfo -- ^ See comments on 'TyCon.RuntimeRepInfo' + -> KnotTied TyCon -- ^ Representation type constructor + -> ConTag -- ^ Constructor tag + -> ThetaType -- ^ The "stupid theta", context of the data + -- declaration e.g. @data Eq a => T a ...@ + -> Id -- ^ Worker Id + -> DataConRep -- ^ Representation + -> DataCon + -- Can get the tag from the TyCon + +mkDataCon name declared_infix prom_info + arg_stricts -- Must match orig_arg_tys 1-1 + fields + univ_tvs ex_tvs user_tvbs + eq_spec theta + orig_arg_tys orig_res_ty rep_info rep_tycon tag + stupid_theta work_id rep +-- Warning: mkDataCon is not a good place to check certain invariants. +-- If the programmer writes the wrong result type in the decl, thus: +-- data T a where { MkT :: S } +-- then it's possible that the univ_tvs may hit an assertion failure +-- if you pull on univ_tvs. This case is checked by checkValidDataCon, +-- so the error is detected properly... it's just that assertions here +-- are a little dodgy. + + = con + where + is_vanilla = null ex_tvs && null eq_spec && null theta + + con = MkData {dcName = name, dcUnique = nameUnique name, + dcVanilla = is_vanilla, dcInfix = declared_infix, + dcUnivTyVars = univ_tvs, + dcExTyCoVars = ex_tvs, + dcUserTyVarBinders = user_tvbs, + dcEqSpec = eq_spec, + dcOtherTheta = theta, + dcStupidTheta = stupid_theta, + dcOrigArgTys = orig_arg_tys, dcOrigResTy = orig_res_ty, + dcRepTyCon = rep_tycon, + dcSrcBangs = arg_stricts, + dcFields = fields, dcTag = tag, dcRepType = rep_ty, + dcWorkId = work_id, + dcRep = rep, + dcSourceArity = length orig_arg_tys, + dcRepArity = length rep_arg_tys + count isCoVar ex_tvs, + dcPromoted = promoted } + + -- The 'arg_stricts' passed to mkDataCon are simply those for the + -- source-language arguments. We add extra ones for the + -- dictionary arguments right here. + + rep_arg_tys = dataConRepArgTys con + + rep_ty = + case rep of + -- If the DataCon has no wrapper, then the worker's type *is* the + -- user-facing type, so we can simply use dataConUserType. + NoDataConRep -> dataConUserType con + -- If the DataCon has a wrapper, then the worker's type is never seen + -- by the user. The visibilities we pick do not matter here. + DCR{} -> mkInvForAllTys univ_tvs $ mkTyCoInvForAllTys ex_tvs $ + mkVisFunTys rep_arg_tys $ + mkTyConApp rep_tycon (mkTyVarTys univ_tvs) + + -- See Note [Promoted data constructors] in TyCon + prom_tv_bndrs = [ mkNamedTyConBinder vis tv + | Bndr tv vis <- user_tvbs ] + + fresh_names = freshNames (map getName user_tvbs) + -- fresh_names: make sure that the "anonymous" tyvars don't + -- clash in name or unique with the universal/existential ones. + -- Tiresome! And unnecessary because these tyvars are never looked at + prom_theta_bndrs = [ mkAnonTyConBinder InvisArg (mkTyVar n t) + {- Invisible -} | (n,t) <- fresh_names `zip` theta ] + prom_arg_bndrs = [ mkAnonTyConBinder VisArg (mkTyVar n t) + {- Visible -} | (n,t) <- dropList theta fresh_names `zip` orig_arg_tys ] + prom_bndrs = prom_tv_bndrs ++ prom_theta_bndrs ++ prom_arg_bndrs + prom_res_kind = orig_res_ty + promoted = mkPromotedDataCon con name prom_info prom_bndrs + prom_res_kind roles rep_info + + roles = map (\tv -> if isTyVar tv then Nominal else Phantom) + (univ_tvs ++ ex_tvs) + ++ map (const Representational) (theta ++ orig_arg_tys) + +freshNames :: [Name] -> [Name] +-- Make an infinite list of Names whose Uniques and OccNames +-- differ from those in the 'avoid' list +freshNames avoids + = [ mkSystemName uniq occ + | n <- [0..] + , let uniq = mkAlphaTyVarUnique n + occ = mkTyVarOccFS (mkFastString ('x' : show n)) + + , not (uniq `elementOfUniqSet` avoid_uniqs) + , not (occ `elemOccSet` avoid_occs) ] + + where + avoid_uniqs :: UniqSet Unique + avoid_uniqs = mkUniqSet (map getUnique avoids) + + avoid_occs :: OccSet + avoid_occs = mkOccSet (map getOccName avoids) + +-- | The 'Name' of the 'DataCon', giving it a unique, rooted identification +dataConName :: DataCon -> Name +dataConName = dcName + +-- | The tag used for ordering 'DataCon's +dataConTag :: DataCon -> ConTag +dataConTag = dcTag + +dataConTagZ :: DataCon -> ConTagZ +dataConTagZ con = dataConTag con - fIRST_TAG + +-- | The type constructor that we are building via this data constructor +dataConTyCon :: DataCon -> TyCon +dataConTyCon = dcRepTyCon + +-- | The original type constructor used in the definition of this data +-- constructor. In case of a data family instance, that will be the family +-- type constructor. +dataConOrigTyCon :: DataCon -> TyCon +dataConOrigTyCon dc + | Just (tc, _) <- tyConFamInst_maybe (dcRepTyCon dc) = tc + | otherwise = dcRepTyCon dc + +-- | The representation type of the data constructor, i.e. the sort +-- type that will represent values of this type at runtime +dataConRepType :: DataCon -> Type +dataConRepType = dcRepType + +-- | Should the 'DataCon' be presented infix? +dataConIsInfix :: DataCon -> Bool +dataConIsInfix = dcInfix + +-- | The universally-quantified type variables of the constructor +dataConUnivTyVars :: DataCon -> [TyVar] +dataConUnivTyVars (MkData { dcUnivTyVars = tvbs }) = tvbs + +-- | The existentially-quantified type/coercion variables of the constructor +-- including dependent (kind-) GADT equalities +dataConExTyCoVars :: DataCon -> [TyCoVar] +dataConExTyCoVars (MkData { dcExTyCoVars = tvbs }) = tvbs + +-- | Both the universal and existential type/coercion variables of the constructor +dataConUnivAndExTyCoVars :: DataCon -> [TyCoVar] +dataConUnivAndExTyCoVars (MkData { dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs }) + = univ_tvs ++ ex_tvs + +-- See Note [DataCon user type variable binders] +-- | The type variables of the constructor, in the order the user wrote them +dataConUserTyVars :: DataCon -> [TyVar] +dataConUserTyVars (MkData { dcUserTyVarBinders = tvbs }) = binderVars tvbs + +-- See Note [DataCon user type variable binders] +-- | 'TyCoVarBinder's for the type variables of the constructor, in the order the +-- user wrote them +dataConUserTyVarBinders :: DataCon -> [TyVarBinder] +dataConUserTyVarBinders = dcUserTyVarBinders + +-- | Equalities derived from the result type of the data constructor, as written +-- by the programmer in any GADT declaration. This includes *all* GADT-like +-- equalities, including those written in by hand by the programmer. +dataConEqSpec :: DataCon -> [EqSpec] +dataConEqSpec con@(MkData { dcEqSpec = eq_spec, dcOtherTheta = theta }) + = dataConKindEqSpec con + ++ eq_spec ++ + [ spec -- heterogeneous equality + | Just (tc, [_k1, _k2, ty1, ty2]) <- map splitTyConApp_maybe theta + , tc `hasKey` heqTyConKey + , spec <- case (getTyVar_maybe ty1, getTyVar_maybe ty2) of + (Just tv1, _) -> [mkEqSpec tv1 ty2] + (_, Just tv2) -> [mkEqSpec tv2 ty1] + _ -> [] + ] ++ + [ spec -- homogeneous equality + | Just (tc, [_k, ty1, ty2]) <- map splitTyConApp_maybe theta + , tc `hasKey` eqTyConKey + , spec <- case (getTyVar_maybe ty1, getTyVar_maybe ty2) of + (Just tv1, _) -> [mkEqSpec tv1 ty2] + (_, Just tv2) -> [mkEqSpec tv2 ty1] + _ -> [] + ] + +-- | Dependent (kind-level) equalities in a constructor. +-- There are extracted from the existential variables. +-- See Note [Existential coercion variables] +dataConKindEqSpec :: DataCon -> [EqSpec] +dataConKindEqSpec (MkData {dcExTyCoVars = ex_tcvs}) + -- It is used in 'dataConEqSpec' (maybe also 'dataConFullSig' in the future), + -- which are frequently used functions. + -- For now (Aug 2018) this function always return empty set as we don't really + -- have coercion variables. + -- In the future when we do, we might want to cache this information in DataCon + -- so it won't be computed every time when aforementioned functions are called. + = [ EqSpec tv ty + | cv <- ex_tcvs + , isCoVar cv + , let (_, _, ty1, ty, _) = coVarKindsTypesRole cv + tv = getTyVar "dataConKindEqSpec" ty1 + ] + +-- | The *full* constraints on the constructor type, including dependent GADT +-- equalities. +dataConTheta :: DataCon -> ThetaType +dataConTheta con@(MkData { dcEqSpec = eq_spec, dcOtherTheta = theta }) + = eqSpecPreds (dataConKindEqSpec con ++ eq_spec) ++ theta + +-- | Get the Id of the 'DataCon' worker: a function that is the "actual" +-- constructor and has no top level binding in the program. The type may +-- be different from the obvious one written in the source program. Panics +-- if there is no such 'Id' for this 'DataCon' +dataConWorkId :: DataCon -> Id +dataConWorkId dc = dcWorkId dc + +-- | Get the Id of the 'DataCon' wrapper: a function that wraps the "actual" +-- constructor so it has the type visible in the source program: c.f. +-- 'dataConWorkId'. +-- Returns Nothing if there is no wrapper, which occurs for an algebraic data +-- constructor and also for a newtype (whose constructor is inlined +-- compulsorily) +dataConWrapId_maybe :: DataCon -> Maybe Id +dataConWrapId_maybe dc = case dcRep dc of + NoDataConRep -> Nothing + DCR { dcr_wrap_id = wrap_id } -> Just wrap_id + +-- | Returns an Id which looks like the Haskell-source constructor by using +-- the wrapper if it exists (see 'dataConWrapId_maybe') and failing over to +-- the worker (see 'dataConWorkId') +dataConWrapId :: DataCon -> Id +dataConWrapId dc = case dcRep dc of + NoDataConRep-> dcWorkId dc -- worker=wrapper + DCR { dcr_wrap_id = wrap_id } -> wrap_id + +-- | Find all the 'Id's implicitly brought into scope by the data constructor. Currently, +-- the union of the 'dataConWorkId' and the 'dataConWrapId' +dataConImplicitTyThings :: DataCon -> [TyThing] +dataConImplicitTyThings (MkData { dcWorkId = work, dcRep = rep }) + = [AnId work] ++ wrap_ids + where + wrap_ids = case rep of + NoDataConRep -> [] + DCR { dcr_wrap_id = wrap } -> [AnId wrap] + +-- | The labels for the fields of this particular 'DataCon' +dataConFieldLabels :: DataCon -> [FieldLabel] +dataConFieldLabels = dcFields + +-- | Extract the type for any given labelled field of the 'DataCon' +dataConFieldType :: DataCon -> FieldLabelString -> Type +dataConFieldType con label = case dataConFieldType_maybe con label of + Just (_, ty) -> ty + Nothing -> pprPanic "dataConFieldType" (ppr con <+> ppr label) + +-- | Extract the label and type for any given labelled field of the +-- 'DataCon', or return 'Nothing' if the field does not belong to it +dataConFieldType_maybe :: DataCon -> FieldLabelString + -> Maybe (FieldLabel, Type) +dataConFieldType_maybe con label + = find ((== label) . flLabel . fst) (dcFields con `zip` dcOrigArgTys con) + +-- | Strictness/unpack annotations, from user; or, for imported +-- DataCons, from the interface file +-- The list is in one-to-one correspondence with the arity of the 'DataCon' + +dataConSrcBangs :: DataCon -> [HsSrcBang] +dataConSrcBangs = dcSrcBangs + +-- | Source-level arity of the data constructor +dataConSourceArity :: DataCon -> Arity +dataConSourceArity (MkData { dcSourceArity = arity }) = arity + +-- | Gives the number of actual fields in the /representation/ of the +-- data constructor. This may be more than appear in the source code; +-- the extra ones are the existentially quantified dictionaries +dataConRepArity :: DataCon -> Arity +dataConRepArity (MkData { dcRepArity = arity }) = arity + +-- | Return whether there are any argument types for this 'DataCon's original source type +-- See Note [DataCon arities] +isNullarySrcDataCon :: DataCon -> Bool +isNullarySrcDataCon dc = dataConSourceArity dc == 0 + +-- | Return whether there are any argument types for this 'DataCon's runtime representation type +-- See Note [DataCon arities] +isNullaryRepDataCon :: DataCon -> Bool +isNullaryRepDataCon dc = dataConRepArity dc == 0 + +dataConRepStrictness :: DataCon -> [StrictnessMark] +-- ^ Give the demands on the arguments of a +-- Core constructor application (Con dc args) +dataConRepStrictness dc = case dcRep dc of + NoDataConRep -> [NotMarkedStrict | _ <- dataConRepArgTys dc] + DCR { dcr_stricts = strs } -> strs + +dataConImplBangs :: DataCon -> [HsImplBang] +-- The implementation decisions about the strictness/unpack of each +-- source program argument to the data constructor +dataConImplBangs dc + = case dcRep dc of + NoDataConRep -> replicate (dcSourceArity dc) HsLazy + DCR { dcr_bangs = bangs } -> bangs + +dataConBoxer :: DataCon -> Maybe DataConBoxer +dataConBoxer (MkData { dcRep = DCR { dcr_boxer = boxer } }) = Just boxer +dataConBoxer _ = Nothing + +-- | The \"signature\" of the 'DataCon' returns, in order: +-- +-- 1) The result of 'dataConUnivAndExTyCoVars', +-- +-- 2) All the 'ThetaType's relating to the 'DataCon' (coercion, dictionary, +-- implicit parameter - whatever), including dependent GADT equalities. +-- Dependent GADT equalities are *also* listed in return value (1), so be +-- careful! +-- +-- 3) The type arguments to the constructor +-- +-- 4) The /original/ result type of the 'DataCon' +dataConSig :: DataCon -> ([TyCoVar], ThetaType, [Type], Type) +dataConSig con@(MkData {dcOrigArgTys = arg_tys, dcOrigResTy = res_ty}) + = (dataConUnivAndExTyCoVars con, dataConTheta con, arg_tys, res_ty) + +dataConInstSig + :: DataCon + -> [Type] -- Instantiate the *universal* tyvars with these types + -> ([TyCoVar], ThetaType, [Type]) -- Return instantiated existentials + -- theta and arg tys +-- ^ Instantiate the universal tyvars of a data con, +-- returning +-- ( instantiated existentials +-- , instantiated constraints including dependent GADT equalities +-- which are *also* listed in the instantiated existentials +-- , instantiated args) +dataConInstSig con@(MkData { dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs + , dcOrigArgTys = arg_tys }) + univ_tys + = ( ex_tvs' + , substTheta subst (dataConTheta con) + , substTys subst arg_tys) + where + univ_subst = zipTvSubst univ_tvs univ_tys + (subst, ex_tvs') = Type.substVarBndrs univ_subst ex_tvs + + +-- | The \"full signature\" of the 'DataCon' returns, in order: +-- +-- 1) The result of 'dataConUnivTyVars' +-- +-- 2) The result of 'dataConExTyCoVars' +-- +-- 3) The non-dependent GADT equalities. +-- Dependent GADT equalities are implied by coercion variables in +-- return value (2). +-- +-- 4) The other constraints of the data constructor type, excluding GADT +-- equalities +-- +-- 5) The original argument types to the 'DataCon' (i.e. before +-- any change of the representation of the type) +-- +-- 6) The original result type of the 'DataCon' +dataConFullSig :: DataCon + -> ([TyVar], [TyCoVar], [EqSpec], ThetaType, [Type], Type) +dataConFullSig (MkData {dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs, + dcEqSpec = eq_spec, dcOtherTheta = theta, + dcOrigArgTys = arg_tys, dcOrigResTy = res_ty}) + = (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty) + +dataConOrigResTy :: DataCon -> Type +dataConOrigResTy dc = dcOrigResTy dc + +-- | The \"stupid theta\" of the 'DataCon', such as @data Eq a@ in: +-- +-- > data Eq a => T a = ... +dataConStupidTheta :: DataCon -> ThetaType +dataConStupidTheta dc = dcStupidTheta dc + +dataConUserType :: DataCon -> Type +-- ^ The user-declared type of the data constructor +-- in the nice-to-read form: +-- +-- > T :: forall a b. a -> b -> T [a] +-- +-- rather than: +-- +-- > T :: forall a c. forall b. (c~[a]) => a -> b -> T c +-- +-- The type variables are quantified in the order that the user wrote them. +-- See @Note [DataCon user type variable binders]@. +-- +-- NB: If the constructor is part of a data instance, the result type +-- mentions the family tycon, not the internal one. +dataConUserType (MkData { dcUserTyVarBinders = user_tvbs, + dcOtherTheta = theta, dcOrigArgTys = arg_tys, + dcOrigResTy = res_ty }) + = mkForAllTys user_tvbs $ + mkInvisFunTys theta $ + mkVisFunTys arg_tys $ + res_ty + +-- | Finds the instantiated types of the arguments required to construct a +-- 'DataCon' representation +-- NB: these INCLUDE any dictionary args +-- but EXCLUDE the data-declaration context, which is discarded +-- It's all post-flattening etc; this is a representation type +dataConInstArgTys :: DataCon -- ^ A datacon with no existentials or equality constraints + -- However, it can have a dcTheta (notably it can be a + -- class dictionary, with superclasses) + -> [Type] -- ^ Instantiated at these types + -> [Type] +dataConInstArgTys dc@(MkData {dcUnivTyVars = univ_tvs, + dcExTyCoVars = ex_tvs}) inst_tys + = ASSERT2( univ_tvs `equalLength` inst_tys + , text "dataConInstArgTys" <+> ppr dc $$ ppr univ_tvs $$ ppr inst_tys) + ASSERT2( null ex_tvs, ppr dc ) + map (substTyWith univ_tvs inst_tys) (dataConRepArgTys dc) + +-- | Returns just the instantiated /value/ argument types of a 'DataCon', +-- (excluding dictionary args) +dataConInstOrigArgTys + :: DataCon -- Works for any DataCon + -> [Type] -- Includes existential tyvar args, but NOT + -- equality constraints or dicts + -> [Type] +-- For vanilla datacons, it's all quite straightforward +-- But for the call in MatchCon, we really do want just the value args +dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys, + dcUnivTyVars = univ_tvs, + dcExTyCoVars = ex_tvs}) inst_tys + = ASSERT2( tyvars `equalLength` inst_tys + , text "dataConInstOrigArgTys" <+> ppr dc $$ ppr tyvars $$ ppr inst_tys ) + map (substTy subst) arg_tys + where + tyvars = univ_tvs ++ ex_tvs + subst = zipTCvSubst tyvars inst_tys + +-- | Returns the argument types of the wrapper, excluding all dictionary arguments +-- and without substituting for any type variables +dataConOrigArgTys :: DataCon -> [Type] +dataConOrigArgTys dc = dcOrigArgTys dc + +-- | Returns the arg types of the worker, including *all* non-dependent +-- evidence, after any flattening has been done and without substituting for +-- any type variables +dataConRepArgTys :: DataCon -> [Type] +dataConRepArgTys (MkData { dcRep = rep + , dcEqSpec = eq_spec + , dcOtherTheta = theta + , dcOrigArgTys = orig_arg_tys }) + = case rep of + NoDataConRep -> ASSERT( null eq_spec ) theta ++ orig_arg_tys + DCR { dcr_arg_tys = arg_tys } -> arg_tys + +-- | The string @package:module.name@ identifying a constructor, which is attached +-- to its info table and used by the GHCi debugger and the heap profiler +dataConIdentity :: DataCon -> ByteString +-- We want this string to be UTF-8, so we get the bytes directly from the FastStrings. +dataConIdentity dc = LBS.toStrict $ BSB.toLazyByteString $ mconcat + [ BSB.byteString $ bytesFS (unitIdFS (moduleUnitId mod)) + , BSB.int8 $ fromIntegral (ord ':') + , BSB.byteString $ bytesFS (moduleNameFS (moduleName mod)) + , BSB.int8 $ fromIntegral (ord '.') + , BSB.byteString $ bytesFS (occNameFS (nameOccName name)) + ] + where name = dataConName dc + mod = ASSERT( isExternalName name ) nameModule name + +isTupleDataCon :: DataCon -> Bool +isTupleDataCon (MkData {dcRepTyCon = tc}) = isTupleTyCon tc + +isUnboxedTupleCon :: DataCon -> Bool +isUnboxedTupleCon (MkData {dcRepTyCon = tc}) = isUnboxedTupleTyCon tc + +isUnboxedSumCon :: DataCon -> Bool +isUnboxedSumCon (MkData {dcRepTyCon = tc}) = isUnboxedSumTyCon tc + +-- | Vanilla 'DataCon's are those that are nice boring Haskell 98 constructors +isVanillaDataCon :: DataCon -> Bool +isVanillaDataCon dc = dcVanilla dc + +-- | Should this DataCon be allowed in a type even without -XDataKinds? +-- Currently, only Lifted & Unlifted +specialPromotedDc :: DataCon -> Bool +specialPromotedDc = isKindTyCon . dataConTyCon + +classDataCon :: Class -> DataCon +classDataCon clas = case tyConDataCons (classTyCon clas) of + (dict_constr:no_more) -> ASSERT( null no_more ) dict_constr + [] -> panic "classDataCon" + +dataConCannotMatch :: [Type] -> DataCon -> Bool +-- Returns True iff the data con *definitely cannot* match a +-- scrutinee of type (T tys) +-- where T is the dcRepTyCon for the data con +dataConCannotMatch tys con + | null inst_theta = False -- Common + | all isTyVarTy tys = False -- Also common + | otherwise = typesCantMatch (concatMap predEqs inst_theta) + where + (_, inst_theta, _) = dataConInstSig con tys + + -- TODO: could gather equalities from superclasses too + predEqs pred = case classifyPredType pred of + EqPred NomEq ty1 ty2 -> [(ty1, ty2)] + ClassPred eq args + | eq `hasKey` eqTyConKey + , [_, ty1, ty2] <- args -> [(ty1, ty2)] + | eq `hasKey` heqTyConKey + , [_, _, ty1, ty2] <- args -> [(ty1, ty2)] + _ -> [] + +-- | Were the type variables of the data con written in a different order +-- than the regular order (universal tyvars followed by existential tyvars)? +-- +-- This is not a cheap test, so we minimize its use in GHC as much as possible. +-- Currently, its only call site in the GHC codebase is in 'mkDataConRep' in +-- "MkId", and so 'dataConUserTyVarsArePermuted' is only called at most once +-- during a data constructor's lifetime. + +-- See Note [DataCon user type variable binders], as well as +-- Note [Data con wrappers and GADT syntax] for an explanation of what +-- mkDataConRep is doing with this function. +dataConUserTyVarsArePermuted :: DataCon -> Bool +dataConUserTyVarsArePermuted (MkData { dcUnivTyVars = univ_tvs + , dcExTyCoVars = ex_tvs, dcEqSpec = eq_spec + , dcUserTyVarBinders = user_tvbs }) = + (filterEqSpec eq_spec univ_tvs ++ ex_tvs) /= binderVars user_tvbs + +{- +%************************************************************************ +%* * + Promoting of data types to the kind level +* * +************************************************************************ + +-} + +promoteDataCon :: DataCon -> TyCon +promoteDataCon (MkData { dcPromoted = tc }) = tc + +{- +************************************************************************ +* * +\subsection{Splitting products} +* * +************************************************************************ +-} + +-- | Extract the type constructor, type argument, data constructor and it's +-- /representation/ argument types from a type if it is a product type. +-- +-- Precisely, we return @Just@ for any type that is all of: +-- +-- * Concrete (i.e. constructors visible) +-- +-- * Single-constructor +-- +-- * Not existentially quantified +-- +-- Whether the type is a @data@ type or a @newtype@ +splitDataProductType_maybe + :: Type -- ^ A product type, perhaps + -> Maybe (TyCon, -- The type constructor + [Type], -- Type args of the tycon + DataCon, -- The data constructor + [Type]) -- Its /representation/ arg types + + -- Rejecting existentials is conservative. Maybe some things + -- could be made to work with them, but I'm not going to sweat + -- it through till someone finds it's important. + +splitDataProductType_maybe ty + | Just (tycon, ty_args) <- splitTyConApp_maybe ty + , Just con <- isDataProductTyCon_maybe tycon + = Just (tycon, ty_args, con, dataConInstArgTys con ty_args) + | otherwise + = Nothing + +{- +************************************************************************ +* * + Building an algebraic data type +* * +************************************************************************ + +buildAlgTyCon is here because it is called from TysWiredIn, which can +depend on this module, but not on BuildTyCl. +-} + +buildAlgTyCon :: Name + -> [TyVar] -- ^ Kind variables and type variables + -> [Role] + -> Maybe CType + -> ThetaType -- ^ Stupid theta + -> AlgTyConRhs + -> Bool -- ^ True <=> was declared in GADT syntax + -> AlgTyConFlav + -> TyCon + +buildAlgTyCon tc_name ktvs roles cType stupid_theta rhs + gadt_syn parent + = mkAlgTyCon tc_name binders liftedTypeKind roles cType stupid_theta + rhs parent gadt_syn + where + binders = mkTyConBindersPreferAnon ktvs emptyVarSet + +buildSynTyCon :: Name -> [KnotTied TyConBinder] -> Kind -- ^ /result/ kind + -> [Role] -> KnotTied Type -> TyCon +buildSynTyCon name binders res_kind roles rhs + = mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free + where + is_tau = isTauTy rhs + is_fam_free = isFamFreeTy rhs diff --git a/compiler/basicTypes/DataCon.hs-boot b/compiler/basicTypes/DataCon.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/basicTypes/DataCon.hs-boot @@ -0,0 +1,34 @@ +module DataCon where + +import GhcPrelude +import Var( TyVar, TyCoVar, TyVarBinder ) +import Name( Name, NamedThing ) +import {-# SOURCE #-} TyCon( TyCon ) +import FieldLabel ( FieldLabel ) +import Unique ( Uniquable ) +import Outputable ( Outputable, OutputableBndr ) +import BasicTypes (Arity) +import {-# SOURCE #-} TyCoRep ( Type, ThetaType ) + +data DataCon +data DataConRep +data EqSpec + +dataConName :: DataCon -> Name +dataConTyCon :: DataCon -> TyCon +dataConExTyCoVars :: DataCon -> [TyCoVar] +dataConUserTyVars :: DataCon -> [TyVar] +dataConUserTyVarBinders :: DataCon -> [TyVarBinder] +dataConSourceArity :: DataCon -> Arity +dataConFieldLabels :: DataCon -> [FieldLabel] +dataConInstOrigArgTys :: DataCon -> [Type] -> [Type] +dataConStupidTheta :: DataCon -> ThetaType +dataConFullSig :: DataCon + -> ([TyVar], [TyCoVar], [EqSpec], ThetaType, [Type], Type) +isUnboxedSumCon :: DataCon -> Bool + +instance Eq DataCon +instance Uniquable DataCon +instance NamedThing DataCon +instance Outputable DataCon +instance OutputableBndr DataCon diff --git a/compiler/basicTypes/Demand.hs b/compiler/basicTypes/Demand.hs new file mode 100644 --- /dev/null +++ b/compiler/basicTypes/Demand.hs @@ -0,0 +1,2038 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[Demand]{@Demand@: A decoupled implementation of a demand domain} +-} + +{-# LANGUAGE CPP, FlexibleInstances, TypeSynonymInstances, RecordWildCards #-} + +module Demand ( + StrDmd, UseDmd(..), Count, + + Demand, DmdShell, CleanDemand, getStrDmd, getUseDmd, + mkProdDmd, mkOnceUsedDmd, mkManyUsedDmd, mkHeadStrict, oneifyDmd, + toCleanDmd, + absDmd, topDmd, botDmd, seqDmd, + lubDmd, bothDmd, + lazyApply1Dmd, lazyApply2Dmd, strictApply1Dmd, + isTopDmd, isAbsDmd, isSeqDmd, + peelUseCall, cleanUseDmd_maybe, strictenDmd, bothCleanDmd, + addCaseBndrDmd, + + DmdType(..), dmdTypeDepth, lubDmdType, bothDmdType, + nopDmdType, botDmdType, mkDmdType, + addDemand, removeDmdTyArgs, + BothDmdArg, mkBothDmdArg, toBothDmdArg, + + DmdEnv, emptyDmdEnv, + peelFV, findIdDemand, + + DmdResult, CPRResult, + isBotRes, isTopRes, + topRes, botRes, cprProdRes, + vanillaCprProdRes, cprSumRes, + appIsBottom, isBottomingSig, pprIfaceStrictSig, + trimCPRInfo, returnsCPR_maybe, + StrictSig(..), mkStrictSig, mkClosedStrictSig, + nopSig, botSig, cprProdSig, + isTopSig, hasDemandEnvSig, + splitStrictSig, strictSigDmdEnv, + increaseStrictSigArity, etaExpandStrictSig, + + seqDemand, seqDemandList, seqDmdType, seqStrictSig, + + evalDmd, cleanEvalDmd, cleanEvalProdDmd, isStrictDmd, + splitDmdTy, splitFVs, + deferAfterIO, + postProcessUnsat, postProcessDmdType, + + splitProdDmd_maybe, peelCallDmd, peelManyCalls, mkCallDmd, + mkWorkerDemand, dmdTransformSig, dmdTransformDataConSig, + dmdTransformDictSelSig, argOneShots, argsOneShots, saturatedByOneShots, + trimToType, TypeShape(..), + + useCount, isUsedOnce, reuseEnv, + killUsageDemand, killUsageSig, zapUsageDemand, zapUsageEnvSig, + zapUsedOnceDemand, zapUsedOnceSig, + strictifyDictDmd, strictifyDmd + + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import DynFlags +import Outputable +import Var ( Var ) +import VarEnv +import UniqFM +import Util +import BasicTypes +import Binary +import Maybes ( orElse ) + +import Type ( Type ) +import TyCon ( isNewTyCon, isClassTyCon ) +import DataCon ( splitDataProductType_maybe ) + +{- +************************************************************************ +* * + Joint domain for Strictness and Absence +* * +************************************************************************ +-} + +data JointDmd s u = JD { sd :: s, ud :: u } + deriving ( Eq, Show ) + +getStrDmd :: JointDmd s u -> s +getStrDmd = sd + +getUseDmd :: JointDmd s u -> u +getUseDmd = ud + +-- Pretty-printing +instance (Outputable s, Outputable u) => Outputable (JointDmd s u) where + ppr (JD {sd = s, ud = u}) = angleBrackets (ppr s <> char ',' <> ppr u) + +-- Well-formedness preserving constructors for the joint domain +mkJointDmd :: s -> u -> JointDmd s u +mkJointDmd s u = JD { sd = s, ud = u } + +mkJointDmds :: [s] -> [u] -> [JointDmd s u] +mkJointDmds ss as = zipWithEqual "mkJointDmds" mkJointDmd ss as + + +{- +************************************************************************ +* * + Strictness domain +* * +************************************************************************ + + Lazy + | + HeadStr + / \ + SCall SProd + \ / + HyperStr + +Note [Exceptions and strictness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to smart about catching exceptions, but we aren't anymore. +See #14998 for the way it's resolved at the moment. + +Here's a historic breakdown: + +Apparently, exception handling prim-ops didn't use to have any special +strictness signatures, thus defaulting to topSig, which assumes they use their +arguments lazily. Joachim was the first to realise that we could provide richer +information. Thus, in 0558911f91c (Dec 13), he added signatures to +primops.txt.pp indicating that functions like `catch#` and `catchRetry#` call +their argument, which is useful information for usage analysis. Still with a +'Lazy' strictness demand (i.e. 'lazyApply1Dmd'), though, and the world was fine. + +In 7c0fff4 (July 15), Simon argued that giving `catch#` et al. a +'strictApply1Dmd' leads to substantial performance gains. That was at the cost +of correctness, as #10712 proved. So, back to 'lazyApply1Dmd' in +28638dfe79e (Dec 15). + +Motivated to reproduce the gains of 7c0fff4 without the breakage of #10712, +Ben opened #11222. Simon made the demand analyser "understand catch" in +9915b656 (Jan 16) by adding a new 'catchArgDmd', which basically said to call +its argument strictly, but also swallow any thrown exceptions in +'postProcessDmdResult'. This was realized by extending the 'Str' constructor of +'ArgStr' with a 'ExnStr' field, indicating that it catches the exception, and +adding a 'ThrowsExn' constructor to the 'Termination' lattice as an element +between 'Dunno' and 'Diverges'. Then along came #11555 and finally #13330, +so we had to revert to 'lazyApply1Dmd' again in 701256df88c (Mar 17). + +This left the other variants like 'catchRetry#' having 'catchArgDmd', which is +where #14998 picked up. Item 1 was concerned with measuring the impact of also +making `catchRetry#` and `catchSTM#` have 'lazyApply1Dmd'. The result was that +there was none. We removed the last usages of 'catchArgDmd' in 00b8ecb7 +(Apr 18). There was a lot of dead code resulting from that change, that we +removed in ef6b283 (Jan 19): We got rid of 'ThrowsExn' and 'ExnStr' again and +removed any code that was dealing with the peculiarities. + +Where did the speed-ups vanish to? In #14998, item 3 established that +turning 'catch#' strict in its first argument didn't bring back any of the +alleged performance benefits. Item 2 of that ticket finally found out that it +was entirely due to 'catchException's new (since #11555) definition, which +was simply + + catchException !io handler = catch io handler + +While 'catchException' is arguably the saner semantics for 'catch', it is an +internal helper function in "GHC.IO". Its use in +"GHC.IO.Handle.Internals.do_operation" made for the huge allocation differences: +Remove the bang and you find the regressions we originally wanted to avoid with +'catchArgDmd'. See also #exceptions_and_strictness# in "GHC.IO". + +So history keeps telling us that the only possibly correct strictness annotation +for the first argument of 'catch#' is 'lazyApply1Dmd', because 'catch#' really +is not strict in its argument: Just try this in GHCi + + :set -XScopedTypeVariables + import Control.Exception + catch undefined (\(_ :: SomeException) -> putStrLn "you'll see this") + +Any analysis that assumes otherwise will be broken in some way or another +(beyond `-fno-pendantic-bottoms`). +-} + +-- | Vanilla strictness domain +data StrDmd + = HyperStr -- ^ Hyper-strict (bottom of the lattice). + -- See Note [HyperStr and Use demands] + + | SCall StrDmd -- ^ Call demand + -- Used only for values of function type + + | SProd [ArgStr] -- ^ Product + -- Used only for values of product type + -- Invariant: not all components are HyperStr (use HyperStr) + -- not all components are Lazy (use HeadStr) + + | HeadStr -- ^ Head-Strict + -- A polymorphic demand: used for values of all types, + -- including a type variable + + deriving ( Eq, Show ) + +-- | Strictness of a function argument. +type ArgStr = Str StrDmd + +-- | Strictness demand. +data Str s = Lazy -- ^ Lazy (top of the lattice) + | Str s -- ^ Strict + deriving ( Eq, Show ) + +-- Well-formedness preserving constructors for the Strictness domain +strBot, strTop :: ArgStr +strBot = Str HyperStr +strTop = Lazy + +mkSCall :: StrDmd -> StrDmd +mkSCall HyperStr = HyperStr +mkSCall s = SCall s + +mkSProd :: [ArgStr] -> StrDmd +mkSProd sx + | any isHyperStr sx = HyperStr + | all isLazy sx = HeadStr + | otherwise = SProd sx + +isLazy :: ArgStr -> Bool +isLazy Lazy = True +isLazy (Str {}) = False + +isHyperStr :: ArgStr -> Bool +isHyperStr (Str HyperStr) = True +isHyperStr _ = False + +-- Pretty-printing +instance Outputable StrDmd where + ppr HyperStr = char 'B' + ppr (SCall s) = char 'C' <> parens (ppr s) + ppr HeadStr = char 'S' + ppr (SProd sx) = char 'S' <> parens (hcat (map ppr sx)) + +instance Outputable ArgStr where + ppr (Str s) = ppr s + ppr Lazy = char 'L' + +lubArgStr :: ArgStr -> ArgStr -> ArgStr +lubArgStr Lazy _ = Lazy +lubArgStr _ Lazy = Lazy +lubArgStr (Str s1) (Str s2) = Str (s1 `lubStr` s2) + +lubStr :: StrDmd -> StrDmd -> StrDmd +lubStr HyperStr s = s +lubStr (SCall s1) HyperStr = SCall s1 +lubStr (SCall _) HeadStr = HeadStr +lubStr (SCall s1) (SCall s2) = SCall (s1 `lubStr` s2) +lubStr (SCall _) (SProd _) = HeadStr +lubStr (SProd sx) HyperStr = SProd sx +lubStr (SProd _) HeadStr = HeadStr +lubStr (SProd s1) (SProd s2) + | s1 `equalLength` s2 = mkSProd (zipWith lubArgStr s1 s2) + | otherwise = HeadStr +lubStr (SProd _) (SCall _) = HeadStr +lubStr HeadStr _ = HeadStr + +bothArgStr :: ArgStr -> ArgStr -> ArgStr +bothArgStr Lazy s = s +bothArgStr s Lazy = s +bothArgStr (Str s1) (Str s2) = Str (s1 `bothStr` s2) + +bothStr :: StrDmd -> StrDmd -> StrDmd +bothStr HyperStr _ = HyperStr +bothStr HeadStr s = s +bothStr (SCall _) HyperStr = HyperStr +bothStr (SCall s1) HeadStr = SCall s1 +bothStr (SCall s1) (SCall s2) = SCall (s1 `bothStr` s2) +bothStr (SCall _) (SProd _) = HyperStr -- Weird + +bothStr (SProd _) HyperStr = HyperStr +bothStr (SProd s1) HeadStr = SProd s1 +bothStr (SProd s1) (SProd s2) + | s1 `equalLength` s2 = mkSProd (zipWith bothArgStr s1 s2) + | otherwise = HyperStr -- Weird +bothStr (SProd _) (SCall _) = HyperStr + +-- utility functions to deal with memory leaks +seqStrDmd :: StrDmd -> () +seqStrDmd (SProd ds) = seqStrDmdList ds +seqStrDmd (SCall s) = seqStrDmd s +seqStrDmd _ = () + +seqStrDmdList :: [ArgStr] -> () +seqStrDmdList [] = () +seqStrDmdList (d:ds) = seqArgStr d `seq` seqStrDmdList ds + +seqArgStr :: ArgStr -> () +seqArgStr Lazy = () +seqArgStr (Str s) = seqStrDmd s + +-- Splitting polymorphic demands +splitArgStrProdDmd :: Int -> ArgStr -> Maybe [ArgStr] +splitArgStrProdDmd n Lazy = Just (replicate n Lazy) +splitArgStrProdDmd n (Str s) = splitStrProdDmd n s + +splitStrProdDmd :: Int -> StrDmd -> Maybe [ArgStr] +splitStrProdDmd n HyperStr = Just (replicate n strBot) +splitStrProdDmd n HeadStr = Just (replicate n strTop) +splitStrProdDmd n (SProd ds) = WARN( not (ds `lengthIs` n), + text "splitStrProdDmd" $$ ppr n $$ ppr ds ) + Just ds +splitStrProdDmd _ (SCall {}) = Nothing + -- This can happen when the programmer uses unsafeCoerce, + -- and we don't then want to crash the compiler (#9208) + +{- +************************************************************************ +* * + Absence domain +* * +************************************************************************ + + Used + / \ + UCall UProd + \ / + UHead + | + Count x - + | + Abs +-} + +-- | Domain for genuine usage +data UseDmd + = UCall Count UseDmd -- ^ Call demand for absence. + -- Used only for values of function type + + | UProd [ArgUse] -- ^ Product. + -- Used only for values of product type + -- See Note [Don't optimise UProd(Used) to Used] + -- + -- Invariant: Not all components are Abs + -- (in that case, use UHead) + + | UHead -- ^ May be used but its sub-components are + -- definitely *not* used. For product types, UHead + -- is equivalent to U(AAA); see mkUProd. + -- + -- UHead is needed only to express the demand + -- of 'seq' and 'case' which are polymorphic; + -- i.e. the scrutinised value is of type 'a' + -- rather than a product type. That's why we + -- can't use UProd [A,A,A] + -- + -- Since (UCall _ Abs) is ill-typed, UHead doesn't + -- make sense for lambdas + + | Used -- ^ May be used and its sub-components may be used. + -- (top of the lattice) + deriving ( Eq, Show ) + +-- Extended usage demand for absence and counting +type ArgUse = Use UseDmd + +data Use u + = Abs -- Definitely unused + -- Bottom of the lattice + + | Use Count u -- May be used with some cardinality + deriving ( Eq, Show ) + +-- | Abstract counting of usages +data Count = One | Many + deriving ( Eq, Show ) + +-- Pretty-printing +instance Outputable ArgUse where + ppr Abs = char 'A' + ppr (Use Many a) = ppr a + ppr (Use One a) = char '1' <> char '*' <> ppr a + +instance Outputable UseDmd where + ppr Used = char 'U' + ppr (UCall c a) = char 'C' <> ppr c <> parens (ppr a) + ppr UHead = char 'H' + ppr (UProd as) = char 'U' <> parens (hcat (punctuate (char ',') (map ppr as))) + +instance Outputable Count where + ppr One = char '1' + ppr Many = text "" + +useBot, useTop :: ArgUse +useBot = Abs +useTop = Use Many Used + +mkUCall :: Count -> UseDmd -> UseDmd +--mkUCall c Used = Used c +mkUCall c a = UCall c a + +mkUProd :: [ArgUse] -> UseDmd +mkUProd ux + | all (== Abs) ux = UHead + | otherwise = UProd ux + +lubCount :: Count -> Count -> Count +lubCount _ Many = Many +lubCount Many _ = Many +lubCount x _ = x + +lubArgUse :: ArgUse -> ArgUse -> ArgUse +lubArgUse Abs x = x +lubArgUse x Abs = x +lubArgUse (Use c1 a1) (Use c2 a2) = Use (lubCount c1 c2) (lubUse a1 a2) + +lubUse :: UseDmd -> UseDmd -> UseDmd +lubUse UHead u = u +lubUse (UCall c u) UHead = UCall c u +lubUse (UCall c1 u1) (UCall c2 u2) = UCall (lubCount c1 c2) (lubUse u1 u2) +lubUse (UCall _ _) _ = Used +lubUse (UProd ux) UHead = UProd ux +lubUse (UProd ux1) (UProd ux2) + | ux1 `equalLength` ux2 = UProd $ zipWith lubArgUse ux1 ux2 + | otherwise = Used +lubUse (UProd {}) (UCall {}) = Used +-- lubUse (UProd {}) Used = Used +lubUse (UProd ux) Used = UProd (map (`lubArgUse` useTop) ux) +lubUse Used (UProd ux) = UProd (map (`lubArgUse` useTop) ux) +lubUse Used _ = Used -- Note [Used should win] + +-- `both` is different from `lub` in its treatment of counting; if +-- `both` is computed for two used, the result always has +-- cardinality `Many` (except for the inner demands of UCall demand -- [TODO] explain). +-- Also, x `bothUse` x /= x (for anything but Abs). + +bothArgUse :: ArgUse -> ArgUse -> ArgUse +bothArgUse Abs x = x +bothArgUse x Abs = x +bothArgUse (Use _ a1) (Use _ a2) = Use Many (bothUse a1 a2) + + +bothUse :: UseDmd -> UseDmd -> UseDmd +bothUse UHead u = u +bothUse (UCall c u) UHead = UCall c u + +-- Exciting special treatment of inner demand for call demands: +-- use `lubUse` instead of `bothUse`! +bothUse (UCall _ u1) (UCall _ u2) = UCall Many (u1 `lubUse` u2) + +bothUse (UCall {}) _ = Used +bothUse (UProd ux) UHead = UProd ux +bothUse (UProd ux1) (UProd ux2) + | ux1 `equalLength` ux2 = UProd $ zipWith bothArgUse ux1 ux2 + | otherwise = Used +bothUse (UProd {}) (UCall {}) = Used +-- bothUse (UProd {}) Used = Used -- Note [Used should win] +bothUse Used (UProd ux) = UProd (map (`bothArgUse` useTop) ux) +bothUse (UProd ux) Used = UProd (map (`bothArgUse` useTop) ux) +bothUse Used _ = Used -- Note [Used should win] + +peelUseCall :: UseDmd -> Maybe (Count, UseDmd) +peelUseCall (UCall c u) = Just (c,u) +peelUseCall _ = Nothing + +addCaseBndrDmd :: Demand -- On the case binder + -> [Demand] -- On the components of the constructor + -> [Demand] -- Final demands for the components of the constructor +-- See Note [Demand on case-alternative binders] +addCaseBndrDmd (JD { sd = ms, ud = mu }) alt_dmds + = case mu of + Abs -> alt_dmds + Use _ u -> zipWith bothDmd alt_dmds (mkJointDmds ss us) + where + Just ss = splitArgStrProdDmd arity ms -- Guaranteed not to be a call + Just us = splitUseProdDmd arity u -- Ditto + where + arity = length alt_dmds + +{- Note [Demand on case-alternative binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The demand on a binder in a case alternative comes + (a) From the demand on the binder itself + (b) From the demand on the case binder +Forgetting (b) led directly to #10148. + +Example. Source code: + f x@(p,_) = if p then foo x else True + + foo (p,True) = True + foo (p,q) = foo (q,p) + +After strictness analysis: + f = \ (x_an1 [Dmd=] :: (Bool, Bool)) -> + case x_an1 + of wild_X7 [Dmd=] + { (p_an2 [Dmd=], ds_dnz [Dmd=]) -> + case p_an2 of _ { + False -> GHC.Types.True; + True -> foo wild_X7 } + +It's true that ds_dnz is *itself* absent, but the use of wild_X7 means +that it is very much alive and demanded. See #10148 for how the +consequences play out. + +This is needed even for non-product types, in case the case-binder +is used but the components of the case alternative are not. + +Note [Don't optimise UProd(Used) to Used] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +These two UseDmds: + UProd [Used, Used] and Used +are semantically equivalent, but we do not turn the former into +the latter, for a regrettable-subtle reason. Suppose we did. +then + f (x,y) = (y,x) +would get + StrDmd = Str = SProd [Lazy, Lazy] + UseDmd = Used = UProd [Used, Used] +But with the joint demand of doesn't convey any clue +that there is a product involved, and so the worthSplittingFun +will not fire. (We'd need to use the type as well to make it fire.) +Moreover, consider + g h p@(_,_) = h p +This too would get , but this time there really isn't any +point in w/w since the components of the pair are not used at all. + +So the solution is: don't aggressively collapse UProd [Used,Used] to +Used; intead leave it as-is. In effect we are using the UseDmd to do a +little bit of boxity analysis. Not very nice. + +Note [Used should win] +~~~~~~~~~~~~~~~~~~~~~~ +Both in lubUse and bothUse we want (Used `both` UProd us) to be Used. +Why? Because Used carries the implication the whole thing is used, +box and all, so we don't want to w/w it. If we use it both boxed and +unboxed, then we are definitely using the box, and so we are quite +likely to pay a reboxing cost. So we make Used win here. + +Example is in the Buffer argument of GHC.IO.Handle.Internals.writeCharBuffer + +Baseline: (A) Not making Used win (UProd wins) +Compare with: (B) making Used win for lub and both + + Min -0.3% -5.6% -10.7% -11.0% -33.3% + Max +0.3% +45.6% +11.5% +11.5% +6.9% + Geometric Mean -0.0% +0.5% +0.3% +0.2% -0.8% + +Baseline: (B) Making Used win for both lub and both +Compare with: (C) making Used win for both, but UProd win for lub + + Min -0.1% -0.3% -7.9% -8.0% -6.5% + Max +0.1% +1.0% +21.0% +21.0% +0.5% + Geometric Mean +0.0% +0.0% -0.0% -0.1% -0.1% +-} + +-- If a demand is used multiple times (i.e. reused), than any use-once +-- mentioned there, that is not protected by a UCall, can happen many times. +markReusedDmd :: ArgUse -> ArgUse +markReusedDmd Abs = Abs +markReusedDmd (Use _ a) = Use Many (markReused a) + +markReused :: UseDmd -> UseDmd +markReused (UCall _ u) = UCall Many u -- No need to recurse here +markReused (UProd ux) = UProd (map markReusedDmd ux) +markReused u = u + +isUsedMU :: ArgUse -> Bool +-- True <=> markReusedDmd d = d +isUsedMU Abs = True +isUsedMU (Use One _) = False +isUsedMU (Use Many u) = isUsedU u + +isUsedU :: UseDmd -> Bool +-- True <=> markReused d = d +isUsedU Used = True +isUsedU UHead = True +isUsedU (UProd us) = all isUsedMU us +isUsedU (UCall One _) = False +isUsedU (UCall Many _) = True -- No need to recurse + +-- Squashing usage demand demands +seqUseDmd :: UseDmd -> () +seqUseDmd (UProd ds) = seqArgUseList ds +seqUseDmd (UCall c d) = c `seq` seqUseDmd d +seqUseDmd _ = () + +seqArgUseList :: [ArgUse] -> () +seqArgUseList [] = () +seqArgUseList (d:ds) = seqArgUse d `seq` seqArgUseList ds + +seqArgUse :: ArgUse -> () +seqArgUse (Use c u) = c `seq` seqUseDmd u +seqArgUse _ = () + +-- Splitting polymorphic Maybe-Used demands +splitUseProdDmd :: Int -> UseDmd -> Maybe [ArgUse] +splitUseProdDmd n Used = Just (replicate n useTop) +splitUseProdDmd n UHead = Just (replicate n Abs) +splitUseProdDmd n (UProd ds) = WARN( not (ds `lengthIs` n), + text "splitUseProdDmd" $$ ppr n + $$ ppr ds ) + Just ds +splitUseProdDmd _ (UCall _ _) = Nothing + -- This can happen when the programmer uses unsafeCoerce, + -- and we don't then want to crash the compiler (#9208) + +useCount :: Use u -> Count +useCount Abs = One +useCount (Use One _) = One +useCount _ = Many + + +{- +************************************************************************ +* * + Clean demand for Strictness and Usage +* * +************************************************************************ + +This domain differst from JointDemand in the sence that pure absence +is taken away, i.e., we deal *only* with non-absent demands. + +Note [Strict demands] +~~~~~~~~~~~~~~~~~~~~~ +isStrictDmd returns true only of demands that are + both strict + and used +In particular, it is False for , which can and does +arise in, say (#7319) + f x = raise# +Then 'x' is not used, so f gets strictness -> . +Now the w/w generates + fx = let x = absentError "unused" + in raise +At this point we really don't want to convert to + fx = case absentError "unused" of x -> raise +Since the program is going to diverge, this swaps one error for another, +but it's really a bad idea to *ever* evaluate an absent argument. +In #7319 we get + T7319.exe: Oops! Entered absent arg w_s1Hd{v} [lid] [base:GHC.Base.String{tc 36u}] + +Note [Dealing with call demands] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Call demands are constructed and deconstructed coherently for +strictness and absence. For instance, the strictness signature for the +following function + +f :: (Int -> (Int, Int)) -> (Int, Bool) +f g = (snd (g 3), True) + +should be: m +-} + +type CleanDemand = JointDmd StrDmd UseDmd + -- A demand that is at least head-strict + +bothCleanDmd :: CleanDemand -> CleanDemand -> CleanDemand +bothCleanDmd (JD { sd = s1, ud = a1}) (JD { sd = s2, ud = a2}) + = JD { sd = s1 `bothStr` s2, ud = a1 `bothUse` a2 } + +mkHeadStrict :: CleanDemand -> CleanDemand +mkHeadStrict cd = cd { sd = HeadStr } + +mkOnceUsedDmd, mkManyUsedDmd :: CleanDemand -> Demand +mkOnceUsedDmd (JD {sd = s,ud = a}) = JD { sd = Str s, ud = Use One a } +mkManyUsedDmd (JD {sd = s,ud = a}) = JD { sd = Str s, ud = Use Many a } + +evalDmd :: Demand +-- Evaluated strictly, and used arbitrarily deeply +evalDmd = JD { sd = Str HeadStr, ud = useTop } + +mkProdDmd :: [Demand] -> CleanDemand +mkProdDmd dx + = JD { sd = mkSProd $ map getStrDmd dx + , ud = mkUProd $ map getUseDmd dx } + +mkCallDmd :: CleanDemand -> CleanDemand +mkCallDmd (JD {sd = d, ud = u}) + = JD { sd = mkSCall d, ud = mkUCall One u } + +-- See Note [Demand on the worker] in WorkWrap +mkWorkerDemand :: Int -> Demand +mkWorkerDemand n = JD { sd = Lazy, ud = Use One (go n) } + where go 0 = Used + go n = mkUCall One $ go (n-1) + +cleanEvalDmd :: CleanDemand +cleanEvalDmd = JD { sd = HeadStr, ud = Used } + +cleanEvalProdDmd :: Arity -> CleanDemand +cleanEvalProdDmd n = JD { sd = HeadStr, ud = UProd (replicate n useTop) } + + +{- +************************************************************************ +* * + Demand: combining stricness and usage +* * +************************************************************************ +-} + +type Demand = JointDmd ArgStr ArgUse + +lubDmd :: Demand -> Demand -> Demand +lubDmd (JD {sd = s1, ud = a1}) (JD {sd = s2, ud = a2}) + = JD { sd = s1 `lubArgStr` s2 + , ud = a1 `lubArgUse` a2 } + +bothDmd :: Demand -> Demand -> Demand +bothDmd (JD {sd = s1, ud = a1}) (JD {sd = s2, ud = a2}) + = JD { sd = s1 `bothArgStr` s2 + , ud = a1 `bothArgUse` a2 } + +lazyApply1Dmd, lazyApply2Dmd, strictApply1Dmd :: Demand + +strictApply1Dmd = JD { sd = Str (SCall HeadStr) + , ud = Use Many (UCall One Used) } + +lazyApply1Dmd = JD { sd = Lazy + , ud = Use One (UCall One Used) } + +-- Second argument of catch#: +-- uses its arg at most once, applies it once +-- but is lazy (might not be called at all) +lazyApply2Dmd = JD { sd = Lazy + , ud = Use One (UCall One (UCall One Used)) } + +absDmd :: Demand +absDmd = JD { sd = Lazy, ud = Abs } + +topDmd :: Demand +topDmd = JD { sd = Lazy, ud = useTop } + +botDmd :: Demand +botDmd = JD { sd = strBot, ud = useBot } + +seqDmd :: Demand +seqDmd = JD { sd = Str HeadStr, ud = Use One UHead } + +oneifyDmd :: JointDmd s (Use u) -> JointDmd s (Use u) +oneifyDmd (JD { sd = s, ud = Use _ a }) = JD { sd = s, ud = Use One a } +oneifyDmd jd = jd + +isTopDmd :: Demand -> Bool +-- Used to suppress pretty-printing of an uninformative demand +isTopDmd (JD {sd = Lazy, ud = Use Many Used}) = True +isTopDmd _ = False + +isAbsDmd :: JointDmd (Str s) (Use u) -> Bool +isAbsDmd (JD {ud = Abs}) = True -- The strictness part can be HyperStr +isAbsDmd _ = False -- for a bottom demand + +isSeqDmd :: Demand -> Bool +isSeqDmd (JD {sd = Str HeadStr, ud = Use _ UHead}) = True +isSeqDmd _ = False + +isUsedOnce :: JointDmd (Str s) (Use u) -> Bool +isUsedOnce (JD { ud = a }) = case useCount a of + One -> True + Many -> False + +-- More utility functions for strictness +seqDemand :: Demand -> () +seqDemand (JD {sd = s, ud = u}) = seqArgStr s `seq` seqArgUse u + +seqDemandList :: [Demand] -> () +seqDemandList [] = () +seqDemandList (d:ds) = seqDemand d `seq` seqDemandList ds + +isStrictDmd :: JointDmd (Str s) (Use u) -> Bool +-- See Note [Strict demands] +isStrictDmd (JD {ud = Abs}) = False +isStrictDmd (JD {sd = Lazy}) = False +isStrictDmd _ = True + +isWeakDmd :: Demand -> Bool +isWeakDmd (JD {sd = s, ud = a}) = isLazy s && isUsedMU a + +cleanUseDmd_maybe :: Demand -> Maybe UseDmd +cleanUseDmd_maybe (JD { ud = Use _ u }) = Just u +cleanUseDmd_maybe _ = Nothing + +splitFVs :: Bool -- Thunk + -> DmdEnv -> (DmdEnv, DmdEnv) +splitFVs is_thunk rhs_fvs + | is_thunk = nonDetFoldUFM_Directly add (emptyVarEnv, emptyVarEnv) rhs_fvs + -- It's OK to use nonDetFoldUFM_Directly because we + -- immediately forget the ordering by putting the elements + -- in the envs again + | otherwise = partitionVarEnv isWeakDmd rhs_fvs + where + add uniq dmd@(JD { sd = s, ud = u }) (lazy_fv, sig_fv) + | Lazy <- s = (addToUFM_Directly lazy_fv uniq dmd, sig_fv) + | otherwise = ( addToUFM_Directly lazy_fv uniq (JD { sd = Lazy, ud = u }) + , addToUFM_Directly sig_fv uniq (JD { sd = s, ud = Abs }) ) + +data TypeShape = TsFun TypeShape + | TsProd [TypeShape] + | TsUnk + +instance Outputable TypeShape where + ppr TsUnk = text "TsUnk" + ppr (TsFun ts) = text "TsFun" <> parens (ppr ts) + ppr (TsProd tss) = parens (hsep $ punctuate comma $ map ppr tss) + +trimToType :: Demand -> TypeShape -> Demand +-- See Note [Trimming a demand to a type] +trimToType (JD { sd = ms, ud = mu }) ts + = JD (go_ms ms ts) (go_mu mu ts) + where + go_ms :: ArgStr -> TypeShape -> ArgStr + go_ms Lazy _ = Lazy + go_ms (Str s) ts = Str (go_s s ts) + + go_s :: StrDmd -> TypeShape -> StrDmd + go_s HyperStr _ = HyperStr + go_s (SCall s) (TsFun ts) = SCall (go_s s ts) + go_s (SProd mss) (TsProd tss) + | equalLength mss tss = SProd (zipWith go_ms mss tss) + go_s _ _ = HeadStr + + go_mu :: ArgUse -> TypeShape -> ArgUse + go_mu Abs _ = Abs + go_mu (Use c u) ts = Use c (go_u u ts) + + go_u :: UseDmd -> TypeShape -> UseDmd + go_u UHead _ = UHead + go_u (UCall c u) (TsFun ts) = UCall c (go_u u ts) + go_u (UProd mus) (TsProd tss) + | equalLength mus tss = UProd (zipWith go_mu mus tss) + go_u _ _ = Used + +{- +Note [Trimming a demand to a type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + + f :: a -> Bool + f x = case ... of + A g1 -> case (x |> g1) of (p,q) -> ... + B -> error "urk" + +where A,B are the constructors of a GADT. We'll get a U(U,U) demand +on x from the A branch, but that's a stupid demand for x itself, which +has type 'a'. Indeed we get ASSERTs going off (notably in +splitUseProdDmd, #8569). + +Bottom line: we really don't want to have a binder whose demand is more +deeply-nested than its type. There are various ways to tackle this. +When processing (x |> g1), we could "trim" the incoming demand U(U,U) +to match x's type. But I'm currently doing so just at the moment when +we pin a demand on a binder, in DmdAnal.findBndrDmd. + + +Note [Threshold demands] +~~~~~~~~~~~~~~~~~~~~~~~~ +Threshold usage demand is generated to figure out if +cardinality-instrumented demands of a binding's free variables should +be unleashed. See also [Aggregated demand for cardinality]. + +Note [Replicating polymorphic demands] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Some demands can be considered as polymorphic. Generally, it is +applicable to such beasts as tops, bottoms as well as Head-Used and +Head-stricts demands. For instance, + +S ~ S(L, ..., L) + +Also, when top or bottom is occurred as a result demand, it in fact +can be expanded to saturate a callee's arity. +-} + +splitProdDmd_maybe :: Demand -> Maybe [Demand] +-- Split a product into its components, iff there is any +-- useful information to be extracted thereby +-- The demand is not necessarily strict! +splitProdDmd_maybe (JD { sd = s, ud = u }) + = case (s,u) of + (Str (SProd sx), Use _ u) | Just ux <- splitUseProdDmd (length sx) u + -> Just (mkJointDmds sx ux) + (Str s, Use _ (UProd ux)) | Just sx <- splitStrProdDmd (length ux) s + -> Just (mkJointDmds sx ux) + (Lazy, Use _ (UProd ux)) -> Just (mkJointDmds (replicate (length ux) Lazy) ux) + _ -> Nothing + +{- +************************************************************************ +* * + Demand results +* * +************************************************************************ + + +DmdResult: Dunno CPRResult + / + Diverges + + +CPRResult: NoCPR + / \ + RetProd RetSum ConTag + + +Product constructors return (Dunno (RetProd rs)) +In a fixpoint iteration, start from Diverges +We have lubs, but not glbs; but that is ok. +-} + +------------------------------------------------------------------------ +-- Constructed Product Result +------------------------------------------------------------------------ + +data Termination r + = Diverges -- Definitely diverges + | Dunno r -- Might diverge or converge + deriving( Eq, Show ) + +-- At this point, Termination is just the 'Lifted' lattice over 'r' +-- (https://hackage.haskell.org/package/lattices/docs/Algebra-Lattice-Lifted.html) + +type DmdResult = Termination CPRResult + +data CPRResult = NoCPR -- Top of the lattice + | RetProd -- Returns a constructor from a product type + | RetSum ConTag -- Returns a constructor from a data type + deriving( Eq, Show ) + +lubCPR :: CPRResult -> CPRResult -> CPRResult +lubCPR (RetSum t1) (RetSum t2) + | t1 == t2 = RetSum t1 +lubCPR RetProd RetProd = RetProd +lubCPR _ _ = NoCPR + +lubDmdResult :: DmdResult -> DmdResult -> DmdResult +lubDmdResult Diverges r = r +lubDmdResult r Diverges = r +lubDmdResult (Dunno c1) (Dunno c2) = Dunno (c1 `lubCPR` c2) +-- This needs to commute with defaultDmd, i.e. +-- defaultDmd (r1 `lubDmdResult` r2) = defaultDmd r1 `lubDmd` defaultDmd r2 +-- (See Note [Default demand on free variables] for why) + +bothDmdResult :: DmdResult -> Termination () -> DmdResult +-- See Note [Asymmetry of 'both' for DmdType and DmdResult] +bothDmdResult _ Diverges = Diverges +bothDmdResult r (Dunno {}) = r +-- This needs to commute with defaultDmd, i.e. +-- defaultDmd (r1 `bothDmdResult` r2) = defaultDmd r1 `bothDmd` defaultDmd r2 +-- (See Note [Default demand on free variables] for why) + +instance Outputable r => Outputable (Termination r) where + ppr Diverges = char 'b' + ppr (Dunno c) = ppr c + +instance Outputable CPRResult where + ppr NoCPR = empty + ppr (RetSum n) = char 'm' <> int n + ppr RetProd = char 'm' + +seqDmdResult :: DmdResult -> () +seqDmdResult Diverges = () +seqDmdResult (Dunno c) = seqCPRResult c + +seqCPRResult :: CPRResult -> () +seqCPRResult NoCPR = () +seqCPRResult (RetSum n) = n `seq` () +seqCPRResult RetProd = () + + +------------------------------------------------------------------------ +-- Combined demand result -- +------------------------------------------------------------------------ + +-- [cprRes] lets us switch off CPR analysis +-- by making sure that everything uses TopRes +topRes, botRes :: DmdResult +topRes = Dunno NoCPR +botRes = Diverges + +cprSumRes :: ConTag -> DmdResult +cprSumRes tag = Dunno $ RetSum tag + +cprProdRes :: [DmdType] -> DmdResult +cprProdRes _arg_tys = Dunno $ RetProd + +vanillaCprProdRes :: Arity -> DmdResult +vanillaCprProdRes _arity = Dunno $ RetProd + +isTopRes :: DmdResult -> Bool +isTopRes (Dunno NoCPR) = True +isTopRes _ = False + +-- | True if the result diverges or throws an exception +isBotRes :: DmdResult -> Bool +isBotRes Diverges = True +isBotRes (Dunno {}) = False + +trimCPRInfo :: Bool -> Bool -> DmdResult -> DmdResult +trimCPRInfo trim_all trim_sums res + = trimR res + where + trimR (Dunno c) = Dunno (trimC c) + trimR res = res + + trimC (RetSum n) | trim_all || trim_sums = NoCPR + | otherwise = RetSum n + trimC RetProd | trim_all = NoCPR + | otherwise = RetProd + trimC NoCPR = NoCPR + +returnsCPR_maybe :: DmdResult -> Maybe ConTag +returnsCPR_maybe (Dunno c) = retCPR_maybe c +returnsCPR_maybe _ = Nothing + +retCPR_maybe :: CPRResult -> Maybe ConTag +retCPR_maybe (RetSum t) = Just t +retCPR_maybe RetProd = Just fIRST_TAG +retCPR_maybe NoCPR = Nothing + +-- See Notes [Default demand on free variables] +-- and [defaultDmd vs. resTypeArgDmd] +defaultDmd :: Termination r -> Demand +defaultDmd (Dunno {}) = absDmd +defaultDmd _ = botDmd -- Diverges + +resTypeArgDmd :: Termination r -> Demand +-- TopRes and BotRes are polymorphic, so that +-- BotRes === (Bot -> BotRes) === ... +-- TopRes === (Top -> TopRes) === ... +-- This function makes that concrete +-- Also see Note [defaultDmd vs. resTypeArgDmd] +resTypeArgDmd (Dunno _) = topDmd +resTypeArgDmd _ = botDmd -- Diverges + +{- +Note [defaultDmd and resTypeArgDmd] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +These functions are similar: They express the demand on something not +explicitly mentioned in the environment resp. the argument list. Yet they are +different: + * Variables not mentioned in the free variables environment are definitely + unused, so we can use absDmd there. + * Further arguments *can* be used, of course. Hence topDmd is used. + + +************************************************************************ +* * + Demand environments and types +* * +************************************************************************ +-} + +type DmdEnv = VarEnv Demand -- See Note [Default demand on free variables] + +data DmdType = DmdType + DmdEnv -- Demand on explicitly-mentioned + -- free variables + [Demand] -- Demand on arguments + DmdResult -- See [Nature of result demand] + +{- +Note [Nature of result demand] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A DmdResult contains information about termination (currently distinguishing +definite divergence and no information; it is possible to include definite +convergence here), and CPR information about the result. + +The semantics of this depends on whether we are looking at a DmdType, i.e. the +demand put on by an expression _under a specific incoming demand_ on its +environment, or at a StrictSig describing a demand transformer. + +For a + * DmdType, the termination information is true given the demand it was + generated with, while for + * a StrictSig it holds after applying enough arguments. + +The CPR information, though, is valid after the number of arguments mentioned +in the type is given. Therefore, when forgetting the demand on arguments, as in +dmdAnalRhs, this needs to be considere (via removeDmdTyArgs). + +Consider + b2 x y = x `seq` y `seq` error (show x) +this has a strictness signature of + b +meaning that "b2 `seq` ()" and "b2 1 `seq` ()" might well terminate, but +for "b2 1 2 `seq` ()" we get definite divergence. + +For comparison, + b1 x = x `seq` error (show x) +has a strictness signature of + b +and "b1 1 `seq` ()" is known to terminate. + +Now consider a function h with signature "", and the expression + e1 = h b1 +now h puts a demand of onto its argument, and the demand transformer +turns it into + b +Now the DmdResult "b" does apply to us, even though "b1 `seq` ()" does not +diverge, and we do not anything being passed to b. + +Note [Asymmetry of 'both' for DmdType and DmdResult] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +'both' for DmdTypes is *asymmetrical*, because there is only one +result! For example, given (e1 e2), we get a DmdType dt1 for e1, use +its arg demand to analyse e2 giving dt2, and then do (dt1 `bothType` dt2). +Similarly with + case e of { p -> rhs } +we get dt_scrut from the scrutinee and dt_rhs from the RHS, and then +compute (dt_rhs `bothType` dt_scrut). + +We + 1. combine the information on the free variables, + 2. take the demand on arguments from the first argument + 3. combine the termination results, but + 4. take CPR info from the first argument. + +3 and 4 are implementd in bothDmdResult. +-} + +-- Equality needed for fixpoints in DmdAnal +instance Eq DmdType where + (==) (DmdType fv1 ds1 res1) + (DmdType fv2 ds2 res2) = nonDetUFMToList fv1 == nonDetUFMToList fv2 + -- It's OK to use nonDetUFMToList here because we're testing for + -- equality and even though the lists will be in some arbitrary + -- Unique order, it is the same order for both + && ds1 == ds2 && res1 == res2 + +lubDmdType :: DmdType -> DmdType -> DmdType +lubDmdType d1 d2 + = DmdType lub_fv lub_ds lub_res + where + n = max (dmdTypeDepth d1) (dmdTypeDepth d2) + (DmdType fv1 ds1 r1) = ensureArgs n d1 + (DmdType fv2 ds2 r2) = ensureArgs n d2 + + lub_fv = plusVarEnv_CD lubDmd fv1 (defaultDmd r1) fv2 (defaultDmd r2) + lub_ds = zipWithEqual "lubDmdType" lubDmd ds1 ds2 + lub_res = lubDmdResult r1 r2 + +{- +Note [The need for BothDmdArg] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Previously, the right argument to bothDmdType, as well as the return value of +dmdAnalStar via postProcessDmdType, was a DmdType. But bothDmdType only needs +to know about the free variables and termination information, but nothing about +the demand put on arguments, nor cpr information. So we make that explicit by +only passing the relevant information. +-} + +type BothDmdArg = (DmdEnv, Termination ()) + +mkBothDmdArg :: DmdEnv -> BothDmdArg +mkBothDmdArg env = (env, Dunno ()) + +toBothDmdArg :: DmdType -> BothDmdArg +toBothDmdArg (DmdType fv _ r) = (fv, go r) + where + go (Dunno {}) = Dunno () + go Diverges = Diverges + +bothDmdType :: DmdType -> BothDmdArg -> DmdType +bothDmdType (DmdType fv1 ds1 r1) (fv2, t2) + -- See Note [Asymmetry of 'both' for DmdType and DmdResult] + -- 'both' takes the argument/result info from its *first* arg, + -- using its second arg just for its free-var info. + = DmdType (plusVarEnv_CD bothDmd fv1 (defaultDmd r1) fv2 (defaultDmd t2)) + ds1 + (r1 `bothDmdResult` t2) + +instance Outputable DmdType where + ppr (DmdType fv ds res) + = hsep [hcat (map ppr ds) <> ppr res, + if null fv_elts then empty + else braces (fsep (map pp_elt fv_elts))] + where + pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd + fv_elts = nonDetUFMToList fv + -- It's OK to use nonDetUFMToList here because we only do it for + -- pretty printing + +emptyDmdEnv :: VarEnv Demand +emptyDmdEnv = emptyVarEnv + +-- nopDmdType is the demand of doing nothing +-- (lazy, absent, no CPR information, no termination information). +-- Note that it is ''not'' the top of the lattice (which would be "may use everything"), +-- so it is (no longer) called topDmd +nopDmdType, botDmdType :: DmdType +nopDmdType = DmdType emptyDmdEnv [] topRes +botDmdType = DmdType emptyDmdEnv [] botRes + +cprProdDmdType :: Arity -> DmdType +cprProdDmdType arity + = DmdType emptyDmdEnv [] (vanillaCprProdRes arity) + +isTopDmdType :: DmdType -> Bool +isTopDmdType (DmdType env [] res) + | isTopRes res && isEmptyVarEnv env = True +isTopDmdType _ = False + +mkDmdType :: DmdEnv -> [Demand] -> DmdResult -> DmdType +mkDmdType fv ds res = DmdType fv ds res + +dmdTypeDepth :: DmdType -> Arity +dmdTypeDepth (DmdType _ ds _) = length ds + +-- Remove any demand on arguments. This is used in dmdAnalRhs on the body +removeDmdTyArgs :: DmdType -> DmdType +removeDmdTyArgs = ensureArgs 0 + +-- This makes sure we can use the demand type with n arguments, +-- It extends the argument list with the correct resTypeArgDmd +-- It also adjusts the DmdResult: Divergence survives additional arguments, +-- CPR information does not (and definite converge also would not). +ensureArgs :: Arity -> DmdType -> DmdType +ensureArgs n d | n == depth = d + | otherwise = DmdType fv ds' r' + where depth = dmdTypeDepth d + DmdType fv ds r = d + + ds' = take n (ds ++ repeat (resTypeArgDmd r)) + r' = case r of -- See [Nature of result demand] + Dunno _ -> topRes + _ -> r + + +seqDmdType :: DmdType -> () +seqDmdType (DmdType env ds res) = + seqDmdEnv env `seq` seqDemandList ds `seq` seqDmdResult res `seq` () + +seqDmdEnv :: DmdEnv -> () +seqDmdEnv env = seqEltsUFM seqDemandList env + +splitDmdTy :: DmdType -> (Demand, DmdType) +-- Split off one function argument +-- We already have a suitable demand on all +-- free vars, so no need to add more! +splitDmdTy (DmdType fv (dmd:dmds) res_ty) = (dmd, DmdType fv dmds res_ty) +splitDmdTy ty@(DmdType _ [] res_ty) = (resTypeArgDmd res_ty, ty) + +-- When e is evaluated after executing an IO action, and d is e's demand, then +-- what of this demand should we consider, given that the IO action can cleanly +-- exit? +-- * We have to kill all strictness demands (i.e. lub with a lazy demand) +-- * We can keep usage information (i.e. lub with an absent demand) +-- * We have to kill definite divergence +-- * We can keep CPR information. +-- See Note [IO hack in the demand analyser] in DmdAnal +deferAfterIO :: DmdType -> DmdType +deferAfterIO d@(DmdType _ _ res) = + case d `lubDmdType` nopDmdType of + DmdType fv ds _ -> DmdType fv ds (defer_res res) + where + defer_res r@(Dunno {}) = r + defer_res _ = topRes -- Diverges + +strictenDmd :: Demand -> CleanDemand +strictenDmd (JD { sd = s, ud = u}) + = JD { sd = poke_s s, ud = poke_u u } + where + poke_s Lazy = HeadStr + poke_s (Str s) = s + poke_u Abs = UHead + poke_u (Use _ u) = u + +-- Deferring and peeling + +type DmdShell -- Describes the "outer shell" + -- of a Demand + = JointDmd (Str ()) (Use ()) + +toCleanDmd :: Demand -> (DmdShell, CleanDemand) +-- Splits a Demand into its "shell" and the inner "clean demand" +toCleanDmd (JD { sd = s, ud = u }) + = (JD { sd = ss, ud = us }, JD { sd = s', ud = u' }) + -- See Note [Analyzing with lazy demand and lambdas] + -- See Note [Analysing with absent demand] + where + (ss, s') = case s of + Str s' -> (Str (), s') + Lazy -> (Lazy, HeadStr) + + (us, u') = case u of + Use c u' -> (Use c (), u') + Abs -> (Abs, Used) + +-- This is used in dmdAnalStar when post-processing +-- a function's argument demand. So we only care about what +-- does to free variables, and whether it terminates. +-- see Note [The need for BothDmdArg] +postProcessDmdType :: DmdShell -> DmdType -> BothDmdArg +postProcessDmdType du@(JD { sd = ss }) (DmdType fv _ res_ty) + = (postProcessDmdEnv du fv, term_info) + where + term_info = case postProcessDmdResult ss res_ty of + Dunno _ -> Dunno () + Diverges -> Diverges + +postProcessDmdResult :: Str () -> DmdResult -> DmdResult +postProcessDmdResult Lazy _ = topRes +postProcessDmdResult _ res = res + +postProcessDmdEnv :: DmdShell -> DmdEnv -> DmdEnv +postProcessDmdEnv ds@(JD { sd = ss, ud = us }) env + | Abs <- us = emptyDmdEnv + -- In this case (postProcessDmd ds) == id; avoid a redundant rebuild + -- of the environment. Be careful, bad things will happen if this doesn't + -- match postProcessDmd (see #13977). + | Str _ <- ss + , Use One _ <- us = env + | otherwise = mapVarEnv (postProcessDmd ds) env + -- For the Absent case just discard all usage information + -- We only processed the thing at all to analyse the body + -- See Note [Always analyse in virgin pass] + +reuseEnv :: DmdEnv -> DmdEnv +reuseEnv = mapVarEnv (postProcessDmd + (JD { sd = Str (), ud = Use Many () })) + +postProcessUnsat :: DmdShell -> DmdType -> DmdType +postProcessUnsat ds@(JD { sd = ss }) (DmdType fv args res_ty) + = DmdType (postProcessDmdEnv ds fv) + (map (postProcessDmd ds) args) + (postProcessDmdResult ss res_ty) + +postProcessDmd :: DmdShell -> Demand -> Demand +postProcessDmd (JD { sd = ss, ud = us }) (JD { sd = s, ud = a}) + = JD { sd = s', ud = a' } + where + s' = case ss of + Lazy -> Lazy + Str _ -> s + a' = case us of + Abs -> Abs + Use Many _ -> markReusedDmd a + Use One _ -> a + +-- Peels one call level from the demand, and also returns +-- whether it was unsaturated (separately for strictness and usage) +peelCallDmd :: CleanDemand -> (CleanDemand, DmdShell) +-- Exploiting the fact that +-- on the strictness side C(B) = B +-- and on the usage side C(U) = U +peelCallDmd (JD {sd = s, ud = u}) + = (JD { sd = s', ud = u' }, JD { sd = ss, ud = us }) + where + (s', ss) = case s of + SCall s' -> (s', Str ()) + HyperStr -> (HyperStr, Str ()) + _ -> (HeadStr, Lazy) + (u', us) = case u of + UCall c u' -> (u', Use c ()) + _ -> (Used, Use Many ()) + -- The _ cases for usage includes UHead which seems a bit wrong + -- because the body isn't used at all! + -- c.f. the Abs case in toCleanDmd + +-- Peels that multiple nestings of calls clean demand and also returns +-- whether it was unsaturated (separately for strictness and usage +-- see Note [Demands from unsaturated function calls] +peelManyCalls :: Int -> CleanDemand -> DmdShell +peelManyCalls n (JD { sd = str, ud = abs }) + = JD { sd = go_str n str, ud = go_abs n abs } + where + go_str :: Int -> StrDmd -> Str () -- True <=> unsaturated, defer + go_str 0 _ = Str () + go_str _ HyperStr = Str () -- == go_str (n-1) HyperStr, as HyperStr = Call(HyperStr) + go_str n (SCall d') = go_str (n-1) d' + go_str _ _ = Lazy + + go_abs :: Int -> UseDmd -> Use () -- Many <=> unsaturated, or at least + go_abs 0 _ = Use One () -- one UCall Many in the demand + go_abs n (UCall One d') = go_abs (n-1) d' + go_abs _ _ = Use Many () + +{- +Note [Demands from unsaturated function calls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Consider a demand transformer d1 -> d2 -> r for f. +If a sufficiently detailed demand is fed into this transformer, +e.g arising from "f x1 x2" in a strict, use-once context, +then d1 and d2 is precisely the demand unleashed onto x1 and x2 (similar for +the free variable environment) and furthermore the result information r is the +one we want to use. + +An anonymous lambda is also an unsaturated function all (needs one argument, +none given), so this applies to that case as well. + +But the demand fed into f might be less than . There are a few cases: + * Not enough demand on the strictness side: + - In that case, we need to zap all strictness in the demand on arguments and + free variables. + - Furthermore, we remove CPR information. It could be left, but given the incoming + demand is not enough to evaluate so far we just do not bother. + - And finally termination information: If r says that f diverges for sure, + then this holds when the demand guarantees that two arguments are going to + be passed. If the demand is lower, we may just as well converge. + If we were tracking definite convegence, than that would still hold under + a weaker demand than expected by the demand transformer. + * Not enough demand from the usage side: The missing usage can be expanded + using UCall Many, therefore this is subsumed by the third case: + * At least one of the uses has a cardinality of Many. + - Even if f puts a One demand on any of its argument or free variables, if + we call f multiple times, we may evaluate this argument or free variable + multiple times. So forget about any occurrence of "One" in the demand. + +In dmdTransformSig, we call peelManyCalls to find out if we are in any of these +cases, and then call postProcessUnsat to reduce the demand appropriately. + +Similarly, dmdTransformDictSelSig and dmdAnal, when analyzing a Lambda, use +peelCallDmd, which peels only one level, but also returns the demand put on the +body of the function. +-} + +peelFV :: DmdType -> Var -> (DmdType, Demand) +peelFV (DmdType fv ds res) id = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv) + (DmdType fv' ds res, dmd) + where + fv' = fv `delVarEnv` id + -- See Note [Default demand on free variables] + dmd = lookupVarEnv fv id `orElse` defaultDmd res + +addDemand :: Demand -> DmdType -> DmdType +addDemand dmd (DmdType fv ds res) = DmdType fv (dmd:ds) res + +findIdDemand :: DmdType -> Var -> Demand +findIdDemand (DmdType fv _ res) id + = lookupVarEnv fv id `orElse` defaultDmd res + +{- +Note [Default demand on free variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the variable is not mentioned in the environment of a demand type, +its demand is taken to be a result demand of the type. + For the stricness component, + if the result demand is a Diverges, then we use HyperStr + else we use Lazy + For the usage component, we use Absent. +So we use either absDmd or botDmd. + +Also note the equations for lubDmdResult (resp. bothDmdResult) noted there. + +Note [Always analyse in virgin pass] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Tricky point: make sure that we analyse in the 'virgin' pass. Consider + rec { f acc x True = f (...rec { g y = ...g... }...) + f acc x False = acc } +In the virgin pass for 'f' we'll give 'f' a very strict (bottom) type. +That might mean that we analyse the sub-expression containing the +E = "...rec g..." stuff in a bottom demand. Suppose we *didn't analyse* +E, but just returned botType. + +Then in the *next* (non-virgin) iteration for 'f', we might analyse E +in a weaker demand, and that will trigger doing a fixpoint iteration +for g. But *because it's not the virgin pass* we won't start g's +iteration at bottom. Disaster. (This happened in $sfibToList' of +nofib/spectral/fibheaps.) + +So in the virgin pass we make sure that we do analyse the expression +at least once, to initialise its signatures. + +Note [Analyzing with lazy demand and lambdas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The insight for analyzing lambdas follows from the fact that for +strictness S = C(L). This polymorphic expansion is critical for +cardinality analysis of the following example: + +{-# NOINLINE build #-} +build g = (g (:) [], g (:) []) + +h c z = build (\x -> + let z1 = z ++ z + in if c + then \y -> x (y ++ z1) + else \y -> x (z1 ++ y)) + +One can see that `build` assigns to `g` demand . +Therefore, when analyzing the lambda `(\x -> ...)`, we +expect each lambda \y -> ... to be annotated as "one-shot" +one. Therefore (\x -> \y -> x (y ++ z)) should be analyzed with a +demand . + +This is achieved by, first, converting the lazy demand L into the +strict S by the second clause of the analysis. + +Note [Analysing with absent demand] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we analyse an expression with demand . The "A" means +"absent", so this expression will never be needed. What should happen? +There are several wrinkles: + +* We *do* want to analyse the expression regardless. + Reason: Note [Always analyse in virgin pass] + + But we can post-process the results to ignore all the usage + demands coming back. This is done by postProcessDmdType. + +* In a previous incarnation of GHC we needed to be extra careful in the + case of an *unlifted type*, because unlifted values are evaluated + even if they are not used. Example (see #9254): + f :: (() -> (# Int#, () #)) -> () + -- Strictness signature is + -- + -- I.e. calls k, but discards first component of result + f k = case k () of (# _, r #) -> r + + g :: Int -> () + g y = f (\n -> (# case y of I# y2 -> y2, n #)) + + Here f's strictness signature says (correctly) that it calls its + argument function and ignores the first component of its result. + This is correct in the sense that it'd be fine to (say) modify the + function so that always returned 0# in the first component. + + But in function g, we *will* evaluate the 'case y of ...', because + it has type Int#. So 'y' will be evaluated. So we must record this + usage of 'y', else 'g' will say 'y' is absent, and will w/w so that + 'y' is bound to an aBSENT_ERROR thunk. + + However, the argument of toCleanDmd always satisfies the let/app + invariant; so if it is unlifted it is also okForSpeculation, and so + can be evaluated in a short finite time -- and that rules out nasty + cases like the one above. (I'm not quite sure why this was a + problem in an earlier version of GHC, but it isn't now.) + + +************************************************************************ +* * + Demand signatures +* * +************************************************************************ + +In a let-bound Id we record its strictness info. +In principle, this strictness info is a demand transformer, mapping +a demand on the Id into a DmdType, which gives + a) the free vars of the Id's value + b) the Id's arguments + c) an indication of the result of applying + the Id to its arguments + +However, in fact we store in the Id an extremely emascuated demand +transfomer, namely + + a single DmdType +(Nevertheless we dignify StrictSig as a distinct type.) + +This DmdType gives the demands unleashed by the Id when it is applied +to as many arguments as are given in by the arg demands in the DmdType. +Also see Note [Nature of result demand] for the meaning of a DmdResult in a +strictness signature. + +If an Id is applied to less arguments than its arity, it means that +the demand on the function at a call site is weaker than the vanilla +call demand, used for signature inference. Therefore we place a top +demand on all arguments. Otherwise, the demand is specified by Id's +signature. + +For example, the demand transformer described by the demand signature + StrictSig (DmdType {x -> } m) +says that when the function is applied to two arguments, it +unleashes demand on the free var x, on the first arg, +and on the second, then returning a constructor. + +If this same function is applied to one arg, all we can say is that it +uses x with , and its arg with demand . +-} + +newtype StrictSig = StrictSig DmdType + deriving( Eq ) + +instance Outputable StrictSig where + ppr (StrictSig ty) = ppr ty + +-- Used for printing top-level strictness pragmas in interface files +pprIfaceStrictSig :: StrictSig -> SDoc +pprIfaceStrictSig (StrictSig (DmdType _ dmds res)) + = hcat (map ppr dmds) <> ppr res + +mkStrictSig :: DmdType -> StrictSig +mkStrictSig dmd_ty = StrictSig dmd_ty + +mkClosedStrictSig :: [Demand] -> DmdResult -> StrictSig +mkClosedStrictSig ds res = mkStrictSig (DmdType emptyDmdEnv ds res) + +splitStrictSig :: StrictSig -> ([Demand], DmdResult) +splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res) + +increaseStrictSigArity :: Int -> StrictSig -> StrictSig +-- Add extra arguments to a strictness signature +increaseStrictSigArity arity_increase sig@(StrictSig dmd_ty@(DmdType env dmds res)) + | isTopDmdType dmd_ty = sig + | arity_increase <= 0 = sig + | otherwise = StrictSig (DmdType env dmds' res) + where + dmds' = replicate arity_increase topDmd ++ dmds + +etaExpandStrictSig :: Arity -> StrictSig -> StrictSig +-- We are expanding (\x y. e) to (\x y z. e z) +-- Add exta demands to the /end/ of the arg demands if necessary +etaExpandStrictSig arity sig@(StrictSig dmd_ty@(DmdType env dmds res)) + | isTopDmdType dmd_ty = sig + | arity_increase <= 0 = sig + | otherwise = StrictSig (DmdType env dmds' res) + where + arity_increase = arity - length dmds + dmds' = dmds ++ replicate arity_increase topDmd + +isTopSig :: StrictSig -> Bool +isTopSig (StrictSig ty) = isTopDmdType ty + +hasDemandEnvSig :: StrictSig -> Bool +hasDemandEnvSig (StrictSig (DmdType env _ _)) = not (isEmptyVarEnv env) + +strictSigDmdEnv :: StrictSig -> DmdEnv +strictSigDmdEnv (StrictSig (DmdType env _ _)) = env + +-- | True if the signature diverges or throws an exception +isBottomingSig :: StrictSig -> Bool +isBottomingSig (StrictSig (DmdType _ _ res)) = isBotRes res + +nopSig, botSig :: StrictSig +nopSig = StrictSig nopDmdType +botSig = StrictSig botDmdType + +cprProdSig :: Arity -> StrictSig +cprProdSig arity = StrictSig (cprProdDmdType arity) + +seqStrictSig :: StrictSig -> () +seqStrictSig (StrictSig ty) = seqDmdType ty + +dmdTransformSig :: StrictSig -> CleanDemand -> DmdType +-- (dmdTransformSig fun_sig dmd) considers a call to a function whose +-- signature is fun_sig, with demand dmd. We return the demand +-- that the function places on its context (eg its args) +dmdTransformSig (StrictSig dmd_ty@(DmdType _ arg_ds _)) cd + = postProcessUnsat (peelManyCalls (length arg_ds) cd) dmd_ty + -- see Note [Demands from unsaturated function calls] + +dmdTransformDataConSig :: Arity -> StrictSig -> CleanDemand -> DmdType +-- Same as dmdTransformSig but for a data constructor (worker), +-- which has a special kind of demand transformer. +-- If the constructor is saturated, we feed the demand on +-- the result into the constructor arguments. +dmdTransformDataConSig arity (StrictSig (DmdType _ _ con_res)) + (JD { sd = str, ud = abs }) + | Just str_dmds <- go_str arity str + , Just abs_dmds <- go_abs arity abs + = DmdType emptyDmdEnv (mkJointDmds str_dmds abs_dmds) con_res + -- Must remember whether it's a product, hence con_res, not TopRes + + | otherwise -- Not saturated + = nopDmdType + where + go_str 0 dmd = splitStrProdDmd arity dmd + go_str n (SCall s') = go_str (n-1) s' + go_str n HyperStr = go_str (n-1) HyperStr + go_str _ _ = Nothing + + go_abs 0 dmd = splitUseProdDmd arity dmd + go_abs n (UCall One u') = go_abs (n-1) u' + go_abs _ _ = Nothing + +dmdTransformDictSelSig :: StrictSig -> CleanDemand -> DmdType +-- Like dmdTransformDataConSig, we have a special demand transformer +-- for dictionary selectors. If the selector is saturated (ie has one +-- argument: the dictionary), we feed the demand on the result into +-- the indicated dictionary component. +dmdTransformDictSelSig (StrictSig (DmdType _ [dict_dmd] _)) cd + | (cd',defer_use) <- peelCallDmd cd + , Just jds <- splitProdDmd_maybe dict_dmd + = postProcessUnsat defer_use $ + DmdType emptyDmdEnv [mkOnceUsedDmd $ mkProdDmd $ map (enhance cd') jds] topRes + | otherwise + = nopDmdType -- See Note [Demand transformer for a dictionary selector] + where + enhance cd old | isAbsDmd old = old + | otherwise = mkOnceUsedDmd cd -- This is the one! + +dmdTransformDictSelSig _ _ = panic "dmdTransformDictSelSig: no args" + +{- +Note [Demand transformer for a dictionary selector] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we evaluate (op dict-expr) under demand 'd', then we can push the demand 'd' +into the appropriate field of the dictionary. What *is* the appropriate field? +We just look at the strictness signature of the class op, which will be +something like: U(AAASAAAAA). Then replace the 'S' by the demand 'd'. + +For single-method classes, which are represented by newtypes the signature +of 'op' won't look like U(...), so the splitProdDmd_maybe will fail. +That's fine: if we are doing strictness analysis we are also doing inlining, +so we'll have inlined 'op' into a cast. So we can bale out in a conservative +way, returning nopDmdType. + +It is (just.. #8329) possible to be running strictness analysis *without* +having inlined class ops from single-method classes. Suppose you are using +ghc --make; and the first module has a local -O0 flag. So you may load a class +without interface pragmas, ie (currently) without an unfolding for the class +ops. Now if a subsequent module in the --make sweep has a local -O flag +you might do strictness analysis, but there is no inlining for the class op. +This is weird, so I'm not worried about whether this optimises brilliantly; but +it should not fall over. +-} + +argsOneShots :: StrictSig -> Arity -> [[OneShotInfo]] +-- See Note [Computing one-shot info] +argsOneShots (StrictSig (DmdType _ arg_ds _)) n_val_args + | unsaturated_call = [] + | otherwise = go arg_ds + where + unsaturated_call = arg_ds `lengthExceeds` n_val_args + + go [] = [] + go (arg_d : arg_ds) = argOneShots arg_d `cons` go arg_ds + + -- Avoid list tail like [ [], [], [] ] + cons [] [] = [] + cons a as = a:as + +-- saturatedByOneShots n C1(C1(...)) = True, +-- <=> +-- there are at least n nested C1(..) calls +-- See Note [Demand on the worker] in WorkWrap +saturatedByOneShots :: Int -> Demand -> Bool +saturatedByOneShots n (JD { ud = usg }) + = case usg of + Use _ arg_usg -> go n arg_usg + _ -> False + where + go 0 _ = True + go n (UCall One u) = go (n-1) u + go _ _ = False + +argOneShots :: Demand -- depending on saturation + -> [OneShotInfo] +argOneShots (JD { ud = usg }) + = case usg of + Use _ arg_usg -> go arg_usg + _ -> [] + where + go (UCall One u) = OneShotLam : go u + go (UCall Many u) = NoOneShotInfo : go u + go _ = [] + +{- Note [Computing one-shot info] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a call + f (\pqr. e1) (\xyz. e2) e3 +where f has usage signature + C1(C(C1(U))) C1(U) U +Then argsOneShots returns a [[OneShotInfo]] of + [[OneShot,NoOneShotInfo,OneShot], [OneShot]] +The occurrence analyser propagates this one-shot infor to the +binders \pqr and \xyz; see Note [Use one-shot information] in OccurAnal. +-} + +-- | Returns true if an application to n args +-- would diverge or throw an exception +-- See Note [Unsaturated applications] +appIsBottom :: StrictSig -> Int -> Bool +appIsBottom (StrictSig (DmdType _ ds res)) n + | isBotRes res = not $ lengthExceeds ds n +appIsBottom _ _ = False + +{- +Note [Unsaturated applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If a function having bottom as its demand result is applied to a less +number of arguments than its syntactic arity, we cannot say for sure +that it is going to diverge. This is the reason why we use the +function appIsBottom, which, given a strictness signature and a number +of arguments, says conservatively if the function is going to diverge +or not. + +Zap absence or one-shot information, under control of flags + +Note [Killing usage information] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The flags -fkill-one-shot and -fkill-absence let you switch off the generation +of absence or one-shot information altogether. This is only used for performance +tests, to see how important they are. +-} + +zapUsageEnvSig :: StrictSig -> StrictSig +-- Remove the usage environment from the demand +zapUsageEnvSig (StrictSig (DmdType _ ds r)) = mkClosedStrictSig ds r + +zapUsageDemand :: Demand -> Demand +-- Remove the usage info, but not the strictness info, from the demand +zapUsageDemand = kill_usage $ KillFlags + { kf_abs = True + , kf_used_once = True + , kf_called_once = True + } + +-- | Remove all 1* information (but not C1 information) from the demand +zapUsedOnceDemand :: Demand -> Demand +zapUsedOnceDemand = kill_usage $ KillFlags + { kf_abs = False + , kf_used_once = True + , kf_called_once = False + } + +-- | Remove all 1* information (but not C1 information) from the strictness +-- signature +zapUsedOnceSig :: StrictSig -> StrictSig +zapUsedOnceSig (StrictSig (DmdType env ds r)) + = StrictSig (DmdType env (map zapUsedOnceDemand ds) r) + +killUsageDemand :: DynFlags -> Demand -> Demand +-- See Note [Killing usage information] +killUsageDemand dflags dmd + | Just kfs <- killFlags dflags = kill_usage kfs dmd + | otherwise = dmd + +killUsageSig :: DynFlags -> StrictSig -> StrictSig +-- See Note [Killing usage information] +killUsageSig dflags sig@(StrictSig (DmdType env ds r)) + | Just kfs <- killFlags dflags = StrictSig (DmdType env (map (kill_usage kfs) ds) r) + | otherwise = sig + +data KillFlags = KillFlags + { kf_abs :: Bool + , kf_used_once :: Bool + , kf_called_once :: Bool + } + +killFlags :: DynFlags -> Maybe KillFlags +-- See Note [Killing usage information] +killFlags dflags + | not kf_abs && not kf_used_once = Nothing + | otherwise = Just (KillFlags {..}) + where + kf_abs = gopt Opt_KillAbsence dflags + kf_used_once = gopt Opt_KillOneShot dflags + kf_called_once = kf_used_once + +kill_usage :: KillFlags -> Demand -> Demand +kill_usage kfs (JD {sd = s, ud = u}) = JD {sd = s, ud = zap_musg kfs u} + +zap_musg :: KillFlags -> ArgUse -> ArgUse +zap_musg kfs Abs + | kf_abs kfs = useTop + | otherwise = Abs +zap_musg kfs (Use c u) + | kf_used_once kfs = Use Many (zap_usg kfs u) + | otherwise = Use c (zap_usg kfs u) + +zap_usg :: KillFlags -> UseDmd -> UseDmd +zap_usg kfs (UCall c u) + | kf_called_once kfs = UCall Many (zap_usg kfs u) + | otherwise = UCall c (zap_usg kfs u) +zap_usg kfs (UProd us) = UProd (map (zap_musg kfs) us) +zap_usg _ u = u + +-- If the argument is a used non-newtype dictionary, give it strict +-- demand. Also split the product type & demand and recur in order to +-- similarly strictify the argument's contained used non-newtype +-- superclass dictionaries. We use the demand as our recursive measure +-- to guarantee termination. +strictifyDictDmd :: Type -> Demand -> Demand +strictifyDictDmd ty dmd = case getUseDmd dmd of + Use n _ | + Just (tycon, _arg_tys, _data_con, inst_con_arg_tys) + <- splitDataProductType_maybe ty, + not (isNewTyCon tycon), isClassTyCon tycon -- is a non-newtype dictionary + -> seqDmd `bothDmd` -- main idea: ensure it's strict + case splitProdDmd_maybe dmd of + -- superclass cycles should not be a problem, since the demand we are + -- consuming would also have to be infinite in order for us to diverge + Nothing -> dmd -- no components have interesting demand, so stop + -- looking for superclass dicts + Just dmds + | all (not . isAbsDmd) dmds -> evalDmd + -- abstract to strict w/ arbitrary component use, since this + -- smells like reboxing; results in CBV boxed + -- + -- TODO revisit this if we ever do boxity analysis + | otherwise -> case mkProdDmd $ zipWith strictifyDictDmd inst_con_arg_tys dmds of + JD {sd = s,ud = a} -> JD (Str s) (Use n a) + -- TODO could optimize with an aborting variant of zipWith since + -- the superclass dicts are always a prefix + _ -> dmd -- unused or not a dictionary + +strictifyDmd :: Demand -> Demand +strictifyDmd dmd@(JD { sd = str }) + = dmd { sd = str `bothArgStr` Str HeadStr } + +{- +Note [HyperStr and Use demands] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The information "HyperStr" needs to be in the strictness signature, and not in +the demand signature, because we still want to know about the demand on things. Consider + + f (x,y) True = error (show x) + f (x,y) False = x+1 + +The signature of f should be m. If we were not +distinguishing the uses on x and y in the True case, we could either not figure +out how deeply we can unpack x, or that we do not have to pass y. + + +************************************************************************ +* * + Serialisation +* * +************************************************************************ +-} + +instance Binary StrDmd where + put_ bh HyperStr = do putByte bh 0 + put_ bh HeadStr = do putByte bh 1 + put_ bh (SCall s) = do putByte bh 2 + put_ bh s + put_ bh (SProd sx) = do putByte bh 3 + put_ bh sx + get bh = do + h <- getByte bh + case h of + 0 -> do return HyperStr + 1 -> do return HeadStr + 2 -> do s <- get bh + return (SCall s) + _ -> do sx <- get bh + return (SProd sx) + +instance Binary ArgStr where + put_ bh Lazy = do + putByte bh 0 + put_ bh (Str s) = do + putByte bh 1 + put_ bh s + + get bh = do + h <- getByte bh + case h of + 0 -> return Lazy + _ -> do s <- get bh + return $ Str s + +instance Binary Count where + put_ bh One = do putByte bh 0 + put_ bh Many = do putByte bh 1 + + get bh = do h <- getByte bh + case h of + 0 -> return One + _ -> return Many + +instance Binary ArgUse where + put_ bh Abs = do + putByte bh 0 + put_ bh (Use c u) = do + putByte bh 1 + put_ bh c + put_ bh u + + get bh = do + h <- getByte bh + case h of + 0 -> return Abs + _ -> do c <- get bh + u <- get bh + return $ Use c u + +instance Binary UseDmd where + put_ bh Used = do + putByte bh 0 + put_ bh UHead = do + putByte bh 1 + put_ bh (UCall c u) = do + putByte bh 2 + put_ bh c + put_ bh u + put_ bh (UProd ux) = do + putByte bh 3 + put_ bh ux + + get bh = do + h <- getByte bh + case h of + 0 -> return $ Used + 1 -> return $ UHead + 2 -> do c <- get bh + u <- get bh + return (UCall c u) + _ -> do ux <- get bh + return (UProd ux) + +instance (Binary s, Binary u) => Binary (JointDmd s u) where + put_ bh (JD { sd = x, ud = y }) = do put_ bh x; put_ bh y + get bh = do + x <- get bh + y <- get bh + return $ JD { sd = x, ud = y } + +instance Binary StrictSig where + put_ bh (StrictSig aa) = do + put_ bh aa + get bh = do + aa <- get bh + return (StrictSig aa) + +instance Binary DmdType where + -- Ignore DmdEnv when spitting out the DmdType + put_ bh (DmdType _ ds dr) + = do put_ bh ds + put_ bh dr + get bh + = do ds <- get bh + dr <- get bh + return (DmdType emptyDmdEnv ds dr) + +instance Binary DmdResult where + put_ bh (Dunno c) = do { putByte bh 0; put_ bh c } + put_ bh Diverges = putByte bh 1 + + get bh = do { h <- getByte bh + ; case h of + 0 -> do { c <- get bh; return (Dunno c) } + _ -> return Diverges } + +instance Binary CPRResult where + put_ bh (RetSum n) = do { putByte bh 0; put_ bh n } + put_ bh RetProd = putByte bh 1 + put_ bh NoCPR = putByte bh 2 + + get bh = do + h <- getByte bh + case h of + 0 -> do { n <- get bh; return (RetSum n) } + 1 -> return RetProd + _ -> return NoCPR diff --git a/compiler/basicTypes/FieldLabel.hs b/compiler/basicTypes/FieldLabel.hs new file mode 100644 --- /dev/null +++ b/compiler/basicTypes/FieldLabel.hs @@ -0,0 +1,130 @@ +{- +% +% (c) Adam Gundry 2013-2015 +% + +This module defines the representation of FieldLabels as stored in +TyCons. As well as a selector name, these have some extra structure +to support the DuplicateRecordFields extension. + +In the normal case (with NoDuplicateRecordFields), a datatype like + + data T = MkT { foo :: Int } + +has + + FieldLabel { flLabel = "foo" + , flIsOverloaded = False + , flSelector = foo }. + +In particular, the Name of the selector has the same string +representation as the label. If DuplicateRecordFields +is enabled, however, the same declaration instead gives + + FieldLabel { flLabel = "foo" + , flIsOverloaded = True + , flSelector = $sel:foo:MkT }. + +Now the name of the selector ($sel:foo:MkT) does not match the label of +the field (foo). We must be careful not to show the selector name to +the user! The point of mangling the selector name is to allow a +module to define the same field label in different datatypes: + + data T = MkT { foo :: Int } + data U = MkU { foo :: Bool } + +Now there will be two FieldLabel values for 'foo', one in T and one in +U. They share the same label (FieldLabelString), but the selector +functions differ. + +See also Note [Representing fields in AvailInfo] in Avail. + +Note [Why selector names include data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +As explained above, a selector name includes the name of the first +data constructor in the type, so that the same label can appear +multiple times in the same module. (This is irrespective of whether +the first constructor has that field, for simplicity.) + +We use a data constructor name, rather than the type constructor name, +because data family instances do not have a representation type +constructor name generated until relatively late in the typechecking +process. + +Of course, datatypes with no constructors cannot have any fields. + +-} + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE StandaloneDeriving #-} + +module FieldLabel ( FieldLabelString + , FieldLabelEnv + , FieldLbl(..) + , FieldLabel + , mkFieldLabelOccs + ) where + +import GhcPrelude + +import OccName +import Name + +import FastString +import FastStringEnv +import Outputable +import Binary + +import Data.Data + +-- | Field labels are just represented as strings; +-- they are not necessarily unique (even within a module) +type FieldLabelString = FastString + +-- | A map from labels to all the auxiliary information +type FieldLabelEnv = DFastStringEnv FieldLabel + + +type FieldLabel = FieldLbl Name + +-- | Fields in an algebraic record type +data FieldLbl a = FieldLabel { + flLabel :: FieldLabelString, -- ^ User-visible label of the field + flIsOverloaded :: Bool, -- ^ Was DuplicateRecordFields on + -- in the defining module for this datatype? + flSelector :: a -- ^ Record selector function + } + deriving (Eq, Functor, Foldable, Traversable) +deriving instance Data a => Data (FieldLbl a) + +instance Outputable a => Outputable (FieldLbl a) where + ppr fl = ppr (flLabel fl) <> braces (ppr (flSelector fl)) + +instance Binary a => Binary (FieldLbl a) where + put_ bh (FieldLabel aa ab ac) = do + put_ bh aa + put_ bh ab + put_ bh ac + get bh = do + ab <- get bh + ac <- get bh + ad <- get bh + return (FieldLabel ab ac ad) + + +-- | Record selector OccNames are built from the underlying field name +-- and the name of the first data constructor of the type, to support +-- duplicate record field names. +-- See Note [Why selector names include data constructors]. +mkFieldLabelOccs :: FieldLabelString -> OccName -> Bool -> FieldLbl OccName +mkFieldLabelOccs lbl dc is_overloaded + = FieldLabel { flLabel = lbl, flIsOverloaded = is_overloaded + , flSelector = sel_occ } + where + str = ":" ++ unpackFS lbl ++ ":" ++ occNameString dc + sel_occ | is_overloaded = mkRecFldSelOcc str + | otherwise = mkVarOccFS lbl diff --git a/compiler/basicTypes/Id.hs b/compiler/basicTypes/Id.hs new file mode 100644 --- /dev/null +++ b/compiler/basicTypes/Id.hs @@ -0,0 +1,987 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[Id]{@Ids@: Value and constructor identifiers} +-} + +{-# LANGUAGE CPP #-} + +-- | +-- #name_types# +-- GHC uses several kinds of name internally: +-- +-- * 'OccName.OccName': see "OccName#name_types" +-- +-- * 'RdrName.RdrName': see "RdrName#name_types" +-- +-- * 'Name.Name': see "Name#name_types" +-- +-- * 'Id.Id' represents names that not only have a 'Name.Name' but also a 'TyCoRep.Type' and some additional +-- details (a 'IdInfo.IdInfo' and one of 'Var.LocalIdDetails' or 'IdInfo.GlobalIdDetails') that +-- are added, modified and inspected by various compiler passes. These 'Var.Var' names may either +-- be global or local, see "Var#globalvslocal" +-- +-- * 'Var.Var': see "Var#name_types" + +module Id ( + -- * The main types + Var, Id, isId, + + -- * In and Out variants + InVar, InId, + OutVar, OutId, + + -- ** Simple construction + mkGlobalId, mkVanillaGlobal, mkVanillaGlobalWithInfo, + mkLocalId, mkLocalCoVar, mkLocalIdOrCoVar, + mkLocalIdOrCoVarWithInfo, + mkLocalIdWithInfo, mkExportedLocalId, mkExportedVanillaId, + mkSysLocal, mkSysLocalM, mkSysLocalOrCoVar, mkSysLocalOrCoVarM, + mkUserLocal, mkUserLocalOrCoVar, + mkTemplateLocals, mkTemplateLocalsNum, mkTemplateLocal, + mkWorkerId, + + -- ** Taking an Id apart + idName, idType, idUnique, idInfo, idDetails, + recordSelectorTyCon, + + -- ** Modifying an Id + setIdName, setIdUnique, Id.setIdType, + setIdExported, setIdNotExported, + globaliseId, localiseId, + setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo, + zapLamIdInfo, zapIdDemandInfo, zapIdUsageInfo, zapIdUsageEnvInfo, + zapIdUsedOnceInfo, zapIdTailCallInfo, + zapFragileIdInfo, zapIdStrictness, zapStableUnfolding, + transferPolyIdInfo, + + -- ** Predicates on Ids + isImplicitId, isDeadBinder, + isStrictId, + isExportedId, isLocalId, isGlobalId, + isRecordSelector, isNaughtyRecordSelector, + isPatSynRecordSelector, + isDataConRecordSelector, + isClassOpId_maybe, isDFunId, + isPrimOpId, isPrimOpId_maybe, + isFCallId, isFCallId_maybe, + isDataConWorkId, isDataConWorkId_maybe, + isDataConWrapId, isDataConWrapId_maybe, + isDataConId_maybe, + idDataCon, + isConLikeId, isBottomingId, idIsFrom, + hasNoBinding, + + -- ** Evidence variables + DictId, isDictId, isEvVar, + + -- ** Join variables + JoinId, isJoinId, isJoinId_maybe, idJoinArity, + asJoinId, asJoinId_maybe, zapJoinId, + + -- ** Inline pragma stuff + idInlinePragma, setInlinePragma, modifyInlinePragma, + idInlineActivation, setInlineActivation, idRuleMatchInfo, + + -- ** One-shot lambdas + isOneShotBndr, isProbablyOneShotLambda, + setOneShotLambda, clearOneShotLambda, + updOneShotInfo, setIdOneShotInfo, + isStateHackType, stateHackOneShot, typeOneShot, + + -- ** Reading 'IdInfo' fields + idArity, + idCallArity, idFunRepArity, + idUnfolding, realIdUnfolding, + idSpecialisation, idCoreRules, idHasRules, + idCafInfo, + idOneShotInfo, idStateHackOneShotInfo, + idOccInfo, + isNeverLevPolyId, + + -- ** Writing 'IdInfo' fields + setIdUnfolding, setCaseBndrEvald, + setIdArity, + setIdCallArity, + + setIdSpecialisation, + setIdCafInfo, + setIdOccInfo, zapIdOccInfo, + + setIdDemandInfo, + setIdStrictness, + + idDemandInfo, + idStrictness, + + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import DynFlags +import CoreSyn ( CoreRule, isStableUnfolding, evaldUnfolding, + isCompulsoryUnfolding, Unfolding( NoUnfolding ) ) + +import IdInfo +import BasicTypes + +-- Imported and re-exported +import Var( Id, CoVar, DictId, JoinId, + InId, InVar, + OutId, OutVar, + idInfo, idDetails, setIdDetails, globaliseId, varType, + isId, isLocalId, isGlobalId, isExportedId ) +import qualified Var + +import Type +import RepType +import TysPrim +import DataCon +import Demand +import Name +import Module +import Class +import {-# SOURCE #-} PrimOp (PrimOp) +import ForeignCall +import Maybes +import SrcLoc +import Outputable +import Unique +import UniqSupply +import FastString +import Util + +-- infixl so you can say (id `set` a `set` b) +infixl 1 `setIdUnfolding`, + `setIdArity`, + `setIdCallArity`, + `setIdOccInfo`, + `setIdOneShotInfo`, + + `setIdSpecialisation`, + `setInlinePragma`, + `setInlineActivation`, + `idCafInfo`, + + `setIdDemandInfo`, + `setIdStrictness`, + + `asJoinId`, + `asJoinId_maybe` + +{- +************************************************************************ +* * +\subsection{Basic Id manipulation} +* * +************************************************************************ +-} + +idName :: Id -> Name +idName = Var.varName + +idUnique :: Id -> Unique +idUnique = Var.varUnique + +idType :: Id -> Kind +idType = Var.varType + +setIdName :: Id -> Name -> Id +setIdName = Var.setVarName + +setIdUnique :: Id -> Unique -> Id +setIdUnique = Var.setVarUnique + +-- | Not only does this set the 'Id' 'Type', it also evaluates the type to try and +-- reduce space usage +setIdType :: Id -> Type -> Id +setIdType id ty = seqType ty `seq` Var.setVarType id ty + +setIdExported :: Id -> Id +setIdExported = Var.setIdExported + +setIdNotExported :: Id -> Id +setIdNotExported = Var.setIdNotExported + +localiseId :: Id -> Id +-- Make an Id with the same unique and type as the +-- incoming Id, but with an *Internal* Name and *LocalId* flavour +localiseId id + | ASSERT( isId id ) isLocalId id && isInternalName name + = id + | otherwise + = Var.mkLocalVar (idDetails id) (localiseName name) (idType id) (idInfo id) + where + name = idName id + +lazySetIdInfo :: Id -> IdInfo -> Id +lazySetIdInfo = Var.lazySetIdInfo + +setIdInfo :: Id -> IdInfo -> Id +setIdInfo id info = info `seq` (lazySetIdInfo id info) + -- Try to avoid space leaks by seq'ing + +modifyIdInfo :: HasDebugCallStack => (IdInfo -> IdInfo) -> Id -> Id +modifyIdInfo fn id = setIdInfo id (fn (idInfo id)) + +-- maybeModifyIdInfo tries to avoid unnecessary thrashing +maybeModifyIdInfo :: Maybe IdInfo -> Id -> Id +maybeModifyIdInfo (Just new_info) id = lazySetIdInfo id new_info +maybeModifyIdInfo Nothing id = id + +{- +************************************************************************ +* * +\subsection{Simple Id construction} +* * +************************************************************************ + +Absolutely all Ids are made by mkId. It is just like Var.mkId, +but in addition it pins free-tyvar-info onto the Id's type, +where it can easily be found. + +Note [Free type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +At one time we cached the free type variables of the type of an Id +at the root of the type in a TyNote. The idea was to avoid repeating +the free-type-variable calculation. But it turned out to slow down +the compiler overall. I don't quite know why; perhaps finding free +type variables of an Id isn't all that common whereas applying a +substitution (which changes the free type variables) is more common. +Anyway, we removed it in March 2008. +-} + +-- | For an explanation of global vs. local 'Id's, see "Var#globalvslocal" +mkGlobalId :: IdDetails -> Name -> Type -> IdInfo -> Id +mkGlobalId = Var.mkGlobalVar + +-- | Make a global 'Id' without any extra information at all +mkVanillaGlobal :: Name -> Type -> Id +mkVanillaGlobal name ty = mkVanillaGlobalWithInfo name ty vanillaIdInfo + +-- | Make a global 'Id' with no global information but some generic 'IdInfo' +mkVanillaGlobalWithInfo :: Name -> Type -> IdInfo -> Id +mkVanillaGlobalWithInfo = mkGlobalId VanillaId + + +-- | For an explanation of global vs. local 'Id's, see "Var#globalvslocal" +mkLocalId :: Name -> Type -> Id +mkLocalId name ty = mkLocalIdWithInfo name ty vanillaIdInfo + -- It's tempting to ASSERT( not (isCoVarType ty) ), but don't. Sometimes, + -- the type is a panic. (Search invented_id) + +-- | Make a local CoVar +mkLocalCoVar :: Name -> Type -> CoVar +mkLocalCoVar name ty + = ASSERT( isCoVarType ty ) + Var.mkLocalVar CoVarId name ty vanillaIdInfo + +-- | Like 'mkLocalId', but checks the type to see if it should make a covar +mkLocalIdOrCoVar :: Name -> Type -> Id +mkLocalIdOrCoVar name ty + | isCoVarType ty = mkLocalCoVar name ty + | otherwise = mkLocalId name ty + +-- | Make a local id, with the IdDetails set to CoVarId if the type indicates +-- so. +mkLocalIdOrCoVarWithInfo :: Name -> Type -> IdInfo -> Id +mkLocalIdOrCoVarWithInfo name ty info + = Var.mkLocalVar details name ty info + where + details | isCoVarType ty = CoVarId + | otherwise = VanillaId + + -- proper ids only; no covars! +mkLocalIdWithInfo :: Name -> Type -> IdInfo -> Id +mkLocalIdWithInfo name ty info = Var.mkLocalVar VanillaId name ty info + -- Note [Free type variables] + +-- | Create a local 'Id' that is marked as exported. +-- This prevents things attached to it from being removed as dead code. +-- See Note [Exported LocalIds] +mkExportedLocalId :: IdDetails -> Name -> Type -> Id +mkExportedLocalId details name ty = Var.mkExportedLocalVar details name ty vanillaIdInfo + -- Note [Free type variables] + +mkExportedVanillaId :: Name -> Type -> Id +mkExportedVanillaId name ty = Var.mkExportedLocalVar VanillaId name ty vanillaIdInfo + -- Note [Free type variables] + + +-- | Create a system local 'Id'. These are local 'Id's (see "Var#globalvslocal") +-- that are created by the compiler out of thin air +mkSysLocal :: FastString -> Unique -> Type -> Id +mkSysLocal fs uniq ty = ASSERT( not (isCoVarType ty) ) + mkLocalId (mkSystemVarName uniq fs) ty + +-- | Like 'mkSysLocal', but checks to see if we have a covar type +mkSysLocalOrCoVar :: FastString -> Unique -> Type -> Id +mkSysLocalOrCoVar fs uniq ty + = mkLocalIdOrCoVar (mkSystemVarName uniq fs) ty + +mkSysLocalM :: MonadUnique m => FastString -> Type -> m Id +mkSysLocalM fs ty = getUniqueM >>= (\uniq -> return (mkSysLocal fs uniq ty)) + +mkSysLocalOrCoVarM :: MonadUnique m => FastString -> Type -> m Id +mkSysLocalOrCoVarM fs ty + = getUniqueM >>= (\uniq -> return (mkSysLocalOrCoVar fs uniq ty)) + +-- | Create a user local 'Id'. These are local 'Id's (see "Var#globalvslocal") with a name and location that the user might recognize +mkUserLocal :: OccName -> Unique -> Type -> SrcSpan -> Id +mkUserLocal occ uniq ty loc = ASSERT( not (isCoVarType ty) ) + mkLocalId (mkInternalName uniq occ loc) ty + +-- | Like 'mkUserLocal', but checks if we have a coercion type +mkUserLocalOrCoVar :: OccName -> Unique -> Type -> SrcSpan -> Id +mkUserLocalOrCoVar occ uniq ty loc + = mkLocalIdOrCoVar (mkInternalName uniq occ loc) ty + +{- +Make some local @Ids@ for a template @CoreExpr@. These have bogus +@Uniques@, but that's OK because the templates are supposed to be +instantiated before use. +-} + +-- | Workers get local names. "CoreTidy" will externalise these if necessary +mkWorkerId :: Unique -> Id -> Type -> Id +mkWorkerId uniq unwrkr ty + = mkLocalIdOrCoVar (mkDerivedInternalName mkWorkerOcc uniq (getName unwrkr)) ty + +-- | Create a /template local/: a family of system local 'Id's in bijection with @Int@s, typically used in unfoldings +mkTemplateLocal :: Int -> Type -> Id +mkTemplateLocal i ty = mkSysLocalOrCoVar (fsLit "v") (mkBuiltinUnique i) ty + +-- | Create a template local for a series of types +mkTemplateLocals :: [Type] -> [Id] +mkTemplateLocals = mkTemplateLocalsNum 1 + +-- | Create a template local for a series of type, but start from a specified template local +mkTemplateLocalsNum :: Int -> [Type] -> [Id] +mkTemplateLocalsNum n tys = zipWith mkTemplateLocal [n..] tys + +{- Note [Exported LocalIds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We use mkExportedLocalId for things like + - Dictionary functions (DFunId) + - Wrapper and matcher Ids for pattern synonyms + - Default methods for classes + - Pattern-synonym matcher and builder Ids + - etc + +They marked as "exported" in the sense that they should be kept alive +even if apparently unused in other bindings, and not dropped as dead +code by the occurrence analyser. (But "exported" here does not mean +"brought into lexical scope by an import declaration". Indeed these +things are always internal Ids that the user never sees.) + +It's very important that they are *LocalIds*, not GlobalIds, for lots +of reasons: + + * We want to treat them as free variables for the purpose of + dependency analysis (e.g. CoreFVs.exprFreeVars). + + * Look them up in the current substitution when we come across + occurrences of them (in Subst.lookupIdSubst). Lacking this we + can get an out-of-date unfolding, which can in turn make the + simplifier go into an infinite loop (#9857) + + * Ensure that for dfuns that the specialiser does not float dict uses + above their defns, which would prevent good simplifications happening. + + * The strictness analyser treats a occurrence of a GlobalId as + imported and assumes it contains strictness in its IdInfo, which + isn't true if the thing is bound in the same module as the + occurrence. + +In CoreTidy we must make all these LocalIds into GlobalIds, so that in +importing modules (in --make mode) we treat them as properly global. +That is what is happening in, say tidy_insts in TidyPgm. + +************************************************************************ +* * +\subsection{Special Ids} +* * +************************************************************************ +-} + +-- | If the 'Id' is that for a record selector, extract the 'sel_tycon'. Panic otherwise. +recordSelectorTyCon :: Id -> RecSelParent +recordSelectorTyCon id + = case Var.idDetails id of + RecSelId { sel_tycon = parent } -> parent + _ -> panic "recordSelectorTyCon" + + +isRecordSelector :: Id -> Bool +isNaughtyRecordSelector :: Id -> Bool +isPatSynRecordSelector :: Id -> Bool +isDataConRecordSelector :: Id -> Bool +isPrimOpId :: Id -> Bool +isFCallId :: Id -> Bool +isDataConWorkId :: Id -> Bool +isDataConWrapId :: Id -> Bool +isDFunId :: Id -> Bool + +isClassOpId_maybe :: Id -> Maybe Class +isPrimOpId_maybe :: Id -> Maybe PrimOp +isFCallId_maybe :: Id -> Maybe ForeignCall +isDataConWorkId_maybe :: Id -> Maybe DataCon +isDataConWrapId_maybe :: Id -> Maybe DataCon + +isRecordSelector id = case Var.idDetails id of + RecSelId {} -> True + _ -> False + +isDataConRecordSelector id = case Var.idDetails id of + RecSelId {sel_tycon = RecSelData _} -> True + _ -> False + +isPatSynRecordSelector id = case Var.idDetails id of + RecSelId {sel_tycon = RecSelPatSyn _} -> True + _ -> False + +isNaughtyRecordSelector id = case Var.idDetails id of + RecSelId { sel_naughty = n } -> n + _ -> False + +isClassOpId_maybe id = case Var.idDetails id of + ClassOpId cls -> Just cls + _other -> Nothing + +isPrimOpId id = case Var.idDetails id of + PrimOpId _ -> True + _ -> False + +isDFunId id = case Var.idDetails id of + DFunId {} -> True + _ -> False + +isPrimOpId_maybe id = case Var.idDetails id of + PrimOpId op -> Just op + _ -> Nothing + +isFCallId id = case Var.idDetails id of + FCallId _ -> True + _ -> False + +isFCallId_maybe id = case Var.idDetails id of + FCallId call -> Just call + _ -> Nothing + +isDataConWorkId id = case Var.idDetails id of + DataConWorkId _ -> True + _ -> False + +isDataConWorkId_maybe id = case Var.idDetails id of + DataConWorkId con -> Just con + _ -> Nothing + +isDataConWrapId id = case Var.idDetails id of + DataConWrapId _ -> True + _ -> False + +isDataConWrapId_maybe id = case Var.idDetails id of + DataConWrapId con -> Just con + _ -> Nothing + +isDataConId_maybe :: Id -> Maybe DataCon +isDataConId_maybe id = case Var.idDetails id of + DataConWorkId con -> Just con + DataConWrapId con -> Just con + _ -> Nothing + +isJoinId :: Var -> Bool +-- It is convenient in SetLevels.lvlMFE to apply isJoinId +-- to the free vars of an expression, so it's convenient +-- if it returns False for type variables +isJoinId id + | isId id = case Var.idDetails id of + JoinId {} -> True + _ -> False + | otherwise = False + +isJoinId_maybe :: Var -> Maybe JoinArity +isJoinId_maybe id + | isId id = ASSERT2( isId id, ppr id ) + case Var.idDetails id of + JoinId arity -> Just arity + _ -> Nothing + | otherwise = Nothing + +idDataCon :: Id -> DataCon +-- ^ Get from either the worker or the wrapper 'Id' to the 'DataCon'. Currently used only in the desugarer. +-- +-- INVARIANT: @idDataCon (dataConWrapId d) = d@: remember, 'dataConWrapId' can return either the wrapper or the worker +idDataCon id = isDataConId_maybe id `orElse` pprPanic "idDataCon" (ppr id) + +hasNoBinding :: Id -> Bool +-- ^ Returns @True@ of an 'Id' which may not have a +-- binding, even though it is defined in this module. + +-- Data constructor workers used to be things of this kind, but +-- they aren't any more. Instead, we inject a binding for +-- them at the CorePrep stage. +-- EXCEPT: unboxed tuples, which definitely have no binding +hasNoBinding id = case Var.idDetails id of + PrimOpId _ -> True -- See Note [Primop wrappers] + FCallId _ -> True + DataConWorkId dc -> isUnboxedTupleCon dc || isUnboxedSumCon dc + _ -> isCompulsoryUnfolding (idUnfolding id) + -- See Note [Levity-polymorphic Ids] + +isImplicitId :: Id -> Bool +-- ^ 'isImplicitId' tells whether an 'Id's info is implied by other +-- declarations, so we don't need to put its signature in an interface +-- file, even if it's mentioned in some other interface unfolding. +isImplicitId id + = case Var.idDetails id of + FCallId {} -> True + ClassOpId {} -> True + PrimOpId {} -> True + DataConWorkId {} -> True + DataConWrapId {} -> True + -- These are implied by their type or class decl; + -- remember that all type and class decls appear in the interface file. + -- The dfun id is not an implicit Id; it must *not* be omitted, because + -- it carries version info for the instance decl + _ -> False + +idIsFrom :: Module -> Id -> Bool +idIsFrom mod id = nameIsLocalOrFrom mod (idName id) + +{- Note [Levity-polymorphic Ids] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Some levity-polymorphic Ids must be applied and and inlined, not left +un-saturated. Example: + unsafeCoerceId :: forall r1 r2 (a::TYPE r1) (b::TYPE r2). a -> b + +This has a compulsory unfolding because we can't lambda-bind those +arguments. But the compulsory unfolding may leave levity-polymorphic +lambdas if it is not applied to enough arguments; e.g. (#14561) + bad :: forall (a :: TYPE r). a -> a + bad = unsafeCoerce# + +The desugar has special magic to detect such cases: DsExpr.badUseOfLevPolyPrimop. +And we want that magic to apply to levity-polymorphic compulsory-inline things. +The easiest way to do this is for hasNoBinding to return True of all things +that have compulsory unfolding. A very Ids with a compulsory unfolding also +have a binding, but it does not harm to say they don't here, and its a very +simple way to fix #14561. + +Note [Primop wrappers] +~~~~~~~~~~~~~~~~~~~~~~ +Currently hasNoBinding claims that PrimOpIds don't have a curried +function definition. But actually they do, in GHC.PrimopWrappers, +which is auto-generated from prelude/primops.txt.pp. So actually, hasNoBinding +could return 'False' for PrimOpIds. + +But we'd need to add something in CoreToStg to swizzle any unsaturated +applications of GHC.Prim.plusInt# to GHC.PrimopWrappers.plusInt#. + +Nota Bene: GHC.PrimopWrappers is needed *regardless*, because it's +used by GHCi, which does not implement primops direct at all. +-} + +isDeadBinder :: Id -> Bool +isDeadBinder bndr | isId bndr = isDeadOcc (idOccInfo bndr) + | otherwise = False -- TyVars count as not dead + +{- +************************************************************************ +* * + Evidence variables +* * +************************************************************************ +-} + +isEvVar :: Var -> Bool +isEvVar var = isEvVarType (varType var) + +isDictId :: Id -> Bool +isDictId id = isDictTy (idType id) + +{- +************************************************************************ +* * + Join variables +* * +************************************************************************ +-} + +idJoinArity :: JoinId -> JoinArity +idJoinArity id = isJoinId_maybe id `orElse` pprPanic "idJoinArity" (ppr id) + +asJoinId :: Id -> JoinArity -> JoinId +asJoinId id arity = WARN(not (isLocalId id), + text "global id being marked as join var:" <+> ppr id) + WARN(not (is_vanilla_or_join id), + ppr id <+> pprIdDetails (idDetails id)) + id `setIdDetails` JoinId arity + where + is_vanilla_or_join id = case Var.idDetails id of + VanillaId -> True + JoinId {} -> True + _ -> False + +zapJoinId :: Id -> Id +-- May be a regular id already +zapJoinId jid | isJoinId jid = zapIdTailCallInfo (jid `setIdDetails` VanillaId) + -- Core Lint may complain if still marked + -- as AlwaysTailCalled + | otherwise = jid + +asJoinId_maybe :: Id -> Maybe JoinArity -> Id +asJoinId_maybe id (Just arity) = asJoinId id arity +asJoinId_maybe id Nothing = zapJoinId id + +{- +************************************************************************ +* * +\subsection{IdInfo stuff} +* * +************************************************************************ +-} + + --------------------------------- + -- ARITY +idArity :: Id -> Arity +idArity id = arityInfo (idInfo id) + +setIdArity :: Id -> Arity -> Id +setIdArity id arity = modifyIdInfo (`setArityInfo` arity) id + +idCallArity :: Id -> Arity +idCallArity id = callArityInfo (idInfo id) + +setIdCallArity :: Id -> Arity -> Id +setIdCallArity id arity = modifyIdInfo (`setCallArityInfo` arity) id + +idFunRepArity :: Id -> RepArity +idFunRepArity x = countFunRepArgs (idArity x) (idType x) + +-- | Returns true if an application to n args would diverge +isBottomingId :: Var -> Bool +isBottomingId v + | isId v = isBottomingSig (idStrictness v) + | otherwise = False + +idStrictness :: Id -> StrictSig +idStrictness id = strictnessInfo (idInfo id) + +setIdStrictness :: Id -> StrictSig -> Id +setIdStrictness id sig = modifyIdInfo (`setStrictnessInfo` sig) id + +zapIdStrictness :: Id -> Id +zapIdStrictness id = modifyIdInfo (`setStrictnessInfo` nopSig) id + +-- | This predicate says whether the 'Id' has a strict demand placed on it or +-- has a type such that it can always be evaluated strictly (i.e an +-- unlifted type, as of GHC 7.6). We need to +-- check separately whether the 'Id' has a so-called \"strict type\" because if +-- the demand for the given @id@ hasn't been computed yet but @id@ has a strict +-- type, we still want @isStrictId id@ to be @True@. +isStrictId :: Id -> Bool +isStrictId id + = ASSERT2( isId id, text "isStrictId: not an id: " <+> ppr id ) + not (isJoinId id) && ( + (isStrictType (idType id)) || + -- Take the best of both strictnesses - old and new + (isStrictDmd (idDemandInfo id)) + ) + + --------------------------------- + -- UNFOLDING +idUnfolding :: Id -> Unfolding +-- Do not expose the unfolding of a loop breaker! +idUnfolding id + | isStrongLoopBreaker (occInfo info) = NoUnfolding + | otherwise = unfoldingInfo info + where + info = idInfo id + +realIdUnfolding :: Id -> Unfolding +-- Expose the unfolding if there is one, including for loop breakers +realIdUnfolding id = unfoldingInfo (idInfo id) + +setIdUnfolding :: Id -> Unfolding -> Id +setIdUnfolding id unfolding = modifyIdInfo (`setUnfoldingInfo` unfolding) id + +idDemandInfo :: Id -> Demand +idDemandInfo id = demandInfo (idInfo id) + +setIdDemandInfo :: Id -> Demand -> Id +setIdDemandInfo id dmd = modifyIdInfo (`setDemandInfo` dmd) id + +setCaseBndrEvald :: StrictnessMark -> Id -> Id +-- Used for variables bound by a case expressions, both the case-binder +-- itself, and any pattern-bound variables that are argument of a +-- strict constructor. It just marks the variable as already-evaluated, +-- so that (for example) a subsequent 'seq' can be dropped +setCaseBndrEvald str id + | isMarkedStrict str = id `setIdUnfolding` evaldUnfolding + | otherwise = id + + --------------------------------- + -- SPECIALISATION + +-- See Note [Specialisations and RULES in IdInfo] in IdInfo.hs + +idSpecialisation :: Id -> RuleInfo +idSpecialisation id = ruleInfo (idInfo id) + +idCoreRules :: Id -> [CoreRule] +idCoreRules id = ruleInfoRules (idSpecialisation id) + +idHasRules :: Id -> Bool +idHasRules id = not (isEmptyRuleInfo (idSpecialisation id)) + +setIdSpecialisation :: Id -> RuleInfo -> Id +setIdSpecialisation id spec_info = modifyIdInfo (`setRuleInfo` spec_info) id + + --------------------------------- + -- CAF INFO +idCafInfo :: Id -> CafInfo +idCafInfo id = cafInfo (idInfo id) + +setIdCafInfo :: Id -> CafInfo -> Id +setIdCafInfo id caf_info = modifyIdInfo (`setCafInfo` caf_info) id + + --------------------------------- + -- Occurrence INFO +idOccInfo :: Id -> OccInfo +idOccInfo id = occInfo (idInfo id) + +setIdOccInfo :: Id -> OccInfo -> Id +setIdOccInfo id occ_info = modifyIdInfo (`setOccInfo` occ_info) id + +zapIdOccInfo :: Id -> Id +zapIdOccInfo b = b `setIdOccInfo` noOccInfo + +{- + --------------------------------- + -- INLINING +The inline pragma tells us to be very keen to inline this Id, but it's still +OK not to if optimisation is switched off. +-} + +idInlinePragma :: Id -> InlinePragma +idInlinePragma id = inlinePragInfo (idInfo id) + +setInlinePragma :: Id -> InlinePragma -> Id +setInlinePragma id prag = modifyIdInfo (`setInlinePragInfo` prag) id + +modifyInlinePragma :: Id -> (InlinePragma -> InlinePragma) -> Id +modifyInlinePragma id fn = modifyIdInfo (\info -> info `setInlinePragInfo` (fn (inlinePragInfo info))) id + +idInlineActivation :: Id -> Activation +idInlineActivation id = inlinePragmaActivation (idInlinePragma id) + +setInlineActivation :: Id -> Activation -> Id +setInlineActivation id act = modifyInlinePragma id (\prag -> setInlinePragmaActivation prag act) + +idRuleMatchInfo :: Id -> RuleMatchInfo +idRuleMatchInfo id = inlinePragmaRuleMatchInfo (idInlinePragma id) + +isConLikeId :: Id -> Bool +isConLikeId id = isDataConWorkId id || isConLike (idRuleMatchInfo id) + +{- + --------------------------------- + -- ONE-SHOT LAMBDAS +-} + +idOneShotInfo :: Id -> OneShotInfo +idOneShotInfo id = oneShotInfo (idInfo id) + +-- | Like 'idOneShotInfo', but taking the Horrible State Hack in to account +-- See Note [The state-transformer hack] in CoreArity +idStateHackOneShotInfo :: Id -> OneShotInfo +idStateHackOneShotInfo id + | isStateHackType (idType id) = stateHackOneShot + | otherwise = idOneShotInfo id + +-- | Returns whether the lambda associated with the 'Id' is certainly applied at most once +-- This one is the "business end", called externally. +-- It works on type variables as well as Ids, returning True +-- Its main purpose is to encapsulate the Horrible State Hack +-- See Note [The state-transformer hack] in CoreArity +isOneShotBndr :: Var -> Bool +isOneShotBndr var + | isTyVar var = True + | OneShotLam <- idStateHackOneShotInfo var = True + | otherwise = False + +-- | Should we apply the state hack to values of this 'Type'? +stateHackOneShot :: OneShotInfo +stateHackOneShot = OneShotLam + +typeOneShot :: Type -> OneShotInfo +typeOneShot ty + | isStateHackType ty = stateHackOneShot + | otherwise = NoOneShotInfo + +isStateHackType :: Type -> Bool +isStateHackType ty + | hasNoStateHack unsafeGlobalDynFlags + = False + | otherwise + = case tyConAppTyCon_maybe ty of + Just tycon -> tycon == statePrimTyCon + _ -> False + -- This is a gross hack. It claims that + -- every function over realWorldStatePrimTy is a one-shot + -- function. This is pretty true in practice, and makes a big + -- difference. For example, consider + -- a `thenST` \ r -> ...E... + -- The early full laziness pass, if it doesn't know that r is one-shot + -- will pull out E (let's say it doesn't mention r) to give + -- let lvl = E in a `thenST` \ r -> ...lvl... + -- When `thenST` gets inlined, we end up with + -- let lvl = E in \s -> case a s of (r, s') -> ...lvl... + -- and we don't re-inline E. + -- + -- It would be better to spot that r was one-shot to start with, but + -- I don't want to rely on that. + -- + -- Another good example is in fill_in in PrelPack.hs. We should be able to + -- spot that fill_in has arity 2 (and when Keith is done, we will) but we can't yet. + +isProbablyOneShotLambda :: Id -> Bool +isProbablyOneShotLambda id = case idStateHackOneShotInfo id of + OneShotLam -> True + NoOneShotInfo -> False + +setOneShotLambda :: Id -> Id +setOneShotLambda id = modifyIdInfo (`setOneShotInfo` OneShotLam) id + +clearOneShotLambda :: Id -> Id +clearOneShotLambda id = modifyIdInfo (`setOneShotInfo` NoOneShotInfo) id + +setIdOneShotInfo :: Id -> OneShotInfo -> Id +setIdOneShotInfo id one_shot = modifyIdInfo (`setOneShotInfo` one_shot) id + +updOneShotInfo :: Id -> OneShotInfo -> Id +-- Combine the info in the Id with new info +updOneShotInfo id one_shot + | do_upd = setIdOneShotInfo id one_shot + | otherwise = id + where + do_upd = case (idOneShotInfo id, one_shot) of + (NoOneShotInfo, _) -> True + (OneShotLam, _) -> False + +-- The OneShotLambda functions simply fiddle with the IdInfo flag +-- But watch out: this may change the type of something else +-- f = \x -> e +-- If we change the one-shot-ness of x, f's type changes + +zapInfo :: (IdInfo -> Maybe IdInfo) -> Id -> Id +zapInfo zapper id = maybeModifyIdInfo (zapper (idInfo id)) id + +zapLamIdInfo :: Id -> Id +zapLamIdInfo = zapInfo zapLamInfo + +zapFragileIdInfo :: Id -> Id +zapFragileIdInfo = zapInfo zapFragileInfo + +zapIdDemandInfo :: Id -> Id +zapIdDemandInfo = zapInfo zapDemandInfo + +zapIdUsageInfo :: Id -> Id +zapIdUsageInfo = zapInfo zapUsageInfo + +zapIdUsageEnvInfo :: Id -> Id +zapIdUsageEnvInfo = zapInfo zapUsageEnvInfo + +zapIdUsedOnceInfo :: Id -> Id +zapIdUsedOnceInfo = zapInfo zapUsedOnceInfo + +zapIdTailCallInfo :: Id -> Id +zapIdTailCallInfo = zapInfo zapTailCallInfo + +zapStableUnfolding :: Id -> Id +zapStableUnfolding id + | isStableUnfolding (realIdUnfolding id) = setIdUnfolding id NoUnfolding + | otherwise = id + +{- +Note [transferPolyIdInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~ +This transfer is used in three places: + FloatOut (long-distance let-floating) + SimplUtils.abstractFloats (short-distance let-floating) + StgLiftLams (selectively lambda-lift local functions to top-level) + +Consider the short-distance let-floating: + + f = /\a. let g = rhs in ... + +Then if we float thus + + g' = /\a. rhs + f = /\a. ...[g' a/g].... + +we *do not* want to lose g's + * strictness information + * arity + * inline pragma (though that is bit more debatable) + * occurrence info + +Mostly this is just an optimisation, but it's *vital* to +transfer the occurrence info. Consider + + NonRec { f = /\a. let Rec { g* = ..g.. } in ... } + +where the '*' means 'LoopBreaker'. Then if we float we must get + + Rec { g'* = /\a. ...(g' a)... } + NonRec { f = /\a. ...[g' a/g]....} + +where g' is also marked as LoopBreaker. If not, terrible things +can happen if we re-simplify the binding (and the Simplifier does +sometimes simplify a term twice); see #4345. + +It's not so simple to retain + * worker info + * rules +so we simply discard those. Sooner or later this may bite us. + +If we abstract wrt one or more *value* binders, we must modify the +arity and strictness info before transferring it. E.g. + f = \x. e +--> + g' = \y. \x. e + + substitute (g' y) for g +Notice that g' has an arity one more than the original g +-} + +transferPolyIdInfo :: Id -- Original Id + -> [Var] -- Abstract wrt these variables + -> Id -- New Id + -> Id +transferPolyIdInfo old_id abstract_wrt new_id + = modifyIdInfo transfer new_id + where + arity_increase = count isId abstract_wrt -- Arity increases by the + -- number of value binders + + old_info = idInfo old_id + old_arity = arityInfo old_info + old_inline_prag = inlinePragInfo old_info + old_occ_info = occInfo old_info + new_arity = old_arity + arity_increase + new_occ_info = zapOccTailCallInfo old_occ_info + + old_strictness = strictnessInfo old_info + new_strictness = increaseStrictSigArity arity_increase old_strictness + + transfer new_info = new_info `setArityInfo` new_arity + `setInlinePragInfo` old_inline_prag + `setOccInfo` new_occ_info + `setStrictnessInfo` new_strictness + +isNeverLevPolyId :: Id -> Bool +isNeverLevPolyId = isNeverLevPolyIdInfo . idInfo diff --git a/compiler/basicTypes/IdInfo.hs b/compiler/basicTypes/IdInfo.hs new file mode 100644 --- /dev/null +++ b/compiler/basicTypes/IdInfo.hs @@ -0,0 +1,629 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + +\section[IdInfo]{@IdInfos@: Non-essential information about @Ids@} + +(And a pretty good illustration of quite a few things wrong with +Haskell. [WDP 94/11]) +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} + +module IdInfo ( + -- * The IdDetails type + IdDetails(..), pprIdDetails, coVarDetails, isCoVarDetails, + JoinArity, isJoinIdDetails_maybe, + RecSelParent(..), + + -- * The IdInfo type + IdInfo, -- Abstract + vanillaIdInfo, noCafIdInfo, + + -- ** The OneShotInfo type + OneShotInfo(..), + oneShotInfo, noOneShotInfo, hasNoOneShotInfo, + setOneShotInfo, + + -- ** Zapping various forms of Info + zapLamInfo, zapFragileInfo, + zapDemandInfo, zapUsageInfo, zapUsageEnvInfo, zapUsedOnceInfo, + zapTailCallInfo, zapCallArityInfo, zapUnfolding, + + -- ** The ArityInfo type + ArityInfo, + unknownArity, + arityInfo, setArityInfo, ppArityInfo, + + callArityInfo, setCallArityInfo, + + -- ** Demand and strictness Info + strictnessInfo, setStrictnessInfo, + demandInfo, setDemandInfo, pprStrictness, + + -- ** Unfolding Info + unfoldingInfo, setUnfoldingInfo, + + -- ** The InlinePragInfo type + InlinePragInfo, + inlinePragInfo, setInlinePragInfo, + + -- ** The OccInfo type + OccInfo(..), + isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, + occInfo, setOccInfo, + + InsideLam, OneBranch, + insideLam, notInsideLam, oneBranch, notOneBranch, + + TailCallInfo(..), + tailCallInfo, isAlwaysTailCalled, + + -- ** The RuleInfo type + RuleInfo(..), + emptyRuleInfo, + isEmptyRuleInfo, ruleInfoFreeVars, + ruleInfoRules, setRuleInfoHead, + ruleInfo, setRuleInfo, + + -- ** The CAFInfo type + CafInfo(..), + ppCafInfo, mayHaveCafRefs, + cafInfo, setCafInfo, + + -- ** Tick-box Info + TickBoxOp(..), TickBoxId, + + -- ** Levity info + LevityInfo, levityInfo, setNeverLevPoly, setLevityInfoWithType, + isNeverLevPolyIdInfo + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import CoreSyn + +import Class +import {-# SOURCE #-} PrimOp (PrimOp) +import Name +import VarSet +import BasicTypes +import DataCon +import TyCon +import PatSyn +import Type +import ForeignCall +import Outputable +import Module +import Demand +import Util + +-- infixl so you can say (id `set` a `set` b) +infixl 1 `setRuleInfo`, + `setArityInfo`, + `setInlinePragInfo`, + `setUnfoldingInfo`, + `setOneShotInfo`, + `setOccInfo`, + `setCafInfo`, + `setStrictnessInfo`, + `setDemandInfo`, + `setNeverLevPoly`, + `setLevityInfoWithType` + +{- +************************************************************************ +* * + IdDetails +* * +************************************************************************ +-} + +-- | Identifier Details +-- +-- The 'IdDetails' of an 'Id' give stable, and necessary, +-- information about the Id. +data IdDetails + = VanillaId + + -- | The 'Id' for a record selector + | RecSelId + { sel_tycon :: RecSelParent + , sel_naughty :: Bool -- True <=> a "naughty" selector which can't actually exist, for example @x@ in: + -- data T = forall a. MkT { x :: a } + } -- See Note [Naughty record selectors] in TcTyClsDecls + + | DataConWorkId DataCon -- ^ The 'Id' is for a data constructor /worker/ + | DataConWrapId DataCon -- ^ The 'Id' is for a data constructor /wrapper/ + + -- [the only reasons we need to know is so that + -- a) to support isImplicitId + -- b) when desugaring a RecordCon we can get + -- from the Id back to the data con] + | ClassOpId Class -- ^ The 'Id' is a superclass selector, + -- or class operation of a class + + | PrimOpId PrimOp -- ^ The 'Id' is for a primitive operator + | FCallId ForeignCall -- ^ The 'Id' is for a foreign call. + -- Type will be simple: no type families, newtypes, etc + + | TickBoxOpId TickBoxOp -- ^ The 'Id' is for a HPC tick box (both traditional and binary) + + | DFunId Bool -- ^ A dictionary function. + -- Bool = True <=> the class has only one method, so may be + -- implemented with a newtype, so it might be bad + -- to be strict on this dictionary + + | CoVarId -- ^ A coercion variable + -- This only covers /un-lifted/ coercions, of type + -- (t1 ~# t2) or (t1 ~R# t2), not their lifted variants + | JoinId JoinArity -- ^ An 'Id' for a join point taking n arguments + -- Note [Join points] in CoreSyn + +-- | Recursive Selector Parent +data RecSelParent = RecSelData TyCon | RecSelPatSyn PatSyn deriving Eq + -- Either `TyCon` or `PatSyn` depending + -- on the origin of the record selector. + -- For a data type family, this is the + -- /instance/ 'TyCon' not the family 'TyCon' + +instance Outputable RecSelParent where + ppr p = case p of + RecSelData ty_con -> ppr ty_con + RecSelPatSyn ps -> ppr ps + +-- | Just a synonym for 'CoVarId'. Written separately so it can be +-- exported in the hs-boot file. +coVarDetails :: IdDetails +coVarDetails = CoVarId + +-- | Check if an 'IdDetails' says 'CoVarId'. +isCoVarDetails :: IdDetails -> Bool +isCoVarDetails CoVarId = True +isCoVarDetails _ = False + +isJoinIdDetails_maybe :: IdDetails -> Maybe JoinArity +isJoinIdDetails_maybe (JoinId join_arity) = Just join_arity +isJoinIdDetails_maybe _ = Nothing + +instance Outputable IdDetails where + ppr = pprIdDetails + +pprIdDetails :: IdDetails -> SDoc +pprIdDetails VanillaId = empty +pprIdDetails other = brackets (pp other) + where + pp VanillaId = panic "pprIdDetails" + pp (DataConWorkId _) = text "DataCon" + pp (DataConWrapId _) = text "DataConWrapper" + pp (ClassOpId {}) = text "ClassOp" + pp (PrimOpId _) = text "PrimOp" + pp (FCallId _) = text "ForeignCall" + pp (TickBoxOpId _) = text "TickBoxOp" + pp (DFunId nt) = text "DFunId" <> ppWhen nt (text "(nt)") + pp (RecSelId { sel_naughty = is_naughty }) + = brackets $ text "RecSel" <> + ppWhen is_naughty (text "(naughty)") + pp CoVarId = text "CoVarId" + pp (JoinId arity) = text "JoinId" <> parens (int arity) + +{- +************************************************************************ +* * +\subsection{The main IdInfo type} +* * +************************************************************************ +-} + +-- | Identifier Information +-- +-- An 'IdInfo' gives /optional/ information about an 'Id'. If +-- present it never lies, but it may not be present, in which case there +-- is always a conservative assumption which can be made. +-- +-- Two 'Id's may have different info even though they have the same +-- 'Unique' (and are hence the same 'Id'); for example, one might lack +-- the properties attached to the other. +-- +-- Most of the 'IdInfo' gives information about the value, or definition, of +-- the 'Id', independent of its usage. Exceptions to this +-- are 'demandInfo', 'occInfo', 'oneShotInfo' and 'callArityInfo'. +-- +-- Performance note: when we update 'IdInfo', we have to reallocate this +-- entire record, so it is a good idea not to let this data structure get +-- too big. +data IdInfo + = IdInfo { + arityInfo :: !ArityInfo, -- ^ 'Id' arity + ruleInfo :: RuleInfo, -- ^ Specialisations of the 'Id's function which exist + -- See Note [Specialisations and RULES in IdInfo] + unfoldingInfo :: Unfolding, -- ^ The 'Id's unfolding + cafInfo :: CafInfo, -- ^ 'Id' CAF info + oneShotInfo :: OneShotInfo, -- ^ Info about a lambda-bound variable, if the 'Id' is one + inlinePragInfo :: InlinePragma, -- ^ Any inline pragma atached to the 'Id' + occInfo :: OccInfo, -- ^ How the 'Id' occurs in the program + + strictnessInfo :: StrictSig, -- ^ A strictness signature + + demandInfo :: Demand, -- ^ ID demand information + callArityInfo :: !ArityInfo, -- ^ How this is called. + -- n <=> all calls have at least n arguments + + levityInfo :: LevityInfo -- ^ when applied, will this Id ever have a levity-polymorphic type? + } + +-- Setters + +setRuleInfo :: IdInfo -> RuleInfo -> IdInfo +setRuleInfo info sp = sp `seq` info { ruleInfo = sp } +setInlinePragInfo :: IdInfo -> InlinePragma -> IdInfo +setInlinePragInfo info pr = pr `seq` info { inlinePragInfo = pr } +setOccInfo :: IdInfo -> OccInfo -> IdInfo +setOccInfo info oc = oc `seq` info { occInfo = oc } + -- Try to avoid space leaks by seq'ing + +setUnfoldingInfo :: IdInfo -> Unfolding -> IdInfo +setUnfoldingInfo info uf + = -- We don't seq the unfolding, as we generate intermediate + -- unfoldings which are just thrown away, so evaluating them is a + -- waste of time. + -- seqUnfolding uf `seq` + info { unfoldingInfo = uf } + +setArityInfo :: IdInfo -> ArityInfo -> IdInfo +setArityInfo info ar = info { arityInfo = ar } +setCallArityInfo :: IdInfo -> ArityInfo -> IdInfo +setCallArityInfo info ar = info { callArityInfo = ar } +setCafInfo :: IdInfo -> CafInfo -> IdInfo +setCafInfo info caf = info { cafInfo = caf } + +setOneShotInfo :: IdInfo -> OneShotInfo -> IdInfo +setOneShotInfo info lb = {-lb `seq`-} info { oneShotInfo = lb } + +setDemandInfo :: IdInfo -> Demand -> IdInfo +setDemandInfo info dd = dd `seq` info { demandInfo = dd } + +setStrictnessInfo :: IdInfo -> StrictSig -> IdInfo +setStrictnessInfo info dd = dd `seq` info { strictnessInfo = dd } + +-- | Basic 'IdInfo' that carries no useful information whatsoever +vanillaIdInfo :: IdInfo +vanillaIdInfo + = IdInfo { + cafInfo = vanillaCafInfo, + arityInfo = unknownArity, + ruleInfo = emptyRuleInfo, + unfoldingInfo = noUnfolding, + oneShotInfo = NoOneShotInfo, + inlinePragInfo = defaultInlinePragma, + occInfo = noOccInfo, + demandInfo = topDmd, + strictnessInfo = nopSig, + callArityInfo = unknownArity, + levityInfo = NoLevityInfo + } + +-- | More informative 'IdInfo' we can use when we know the 'Id' has no CAF references +noCafIdInfo :: IdInfo +noCafIdInfo = vanillaIdInfo `setCafInfo` NoCafRefs + -- Used for built-in type Ids in MkId. + +{- +************************************************************************ +* * +\subsection[arity-IdInfo]{Arity info about an @Id@} +* * +************************************************************************ + +For locally-defined Ids, the code generator maintains its own notion +of their arities; so it should not be asking... (but other things +besides the code-generator need arity info!) +-} + +-- | Arity Information +-- +-- An 'ArityInfo' of @n@ tells us that partial application of this +-- 'Id' to up to @n-1@ value arguments does essentially no work. +-- +-- That is not necessarily the same as saying that it has @n@ leading +-- lambdas, because coerces may get in the way. +-- +-- The arity might increase later in the compilation process, if +-- an extra lambda floats up to the binding site. +type ArityInfo = Arity + +-- | It is always safe to assume that an 'Id' has an arity of 0 +unknownArity :: Arity +unknownArity = 0 + +ppArityInfo :: Int -> SDoc +ppArityInfo 0 = empty +ppArityInfo n = hsep [text "Arity", int n] + +{- +************************************************************************ +* * +\subsection{Inline-pragma information} +* * +************************************************************************ +-} + +-- | Inline Pragma Information +-- +-- Tells when the inlining is active. +-- When it is active the thing may be inlined, depending on how +-- big it is. +-- +-- If there was an @INLINE@ pragma, then as a separate matter, the +-- RHS will have been made to look small with a Core inline 'Note' +-- +-- The default 'InlinePragInfo' is 'AlwaysActive', so the info serves +-- entirely as a way to inhibit inlining until we want it +type InlinePragInfo = InlinePragma + +{- +************************************************************************ +* * + Strictness +* * +************************************************************************ +-} + +pprStrictness :: StrictSig -> SDoc +pprStrictness sig = ppr sig + +{- +************************************************************************ +* * + RuleInfo +* * +************************************************************************ + +Note [Specialisations and RULES in IdInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Generally speaking, a GlobalId has an *empty* RuleInfo. All their +RULES are contained in the globally-built rule-base. In principle, +one could attach the to M.f the RULES for M.f that are defined in M. +But we don't do that for instance declarations and so we just treat +them all uniformly. + +The EXCEPTION is PrimOpIds, which do have rules in their IdInfo. That is +jsut for convenience really. + +However, LocalIds may have non-empty RuleInfo. We treat them +differently because: + a) they might be nested, in which case a global table won't work + b) the RULE might mention free variables, which we use to keep things alive + +In TidyPgm, when the LocalId becomes a GlobalId, its RULES are stripped off +and put in the global list. +-} + +-- | Rule Information +-- +-- Records the specializations of this 'Id' that we know about +-- in the form of rewrite 'CoreRule's that target them +data RuleInfo + = RuleInfo + [CoreRule] + DVarSet -- Locally-defined free vars of *both* LHS and RHS + -- of rules. I don't think it needs to include the + -- ru_fn though. + -- Note [Rule dependency info] in OccurAnal + +-- | Assume that no specilizations exist: always safe +emptyRuleInfo :: RuleInfo +emptyRuleInfo = RuleInfo [] emptyDVarSet + +isEmptyRuleInfo :: RuleInfo -> Bool +isEmptyRuleInfo (RuleInfo rs _) = null rs + +-- | Retrieve the locally-defined free variables of both the left and +-- right hand sides of the specialization rules +ruleInfoFreeVars :: RuleInfo -> DVarSet +ruleInfoFreeVars (RuleInfo _ fvs) = fvs + +ruleInfoRules :: RuleInfo -> [CoreRule] +ruleInfoRules (RuleInfo rules _) = rules + +-- | Change the name of the function the rule is keyed on on all of the 'CoreRule's +setRuleInfoHead :: Name -> RuleInfo -> RuleInfo +setRuleInfoHead fn (RuleInfo rules fvs) + = RuleInfo (map (setRuleIdName fn) rules) fvs + +{- +************************************************************************ +* * +\subsection[CG-IdInfo]{Code generator-related information} +* * +************************************************************************ +-} + +-- CafInfo is used to build Static Reference Tables (see simplStg/SRT.hs). + +-- | Constant applicative form Information +-- +-- Records whether an 'Id' makes Constant Applicative Form references +data CafInfo + = MayHaveCafRefs -- ^ Indicates that the 'Id' is for either: + -- + -- 1. A function or static constructor + -- that refers to one or more CAFs, or + -- + -- 2. A real live CAF + + | NoCafRefs -- ^ A function or static constructor + -- that refers to no CAFs. + deriving (Eq, Ord) + +-- | Assumes that the 'Id' has CAF references: definitely safe +vanillaCafInfo :: CafInfo +vanillaCafInfo = MayHaveCafRefs + +mayHaveCafRefs :: CafInfo -> Bool +mayHaveCafRefs MayHaveCafRefs = True +mayHaveCafRefs _ = False + +instance Outputable CafInfo where + ppr = ppCafInfo + +ppCafInfo :: CafInfo -> SDoc +ppCafInfo NoCafRefs = text "NoCafRefs" +ppCafInfo MayHaveCafRefs = empty + +{- +************************************************************************ +* * +\subsection{Bulk operations on IdInfo} +* * +************************************************************************ +-} + +-- | This is used to remove information on lambda binders that we have +-- setup as part of a lambda group, assuming they will be applied all at once, +-- but turn out to be part of an unsaturated lambda as in e.g: +-- +-- > (\x1. \x2. e) arg1 +zapLamInfo :: IdInfo -> Maybe IdInfo +zapLamInfo info@(IdInfo {occInfo = occ, demandInfo = demand}) + | is_safe_occ occ && is_safe_dmd demand + = Nothing + | otherwise + = Just (info {occInfo = safe_occ, demandInfo = topDmd}) + where + -- The "unsafe" occ info is the ones that say I'm not in a lambda + -- because that might not be true for an unsaturated lambda + is_safe_occ occ | isAlwaysTailCalled occ = False + is_safe_occ (OneOcc { occ_in_lam = in_lam }) = in_lam + is_safe_occ _other = True + + safe_occ = case occ of + OneOcc{} -> occ { occ_in_lam = True + , occ_tail = NoTailCallInfo } + IAmALoopBreaker{} + -> occ { occ_tail = NoTailCallInfo } + _other -> occ + + is_safe_dmd dmd = not (isStrictDmd dmd) + +-- | Remove all demand info on the 'IdInfo' +zapDemandInfo :: IdInfo -> Maybe IdInfo +zapDemandInfo info = Just (info {demandInfo = topDmd}) + +-- | Remove usage (but not strictness) info on the 'IdInfo' +zapUsageInfo :: IdInfo -> Maybe IdInfo +zapUsageInfo info = Just (info {demandInfo = zapUsageDemand (demandInfo info)}) + +-- | Remove usage environment info from the strictness signature on the 'IdInfo' +zapUsageEnvInfo :: IdInfo -> Maybe IdInfo +zapUsageEnvInfo info + | hasDemandEnvSig (strictnessInfo info) + = Just (info {strictnessInfo = zapUsageEnvSig (strictnessInfo info)}) + | otherwise + = Nothing + +zapUsedOnceInfo :: IdInfo -> Maybe IdInfo +zapUsedOnceInfo info + = Just $ info { strictnessInfo = zapUsedOnceSig (strictnessInfo info) + , demandInfo = zapUsedOnceDemand (demandInfo info) } + +zapFragileInfo :: IdInfo -> Maybe IdInfo +-- ^ Zap info that depends on free variables +zapFragileInfo info@(IdInfo { occInfo = occ, unfoldingInfo = unf }) + = new_unf `seq` -- The unfolding field is not (currently) strict, so we + -- force it here to avoid a (zapFragileUnfolding unf) thunk + -- which might leak space + Just (info `setRuleInfo` emptyRuleInfo + `setUnfoldingInfo` new_unf + `setOccInfo` zapFragileOcc occ) + where + new_unf = zapFragileUnfolding unf + +zapFragileUnfolding :: Unfolding -> Unfolding +zapFragileUnfolding unf + | isFragileUnfolding unf = noUnfolding + | otherwise = unf + +zapUnfolding :: Unfolding -> Unfolding +-- Squash all unfolding info, preserving only evaluated-ness +zapUnfolding unf | isEvaldUnfolding unf = evaldUnfolding + | otherwise = noUnfolding + +zapTailCallInfo :: IdInfo -> Maybe IdInfo +zapTailCallInfo info + = case occInfo info of + occ | isAlwaysTailCalled occ -> Just (info `setOccInfo` safe_occ) + | otherwise -> Nothing + where + safe_occ = occ { occ_tail = NoTailCallInfo } + +zapCallArityInfo :: IdInfo -> IdInfo +zapCallArityInfo info = setCallArityInfo info 0 + +{- +************************************************************************ +* * +\subsection{TickBoxOp} +* * +************************************************************************ +-} + +type TickBoxId = Int + +-- | Tick box for Hpc-style coverage +data TickBoxOp + = TickBox Module {-# UNPACK #-} !TickBoxId + +instance Outputable TickBoxOp where + ppr (TickBox mod n) = text "tick" <+> ppr (mod,n) + +{- +************************************************************************ +* * + Levity +* * +************************************************************************ + +Note [Levity info] +~~~~~~~~~~~~~~~~~~ + +Ids store whether or not they can be levity-polymorphic at any amount +of saturation. This is helpful in optimizing the levity-polymorphism check +done in the desugarer, where we can usually learn that something is not +levity-polymorphic without actually figuring out its type. See +isExprLevPoly in CoreUtils for where this info is used. Storing +this is required to prevent perf/compiler/T5631 from blowing up. + +-} + +-- See Note [Levity info] +data LevityInfo = NoLevityInfo -- always safe + | NeverLevityPolymorphic + deriving Eq + +instance Outputable LevityInfo where + ppr NoLevityInfo = text "NoLevityInfo" + ppr NeverLevityPolymorphic = text "NeverLevityPolymorphic" + +-- | Marks an IdInfo describing an Id that is never levity polymorphic (even when +-- applied). The Type is only there for checking that it's really never levity +-- polymorphic +setNeverLevPoly :: HasDebugCallStack => IdInfo -> Type -> IdInfo +setNeverLevPoly info ty + = ASSERT2( not (resultIsLevPoly ty), ppr ty ) + info { levityInfo = NeverLevityPolymorphic } + +setLevityInfoWithType :: IdInfo -> Type -> IdInfo +setLevityInfoWithType info ty + | not (resultIsLevPoly ty) + = info { levityInfo = NeverLevityPolymorphic } + | otherwise + = info + +isNeverLevPolyIdInfo :: IdInfo -> Bool +isNeverLevPolyIdInfo info + | NeverLevityPolymorphic <- levityInfo info = True + | otherwise = False diff --git a/compiler/basicTypes/IdInfo.hs-boot b/compiler/basicTypes/IdInfo.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/basicTypes/IdInfo.hs-boot @@ -0,0 +1,11 @@ +module IdInfo where +import GhcPrelude +import Outputable +data IdInfo +data IdDetails + +vanillaIdInfo :: IdInfo +coVarDetails :: IdDetails +isCoVarDetails :: IdDetails -> Bool +pprIdDetails :: IdDetails -> SDoc + diff --git a/compiler/basicTypes/Lexeme.hs b/compiler/basicTypes/Lexeme.hs new file mode 100644 --- /dev/null +++ b/compiler/basicTypes/Lexeme.hs @@ -0,0 +1,240 @@ +-- (c) The GHC Team +-- +-- Functions to evaluate whether or not a string is a valid identifier. +-- There is considerable overlap between the logic here and the logic +-- in Lexer.x, but sadly there seems to be no way to merge them. + +module Lexeme ( + -- * Lexical characteristics of Haskell names + + -- | Use these functions to figure what kind of name a 'FastString' + -- represents; these functions do /not/ check that the identifier + -- is valid. + + isLexCon, isLexVar, isLexId, isLexSym, + isLexConId, isLexConSym, isLexVarId, isLexVarSym, + startsVarSym, startsVarId, startsConSym, startsConId, + + -- * Validating identifiers + + -- | These functions (working over plain old 'String's) check + -- to make sure that the identifier is valid. + okVarOcc, okConOcc, okTcOcc, + okVarIdOcc, okVarSymOcc, okConIdOcc, okConSymOcc + + -- Some of the exports above are not used within GHC, but may + -- be of value to GHC API users. + + ) where + +import GhcPrelude + +import FastString + +import Data.Char +import qualified Data.Set as Set + +import GHC.Lexeme + +{- + +************************************************************************ +* * + Lexical categories +* * +************************************************************************ + +These functions test strings to see if they fit the lexical categories +defined in the Haskell report. + +Note [Classification of generated names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Some names generated for internal use can show up in debugging output, +e.g. when using -ddump-simpl. These generated names start with a $ +but should still be pretty-printed using prefix notation. We make sure +this is the case in isLexVarSym by only classifying a name as a symbol +if all its characters are symbols, not just its first one. +-} + +isLexCon, isLexVar, isLexId, isLexSym :: FastString -> Bool +isLexConId, isLexConSym, isLexVarId, isLexVarSym :: FastString -> Bool + +isLexCon cs = isLexConId cs || isLexConSym cs +isLexVar cs = isLexVarId cs || isLexVarSym cs + +isLexId cs = isLexConId cs || isLexVarId cs +isLexSym cs = isLexConSym cs || isLexVarSym cs + +------------- +isLexConId cs -- Prefix type or data constructors + | nullFS cs = False -- e.g. "Foo", "[]", "(,)" + | cs == (fsLit "[]") = True + | otherwise = startsConId (headFS cs) + +isLexVarId cs -- Ordinary prefix identifiers + | nullFS cs = False -- e.g. "x", "_x" + | otherwise = startsVarId (headFS cs) + +isLexConSym cs -- Infix type or data constructors + | nullFS cs = False -- e.g. ":-:", ":", "->" + | cs == (fsLit "->") = True + | otherwise = startsConSym (headFS cs) + +isLexVarSym fs -- Infix identifiers e.g. "+" + | fs == (fsLit "~R#") = True + | otherwise + = case (if nullFS fs then [] else unpackFS fs) of + [] -> False + (c:cs) -> startsVarSym c && all isVarSymChar cs + -- See Note [Classification of generated names] + +{- + +************************************************************************ +* * + Detecting valid names for Template Haskell +* * +************************************************************************ + +-} + +---------------------- +-- External interface +---------------------- + +-- | Is this an acceptable variable name? +okVarOcc :: String -> Bool +okVarOcc str@(c:_) + | startsVarId c + = okVarIdOcc str + | startsVarSym c + = okVarSymOcc str +okVarOcc _ = False + +-- | Is this an acceptable constructor name? +okConOcc :: String -> Bool +okConOcc str@(c:_) + | startsConId c + = okConIdOcc str + | startsConSym c + = okConSymOcc str + | str == "[]" + = True +okConOcc _ = False + +-- | Is this an acceptable type name? +okTcOcc :: String -> Bool +okTcOcc "[]" = True +okTcOcc "->" = True +okTcOcc "~" = True +okTcOcc str@(c:_) + | startsConId c + = okConIdOcc str + | startsConSym c + = okConSymOcc str + | startsVarSym c + = okVarSymOcc str +okTcOcc _ = False + +-- | Is this an acceptable alphanumeric variable name, assuming it starts +-- with an acceptable letter? +okVarIdOcc :: String -> Bool +okVarIdOcc str = okIdOcc str && + -- admit "_" as a valid identifier. Required to support typed + -- holes in Template Haskell. See #10267 + (str == "_" || not (str `Set.member` reservedIds)) + +-- | Is this an acceptable symbolic variable name, assuming it starts +-- with an acceptable character? +okVarSymOcc :: String -> Bool +okVarSymOcc str = all okSymChar str && + not (str `Set.member` reservedOps) && + not (isDashes str) + +-- | Is this an acceptable alphanumeric constructor name, assuming it +-- starts with an acceptable letter? +okConIdOcc :: String -> Bool +okConIdOcc str = okIdOcc str || + is_tuple_name1 True str || + -- Is it a boxed tuple... + is_tuple_name1 False str || + -- ...or an unboxed tuple (#12407)... + is_sum_name1 str + -- ...or an unboxed sum (#12514)? + where + -- check for tuple name, starting at the beginning + is_tuple_name1 True ('(' : rest) = is_tuple_name2 True rest + is_tuple_name1 False ('(' : '#' : rest) = is_tuple_name2 False rest + is_tuple_name1 _ _ = False + + -- check for tuple tail + is_tuple_name2 True ")" = True + is_tuple_name2 False "#)" = True + is_tuple_name2 boxed (',' : rest) = is_tuple_name2 boxed rest + is_tuple_name2 boxed (ws : rest) + | isSpace ws = is_tuple_name2 boxed rest + is_tuple_name2 _ _ = False + + -- check for sum name, starting at the beginning + is_sum_name1 ('(' : '#' : rest) = is_sum_name2 False rest + is_sum_name1 _ = False + + -- check for sum tail, only allowing at most one underscore + is_sum_name2 _ "#)" = True + is_sum_name2 underscore ('|' : rest) = is_sum_name2 underscore rest + is_sum_name2 False ('_' : rest) = is_sum_name2 True rest + is_sum_name2 underscore (ws : rest) + | isSpace ws = is_sum_name2 underscore rest + is_sum_name2 _ _ = False + +-- | Is this an acceptable symbolic constructor name, assuming it +-- starts with an acceptable character? +okConSymOcc :: String -> Bool +okConSymOcc ":" = True +okConSymOcc str = all okSymChar str && + not (str `Set.member` reservedOps) + +---------------------- +-- Internal functions +---------------------- + +-- | Is this string an acceptable id, possibly with a suffix of hashes, +-- but not worrying about case or clashing with reserved words? +okIdOcc :: String -> Bool +okIdOcc str + = let hashes = dropWhile okIdChar str in + all (== '#') hashes -- -XMagicHash allows a suffix of hashes + -- of course, `all` says "True" to an empty list + +-- | Is this character acceptable in an identifier (after the first letter)? +-- See alexGetByte in Lexer.x +okIdChar :: Char -> Bool +okIdChar c = case generalCategory c of + UppercaseLetter -> True + LowercaseLetter -> True + TitlecaseLetter -> True + ModifierLetter -> True -- See #10196 + OtherLetter -> True -- See #1103 + NonSpacingMark -> True -- See #7650 + DecimalNumber -> True + OtherNumber -> True -- See #4373 + _ -> c == '\'' || c == '_' + +-- | All reserved identifiers. Taken from section 2.4 of the 2010 Report. +reservedIds :: Set.Set String +reservedIds = Set.fromList [ "case", "class", "data", "default", "deriving" + , "do", "else", "foreign", "if", "import", "in" + , "infix", "infixl", "infixr", "instance", "let" + , "module", "newtype", "of", "then", "type", "where" + , "_" ] + +-- | All reserved operators. Taken from section 2.4 of the 2010 Report. +reservedOps :: Set.Set String +reservedOps = Set.fromList [ "..", ":", "::", "=", "\\", "|", "<-", "->" + , "@", "~", "=>" ] + +-- | Does this string contain only dashes and has at least 2 of them? +isDashes :: String -> Bool +isDashes ('-' : '-' : rest) = all (== '-') rest +isDashes _ = False diff --git a/compiler/basicTypes/Literal.hs b/compiler/basicTypes/Literal.hs new file mode 100644 --- /dev/null +++ b/compiler/basicTypes/Literal.hs @@ -0,0 +1,834 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1998 + +\section[Literal]{@Literal@: literals} +-} + +{-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-} + +module Literal + ( + -- * Main data type + Literal(..) -- Exported to ParseIface + , LitNumType(..) + + -- ** Creating Literals + , mkLitInt, mkLitIntWrap, mkLitIntWrapC + , mkLitWord, mkLitWordWrap, mkLitWordWrapC + , mkLitInt64, mkLitInt64Wrap + , mkLitWord64, mkLitWord64Wrap + , mkLitFloat, mkLitDouble + , mkLitChar, mkLitString + , mkLitInteger, mkLitNatural + , mkLitNumber, mkLitNumberWrap + + -- ** Operations on Literals + , literalType + , absentLiteralOf + , pprLiteral + , litNumIsSigned + , litNumCheckRange + + -- ** Predicates on Literals and their contents + , litIsDupable, litIsTrivial, litIsLifted + , inIntRange, inWordRange, tARGET_MAX_INT, inCharRange + , isZeroLit + , litFitsInChar + , litValue, isLitValue, isLitValue_maybe, mapLitValue + + -- ** Coercions + , word2IntLit, int2WordLit + , narrowLit + , narrow8IntLit, narrow16IntLit, narrow32IntLit + , narrow8WordLit, narrow16WordLit, narrow32WordLit + , char2IntLit, int2CharLit + , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit + , nullAddrLit, rubbishLit, float2DoubleLit, double2FloatLit + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import TysPrim +import PrelNames +import Type +import TyCon +import Outputable +import FastString +import BasicTypes +import Binary +import Constants +import DynFlags +import Platform +import UniqFM +import Util + +import Data.ByteString (ByteString) +import Data.Int +import Data.Word +import Data.Char +import Data.Maybe ( isJust ) +import Data.Data ( Data ) +import Data.Proxy +import Numeric ( fromRat ) + +{- +************************************************************************ +* * +\subsection{Literals} +* * +************************************************************************ +-} + +-- | So-called 'Literal's are one of: +-- +-- * An unboxed numeric literal or floating-point literal which is presumed +-- to be surrounded by appropriate constructors (@Int#@, etc.), so that +-- the overall thing makes sense. +-- +-- We maintain the invariant that the 'Integer' in the 'LitNumber' +-- constructor is actually in the (possibly target-dependent) range. +-- The mkLit{Int,Word}*Wrap smart constructors ensure this by applying +-- the target machine's wrapping semantics. Use these in situations +-- where you know the wrapping semantics are correct. +-- +-- * The literal derived from the label mentioned in a \"foreign label\" +-- declaration ('LitLabel') +-- +-- * A 'LitRubbish' to be used in place of values of 'UnliftedRep' +-- (i.e. 'MutVar#') when the the value is never used. +-- +-- * A character +-- * A string +-- * The NULL pointer +-- +data Literal + = LitChar Char -- ^ @Char#@ - at least 31 bits. Create with + -- 'mkLitChar' + + | LitNumber !LitNumType !Integer Type + -- ^ Any numeric literal that can be + -- internally represented with an Integer + + | LitString ByteString -- ^ A string-literal: stored and emitted + -- UTF-8 encoded, we'll arrange to decode it + -- at runtime. Also emitted with a @\'\\0\'@ + -- terminator. Create with 'mkLitString' + + | LitNullAddr -- ^ The @NULL@ pointer, the only pointer value + -- that can be represented as a Literal. Create + -- with 'nullAddrLit' + + | LitRubbish -- ^ A nonsense value, used when an unlifted + -- binding is absent and has type + -- @forall (a :: 'TYPE' 'UnliftedRep'). a@. + -- May be lowered by code-gen to any possible + -- value. Also see Note [Rubbish literals] + + | LitFloat Rational -- ^ @Float#@. Create with 'mkLitFloat' + | LitDouble Rational -- ^ @Double#@. Create with 'mkLitDouble' + + | LitLabel FastString (Maybe Int) FunctionOrData + -- ^ A label literal. Parameters: + -- + -- 1) The name of the symbol mentioned in the + -- declaration + -- + -- 2) The size (in bytes) of the arguments + -- the label expects. Only applicable with + -- @stdcall@ labels. @Just x@ => @\@ will + -- be appended to label name when emitting + -- assembly. + -- + -- 3) Flag indicating whether the symbol + -- references a function or a data + deriving Data + +-- | Numeric literal type +data LitNumType + = LitNumInteger -- ^ @Integer@ (see Note [Integer literals]) + | LitNumNatural -- ^ @Natural@ (see Note [Natural literals]) + | LitNumInt -- ^ @Int#@ - according to target machine + | LitNumInt64 -- ^ @Int64#@ - exactly 64 bits + | LitNumWord -- ^ @Word#@ - according to target machine + | LitNumWord64 -- ^ @Word64#@ - exactly 64 bits + deriving (Data,Enum,Eq,Ord) + +-- | Indicate if a numeric literal type supports negative numbers +litNumIsSigned :: LitNumType -> Bool +litNumIsSigned nt = case nt of + LitNumInteger -> True + LitNumNatural -> False + LitNumInt -> True + LitNumInt64 -> True + LitNumWord -> False + LitNumWord64 -> False + +{- +Note [Integer literals] +~~~~~~~~~~~~~~~~~~~~~~~ +An Integer literal is represented using, well, an Integer, to make it +easier to write RULEs for them. They also contain the Integer type, so +that e.g. literalType can return the right Type for them. + +They only get converted into real Core, + mkInteger [c1, c2, .., cn] +during the CorePrep phase, although TidyPgm looks ahead at what the +core will be, so that it can see whether it involves CAFs. + +When we initally build an Integer literal, notably when +deserialising it from an interface file (see the Binary instance +below), we don't have convenient access to the mkInteger Id. So we +just use an error thunk, and fill in the real Id when we do tcIfaceLit +in TcIface. + +Note [Natural literals] +~~~~~~~~~~~~~~~~~~~~~~~ +Similar to Integer literals. + +Note [String literals] +~~~~~~~~~~~~~~~~~~~~~~ + +String literals are UTF-8 encoded and stored into ByteStrings in the following +ASTs: Haskell, Core, Stg, Cmm. TH can also emit ByteString based string literals +with the BytesPrimL constructor (see #14741). + +It wasn't true before as [Word8] was used in Cmm AST and in TH which was quite +bad for performance with large strings (see #16198 and #14741). + +To include string literals into output objects, the assembler code generator has +to embed the UTF-8 encoded binary blob. See Note [Embedding large binary blobs] +for more details. + +-} + +instance Binary LitNumType where + put_ bh numTyp = putByte bh (fromIntegral (fromEnum numTyp)) + get bh = do + h <- getByte bh + return (toEnum (fromIntegral h)) + +instance Binary Literal where + put_ bh (LitChar aa) = do putByte bh 0; put_ bh aa + put_ bh (LitString ab) = do putByte bh 1; put_ bh ab + put_ bh (LitNullAddr) = do putByte bh 2 + put_ bh (LitFloat ah) = do putByte bh 3; put_ bh ah + put_ bh (LitDouble ai) = do putByte bh 4; put_ bh ai + put_ bh (LitLabel aj mb fod) + = do putByte bh 5 + put_ bh aj + put_ bh mb + put_ bh fod + put_ bh (LitNumber nt i _) + = do putByte bh 6 + put_ bh nt + put_ bh i + put_ bh (LitRubbish) = do putByte bh 7 + get bh = do + h <- getByte bh + case h of + 0 -> do + aa <- get bh + return (LitChar aa) + 1 -> do + ab <- get bh + return (LitString ab) + 2 -> do + return (LitNullAddr) + 3 -> do + ah <- get bh + return (LitFloat ah) + 4 -> do + ai <- get bh + return (LitDouble ai) + 5 -> do + aj <- get bh + mb <- get bh + fod <- get bh + return (LitLabel aj mb fod) + 6 -> do + nt <- get bh + i <- get bh + let t = case nt of + LitNumInt -> intPrimTy + LitNumInt64 -> int64PrimTy + LitNumWord -> wordPrimTy + LitNumWord64 -> word64PrimTy + -- See Note [Integer literals] + LitNumInteger -> + panic "Evaluated the place holder for mkInteger" + -- and Note [Natural literals] + LitNumNatural -> + panic "Evaluated the place holder for mkNatural" + return (LitNumber nt i t) + _ -> do + return (LitRubbish) + +instance Outputable Literal where + ppr lit = pprLiteral (\d -> d) lit + +instance Eq Literal where + a == b = case (a `compare` b) of { EQ -> True; _ -> False } + a /= b = case (a `compare` b) of { EQ -> False; _ -> True } + +-- | Needed for the @Ord@ instance of 'AltCon', which in turn is needed in +-- 'TrieMap.CoreMap'. +instance Ord Literal where + a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } + a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } + a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } + a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } + compare a b = cmpLit a b + +{- + Construction + ~~~~~~~~~~~~ +-} + +{- Note [Word/Int underflow/overflow] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +According to the Haskell Report 2010 (Sections 18.1 and 23.1 about signed and +unsigned integral types): "All arithmetic is performed modulo 2^n, where n is +the number of bits in the type." + +GHC stores Word# and Int# constant values as Integer. Core optimizations such +as constant folding must ensure that the Integer value remains in the valid +target Word/Int range (see #13172). The following functions are used to +ensure this. + +Note that we *don't* warn the user about overflow. It's not done at runtime +either, and compilation of completely harmless things like + ((124076834 :: Word32) + (2147483647 :: Word32)) +doesn't yield a warning. Instead we simply squash the value into the *target* +Int/Word range. +-} + +-- | Wrap a literal number according to its type +wrapLitNumber :: DynFlags -> Literal -> Literal +wrapLitNumber dflags v@(LitNumber nt i t) = case nt of + LitNumInt -> case platformWordSize (targetPlatform dflags) of + 4 -> LitNumber nt (toInteger (fromIntegral i :: Int32)) t + 8 -> LitNumber nt (toInteger (fromIntegral i :: Int64)) t + w -> panic ("wrapLitNumber: Unknown platformWordSize: " ++ show w) + LitNumWord -> case platformWordSize (targetPlatform dflags) of + 4 -> LitNumber nt (toInteger (fromIntegral i :: Word32)) t + 8 -> LitNumber nt (toInteger (fromIntegral i :: Word64)) t + w -> panic ("wrapLitNumber: Unknown platformWordSize: " ++ show w) + LitNumInt64 -> LitNumber nt (toInteger (fromIntegral i :: Int64)) t + LitNumWord64 -> LitNumber nt (toInteger (fromIntegral i :: Word64)) t + LitNumInteger -> v + LitNumNatural -> v +wrapLitNumber _ x = x + +-- | Create a numeric 'Literal' of the given type +mkLitNumberWrap :: DynFlags -> LitNumType -> Integer -> Type -> Literal +mkLitNumberWrap dflags nt i t = wrapLitNumber dflags (LitNumber nt i t) + +-- | Check that a given number is in the range of a numeric literal +litNumCheckRange :: DynFlags -> LitNumType -> Integer -> Bool +litNumCheckRange dflags nt i = case nt of + LitNumInt -> inIntRange dflags i + LitNumWord -> inWordRange dflags i + LitNumInt64 -> inInt64Range i + LitNumWord64 -> inWord64Range i + LitNumNatural -> i >= 0 + LitNumInteger -> True + +-- | Create a numeric 'Literal' of the given type +mkLitNumber :: DynFlags -> LitNumType -> Integer -> Type -> Literal +mkLitNumber dflags nt i t = + ASSERT2(litNumCheckRange dflags nt i, integer i) + (LitNumber nt i t) + +-- | Creates a 'Literal' of type @Int#@ +mkLitInt :: DynFlags -> Integer -> Literal +mkLitInt dflags x = ASSERT2( inIntRange dflags x, integer x ) + (mkLitIntUnchecked x) + +-- | Creates a 'Literal' of type @Int#@. +-- If the argument is out of the (target-dependent) range, it is wrapped. +-- See Note [Word/Int underflow/overflow] +mkLitIntWrap :: DynFlags -> Integer -> Literal +mkLitIntWrap dflags i = wrapLitNumber dflags $ mkLitIntUnchecked i + +-- | Creates a 'Literal' of type @Int#@ without checking its range. +mkLitIntUnchecked :: Integer -> Literal +mkLitIntUnchecked i = LitNumber LitNumInt i intPrimTy + +-- | Creates a 'Literal' of type @Int#@, as well as a 'Bool'ean flag indicating +-- overflow. That is, if the argument is out of the (target-dependent) range +-- the argument is wrapped and the overflow flag will be set. +-- See Note [Word/Int underflow/overflow] +mkLitIntWrapC :: DynFlags -> Integer -> (Literal, Bool) +mkLitIntWrapC dflags i = (n, i /= i') + where + n@(LitNumber _ i' _) = mkLitIntWrap dflags i + +-- | Creates a 'Literal' of type @Word#@ +mkLitWord :: DynFlags -> Integer -> Literal +mkLitWord dflags x = ASSERT2( inWordRange dflags x, integer x ) + (mkLitWordUnchecked x) + +-- | Creates a 'Literal' of type @Word#@. +-- If the argument is out of the (target-dependent) range, it is wrapped. +-- See Note [Word/Int underflow/overflow] +mkLitWordWrap :: DynFlags -> Integer -> Literal +mkLitWordWrap dflags i = wrapLitNumber dflags $ mkLitWordUnchecked i + +-- | Creates a 'Literal' of type @Word#@ without checking its range. +mkLitWordUnchecked :: Integer -> Literal +mkLitWordUnchecked i = LitNumber LitNumWord i wordPrimTy + +-- | Creates a 'Literal' of type @Word#@, as well as a 'Bool'ean flag indicating +-- carry. That is, if the argument is out of the (target-dependent) range +-- the argument is wrapped and the carry flag will be set. +-- See Note [Word/Int underflow/overflow] +mkLitWordWrapC :: DynFlags -> Integer -> (Literal, Bool) +mkLitWordWrapC dflags i = (n, i /= i') + where + n@(LitNumber _ i' _) = mkLitWordWrap dflags i + +-- | Creates a 'Literal' of type @Int64#@ +mkLitInt64 :: Integer -> Literal +mkLitInt64 x = ASSERT2( inInt64Range x, integer x ) (mkLitInt64Unchecked x) + +-- | Creates a 'Literal' of type @Int64#@. +-- If the argument is out of the range, it is wrapped. +mkLitInt64Wrap :: DynFlags -> Integer -> Literal +mkLitInt64Wrap dflags i = wrapLitNumber dflags $ mkLitInt64Unchecked i + +-- | Creates a 'Literal' of type @Int64#@ without checking its range. +mkLitInt64Unchecked :: Integer -> Literal +mkLitInt64Unchecked i = LitNumber LitNumInt64 i int64PrimTy + +-- | Creates a 'Literal' of type @Word64#@ +mkLitWord64 :: Integer -> Literal +mkLitWord64 x = ASSERT2( inWord64Range x, integer x ) (mkLitWord64Unchecked x) + +-- | Creates a 'Literal' of type @Word64#@. +-- If the argument is out of the range, it is wrapped. +mkLitWord64Wrap :: DynFlags -> Integer -> Literal +mkLitWord64Wrap dflags i = wrapLitNumber dflags $ mkLitWord64Unchecked i + +-- | Creates a 'Literal' of type @Word64#@ without checking its range. +mkLitWord64Unchecked :: Integer -> Literal +mkLitWord64Unchecked i = LitNumber LitNumWord64 i word64PrimTy + +-- | Creates a 'Literal' of type @Float#@ +mkLitFloat :: Rational -> Literal +mkLitFloat = LitFloat + +-- | Creates a 'Literal' of type @Double#@ +mkLitDouble :: Rational -> Literal +mkLitDouble = LitDouble + +-- | Creates a 'Literal' of type @Char#@ +mkLitChar :: Char -> Literal +mkLitChar = LitChar + +-- | Creates a 'Literal' of type @Addr#@, which is appropriate for passing to +-- e.g. some of the \"error\" functions in GHC.Err such as @GHC.Err.runtimeError@ +mkLitString :: String -> Literal +-- stored UTF-8 encoded +mkLitString s = LitString (bytesFS $ mkFastString s) + +mkLitInteger :: Integer -> Type -> Literal +mkLitInteger x ty = LitNumber LitNumInteger x ty + +mkLitNatural :: Integer -> Type -> Literal +mkLitNatural x ty = ASSERT2( inNaturalRange x, integer x ) + (LitNumber LitNumNatural x ty) + +inIntRange, inWordRange :: DynFlags -> Integer -> Bool +inIntRange dflags x = x >= tARGET_MIN_INT dflags && x <= tARGET_MAX_INT dflags +inWordRange dflags x = x >= 0 && x <= tARGET_MAX_WORD dflags + +inNaturalRange :: Integer -> Bool +inNaturalRange x = x >= 0 + +inInt64Range, inWord64Range :: Integer -> Bool +inInt64Range x = x >= toInteger (minBound :: Int64) && + x <= toInteger (maxBound :: Int64) +inWord64Range x = x >= toInteger (minBound :: Word64) && + x <= toInteger (maxBound :: Word64) + +inCharRange :: Char -> Bool +inCharRange c = c >= '\0' && c <= chr tARGET_MAX_CHAR + +-- | Tests whether the literal represents a zero of whatever type it is +isZeroLit :: Literal -> Bool +isZeroLit (LitNumber _ 0 _) = True +isZeroLit (LitFloat 0) = True +isZeroLit (LitDouble 0) = True +isZeroLit _ = False + +-- | Returns the 'Integer' contained in the 'Literal', for when that makes +-- sense, i.e. for 'Char', 'Int', 'Word', 'LitInteger' and 'LitNatural'. +litValue :: Literal -> Integer +litValue l = case isLitValue_maybe l of + Just x -> x + Nothing -> pprPanic "litValue" (ppr l) + +-- | Returns the 'Integer' contained in the 'Literal', for when that makes +-- sense, i.e. for 'Char' and numbers. +isLitValue_maybe :: Literal -> Maybe Integer +isLitValue_maybe (LitChar c) = Just $ toInteger $ ord c +isLitValue_maybe (LitNumber _ i _) = Just i +isLitValue_maybe _ = Nothing + +-- | Apply a function to the 'Integer' contained in the 'Literal', for when that +-- makes sense, e.g. for 'Char' and numbers. +-- For fixed-size integral literals, the result will be wrapped in accordance +-- with the semantics of the target type. +-- See Note [Word/Int underflow/overflow] +mapLitValue :: DynFlags -> (Integer -> Integer) -> Literal -> Literal +mapLitValue _ f (LitChar c) = mkLitChar (fchar c) + where fchar = chr . fromInteger . f . toInteger . ord +mapLitValue dflags f (LitNumber nt i t) = wrapLitNumber dflags + (LitNumber nt (f i) t) +mapLitValue _ _ l = pprPanic "mapLitValue" (ppr l) + +-- | Indicate if the `Literal` contains an 'Integer' value, e.g. 'Char', +-- 'Int', 'Word', 'LitInteger' and 'LitNatural'. +isLitValue :: Literal -> Bool +isLitValue = isJust . isLitValue_maybe + +{- + Coercions + ~~~~~~~~~ +-} + +narrow8IntLit, narrow16IntLit, narrow32IntLit, + narrow8WordLit, narrow16WordLit, narrow32WordLit, + char2IntLit, int2CharLit, + float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit, + float2DoubleLit, double2FloatLit + :: Literal -> Literal + +word2IntLit, int2WordLit :: DynFlags -> Literal -> Literal +word2IntLit dflags (LitNumber LitNumWord w _) + -- Map Word range [max_int+1, max_word] + -- to Int range [min_int , -1] + -- Range [0,max_int] has the same representation with both Int and Word + | w > tARGET_MAX_INT dflags = mkLitInt dflags (w - tARGET_MAX_WORD dflags - 1) + | otherwise = mkLitInt dflags w +word2IntLit _ l = pprPanic "word2IntLit" (ppr l) + +int2WordLit dflags (LitNumber LitNumInt i _) + -- Map Int range [min_int , -1] + -- to Word range [max_int+1, max_word] + -- Range [0,max_int] has the same representation with both Int and Word + | i < 0 = mkLitWord dflags (1 + tARGET_MAX_WORD dflags + i) + | otherwise = mkLitWord dflags i +int2WordLit _ l = pprPanic "int2WordLit" (ppr l) + +-- | Narrow a literal number (unchecked result range) +narrowLit :: forall a. Integral a => Proxy a -> Literal -> Literal +narrowLit _ (LitNumber nt i t) = LitNumber nt (toInteger (fromInteger i :: a)) t +narrowLit _ l = pprPanic "narrowLit" (ppr l) + +narrow8IntLit = narrowLit (Proxy :: Proxy Int8) +narrow16IntLit = narrowLit (Proxy :: Proxy Int16) +narrow32IntLit = narrowLit (Proxy :: Proxy Int32) +narrow8WordLit = narrowLit (Proxy :: Proxy Word8) +narrow16WordLit = narrowLit (Proxy :: Proxy Word16) +narrow32WordLit = narrowLit (Proxy :: Proxy Word32) + +char2IntLit (LitChar c) = mkLitIntUnchecked (toInteger (ord c)) +char2IntLit l = pprPanic "char2IntLit" (ppr l) +int2CharLit (LitNumber _ i _) = LitChar (chr (fromInteger i)) +int2CharLit l = pprPanic "int2CharLit" (ppr l) + +float2IntLit (LitFloat f) = mkLitIntUnchecked (truncate f) +float2IntLit l = pprPanic "float2IntLit" (ppr l) +int2FloatLit (LitNumber _ i _) = LitFloat (fromInteger i) +int2FloatLit l = pprPanic "int2FloatLit" (ppr l) + +double2IntLit (LitDouble f) = mkLitIntUnchecked (truncate f) +double2IntLit l = pprPanic "double2IntLit" (ppr l) +int2DoubleLit (LitNumber _ i _) = LitDouble (fromInteger i) +int2DoubleLit l = pprPanic "int2DoubleLit" (ppr l) + +float2DoubleLit (LitFloat f) = LitDouble f +float2DoubleLit l = pprPanic "float2DoubleLit" (ppr l) +double2FloatLit (LitDouble d) = LitFloat d +double2FloatLit l = pprPanic "double2FloatLit" (ppr l) + +nullAddrLit :: Literal +nullAddrLit = LitNullAddr + +-- | A nonsense literal of type @forall (a :: 'TYPE' 'UnliftedRep'). a@. +rubbishLit :: Literal +rubbishLit = LitRubbish + +{- + Predicates + ~~~~~~~~~~ +-} + +-- | True if there is absolutely no penalty to duplicating the literal. +-- False principally of strings. +-- +-- "Why?", you say? I'm glad you asked. Well, for one duplicating strings would +-- blow up code sizes. Not only this, it's also unsafe. +-- +-- Consider a program that wants to traverse a string. One way it might do this +-- is to first compute the Addr# pointing to the end of the string, and then, +-- starting from the beginning, bump a pointer using eqAddr# to determine the +-- end. For instance, +-- +-- @ +-- -- Given pointers to the start and end of a string, count how many zeros +-- -- the string contains. +-- countZeros :: Addr# -> Addr# -> -> Int +-- countZeros start end = go start 0 +-- where +-- go off n +-- | off `addrEq#` end = n +-- | otherwise = go (off `plusAddr#` 1) n' +-- where n' | isTrue# (indexInt8OffAddr# off 0# ==# 0#) = n + 1 +-- | otherwise = n +-- @ +-- +-- Consider what happens if we considered strings to be trivial (and therefore +-- duplicable) and emitted a call like @countZeros "hello"# ("hello"# +-- `plusAddr`# 5)@. The beginning and end pointers do not belong to the same +-- string, meaning that an iteration like the above would blow up terribly. +-- This is what happened in #12757. +-- +-- Ultimately the solution here is to make primitive strings a bit more +-- structured, ensuring that the compiler can't inline in ways that will break +-- user code. One approach to this is described in #8472. +litIsTrivial :: Literal -> Bool +-- c.f. CoreUtils.exprIsTrivial +litIsTrivial (LitString _) = False +litIsTrivial (LitNumber nt _ _) = case nt of + LitNumInteger -> False + LitNumNatural -> False + LitNumInt -> True + LitNumInt64 -> True + LitNumWord -> True + LitNumWord64 -> True +litIsTrivial _ = True + +-- | True if code space does not go bad if we duplicate this literal +litIsDupable :: DynFlags -> Literal -> Bool +-- c.f. CoreUtils.exprIsDupable +litIsDupable _ (LitString _) = False +litIsDupable dflags (LitNumber nt i _) = case nt of + LitNumInteger -> inIntRange dflags i + LitNumNatural -> inIntRange dflags i + LitNumInt -> True + LitNumInt64 -> True + LitNumWord -> True + LitNumWord64 -> True +litIsDupable _ _ = True + +litFitsInChar :: Literal -> Bool +litFitsInChar (LitNumber _ i _) = i >= toInteger (ord minBound) + && i <= toInteger (ord maxBound) +litFitsInChar _ = False + +litIsLifted :: Literal -> Bool +litIsLifted (LitNumber nt _ _) = case nt of + LitNumInteger -> True + LitNumNatural -> True + LitNumInt -> False + LitNumInt64 -> False + LitNumWord -> False + LitNumWord64 -> False +litIsLifted _ = False + +{- + Types + ~~~~~ +-} + +-- | Find the Haskell 'Type' the literal occupies +literalType :: Literal -> Type +literalType LitNullAddr = addrPrimTy +literalType (LitChar _) = charPrimTy +literalType (LitString _) = addrPrimTy +literalType (LitFloat _) = floatPrimTy +literalType (LitDouble _) = doublePrimTy +literalType (LitLabel _ _ _) = addrPrimTy +literalType (LitNumber _ _ t) = t +literalType (LitRubbish) = mkForAllTy a Inferred (mkTyVarTy a) + where + a = alphaTyVarUnliftedRep + +absentLiteralOf :: TyCon -> Maybe Literal +-- Return a literal of the appropriate primitive +-- TyCon, to use as a placeholder when it doesn't matter +-- Rubbish literals are handled in WwLib, because +-- 1. Looking at the TyCon is not enough, we need the actual type +-- 2. This would need to return a type application to a literal +absentLiteralOf tc = lookupUFM absent_lits (tyConName tc) + +absent_lits :: UniqFM Literal +absent_lits = listToUFM [ (addrPrimTyConKey, LitNullAddr) + , (charPrimTyConKey, LitChar 'x') + , (intPrimTyConKey, mkLitIntUnchecked 0) + , (int64PrimTyConKey, mkLitInt64Unchecked 0) + , (wordPrimTyConKey, mkLitWordUnchecked 0) + , (word64PrimTyConKey, mkLitWord64Unchecked 0) + , (floatPrimTyConKey, LitFloat 0) + , (doublePrimTyConKey, LitDouble 0) + ] + +{- + Comparison + ~~~~~~~~~~ +-} + +cmpLit :: Literal -> Literal -> Ordering +cmpLit (LitChar a) (LitChar b) = a `compare` b +cmpLit (LitString a) (LitString b) = a `compare` b +cmpLit (LitNullAddr) (LitNullAddr) = EQ +cmpLit (LitFloat a) (LitFloat b) = a `compare` b +cmpLit (LitDouble a) (LitDouble b) = a `compare` b +cmpLit (LitLabel a _ _) (LitLabel b _ _) = a `compare` b +cmpLit (LitNumber nt1 a _) (LitNumber nt2 b _) + | nt1 == nt2 = a `compare` b + | otherwise = nt1 `compare` nt2 +cmpLit (LitRubbish) (LitRubbish) = EQ +cmpLit lit1 lit2 + | litTag lit1 < litTag lit2 = LT + | otherwise = GT + +litTag :: Literal -> Int +litTag (LitChar _) = 1 +litTag (LitString _) = 2 +litTag (LitNullAddr) = 3 +litTag (LitFloat _) = 4 +litTag (LitDouble _) = 5 +litTag (LitLabel _ _ _) = 6 +litTag (LitNumber {}) = 7 +litTag (LitRubbish) = 8 + +{- + Printing + ~~~~~~~~ +* See Note [Printing of literals in Core] +-} + +pprLiteral :: (SDoc -> SDoc) -> Literal -> SDoc +pprLiteral _ (LitChar c) = pprPrimChar c +pprLiteral _ (LitString s) = pprHsBytes s +pprLiteral _ (LitNullAddr) = text "__NULL" +pprLiteral _ (LitFloat f) = float (fromRat f) <> primFloatSuffix +pprLiteral _ (LitDouble d) = double (fromRat d) <> primDoubleSuffix +pprLiteral add_par (LitNumber nt i _) + = case nt of + LitNumInteger -> pprIntegerVal add_par i + LitNumNatural -> pprIntegerVal add_par i + LitNumInt -> pprPrimInt i + LitNumInt64 -> pprPrimInt64 i + LitNumWord -> pprPrimWord i + LitNumWord64 -> pprPrimWord64 i +pprLiteral add_par (LitLabel l mb fod) = + add_par (text "__label" <+> b <+> ppr fod) + where b = case mb of + Nothing -> pprHsString l + Just x -> doubleQuotes (text (unpackFS l ++ '@':show x)) +pprLiteral _ (LitRubbish) = text "__RUBBISH" + +pprIntegerVal :: (SDoc -> SDoc) -> Integer -> SDoc +-- See Note [Printing of literals in Core]. +pprIntegerVal add_par i | i < 0 = add_par (integer i) + | otherwise = integer i + +{- +Note [Printing of literals in Core] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The function `add_par` is used to wrap parenthesis around negative integers +(`LitInteger`) and labels (`LitLabel`), if they occur in a context requiring +an atomic thing (for example function application). + +Although not all Core literals would be valid Haskell, we are trying to stay +as close as possible to Haskell syntax in the printing of Core, to make it +easier for a Haskell user to read Core. + +To that end: + * We do print parenthesis around negative `LitInteger`, because we print + `LitInteger` using plain number literals (no prefix or suffix), and plain + number literals in Haskell require parenthesis in contexts like function + application (i.e. `1 - -1` is not valid Haskell). + + * We don't print parenthesis around other (negative) literals, because they + aren't needed in GHC/Haskell either (i.e. `1# -# -1#` is accepted by GHC's + parser). + +Literal Output Output if context requires + an atom (if different) +------- ------- ---------------------- +LitChar 'a'# +LitString "aaa"# +LitNullAddr "__NULL" +LitInt -1# +LitInt64 -1L# +LitWord 1## +LitWord64 1L## +LitFloat -1.0# +LitDouble -1.0## +LitInteger -1 (-1) +LitLabel "__label" ... ("__label" ...) +LitRubbish "__RUBBISH" + +Note [Rubbish literals] +~~~~~~~~~~~~~~~~~~~~~~~ +During worker/wrapper after demand analysis, where an argument +is unused (absent) we do the following w/w split (supposing that +y is absent): + + f x y z = e +===> + f x y z = $wf x z + $wf x z = let y = + in e + +Usually the binding for y is ultimately optimised away, and +even if not it should never be evaluated -- but that's the +way the w/w split starts off. + +What is ? +* For lifted values can be a call to 'error'. +* For primitive types like Int# or Word# we can use any random + value of that type. +* But what about /unlifted/ but /boxed/ types like MutVar# or + Array#? We need a literal value of that type. + +That is 'LitRubbish'. Since we need a rubbish literal for +many boxed, unlifted types, we say that LitRubbish has type + LitRubbish :: forall (a :: TYPE UnliftedRep). a + +So we might see a w/w split like + $wf x z = let y :: Array# Int = LitRubbish @(Array# Int) + in e + +Recall that (TYPE UnliftedRep) is the kind of boxed, unlifted +heap pointers. + +Here are the moving parts: + +* We define LitRubbish as a constructor in Literal.Literal + +* It is given its polymoprhic type by Literal.literalType + +* WwLib.mk_absent_let introduces a LitRubbish for absent + arguments of boxed, unlifted type. + +* In CoreToSTG we convert (RubishLit @t) to just (). STG is + untyped, so it doesn't matter that it points to a lifted + value. The important thing is that it is a heap pointer, + which the garbage collector can follow if it encounters it. + + We considered maintaining LitRubbish in STG, and lowering + it in the code genreators, but it seems simpler to do it + once and for all in CoreToSTG. + + In ByteCodeAsm we just lower it as a 0 literal, because + it's all boxed and lifted to the host GC anyway. +-} diff --git a/compiler/basicTypes/MkId.hs b/compiler/basicTypes/MkId.hs new file mode 100644 --- /dev/null +++ b/compiler/basicTypes/MkId.hs @@ -0,0 +1,1666 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1998 + + +This module contains definitions for the IdInfo for things that +have a standard form, namely: + +- data constructors +- record selectors +- method and superclass selectors +- primitive operations +-} + +{-# LANGUAGE CPP #-} + +module MkId ( + mkDictFunId, mkDictFunTy, mkDictSelId, mkDictSelRhs, + + mkPrimOpId, mkFCallId, + + unwrapNewTypeBody, wrapFamInstBody, + DataConBoxer(..), mkDataConRep, mkDataConWorkId, + + -- And some particular Ids; see below for why they are wired in + wiredInIds, ghcPrimIds, + unsafeCoerceName, unsafeCoerceId, realWorldPrimId, + voidPrimId, voidArgId, + nullAddrId, seqId, lazyId, lazyIdKey, + coercionTokenId, magicDictId, coerceId, + proxyHashId, noinlineId, noinlineIdName, + + -- Re-export error Ids + module PrelRules + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import Rules +import TysPrim +import TysWiredIn +import PrelRules +import Type +import FamInstEnv +import Coercion +import TcType +import MkCore +import CoreUtils ( exprType, mkCast ) +import CoreUnfold +import Literal +import TyCon +import Class +import NameSet +import Name +import PrimOp +import ForeignCall +import DataCon +import Id +import IdInfo +import Demand +import CoreSyn +import Unique +import UniqSupply +import PrelNames +import BasicTypes hiding ( SuccessFlag(..) ) +import Util +import Pair +import DynFlags +import Outputable +import FastString +import ListSetOps +import qualified GHC.LanguageExtensions as LangExt + +import Data.Maybe ( maybeToList ) + +{- +************************************************************************ +* * +\subsection{Wired in Ids} +* * +************************************************************************ + +Note [Wired-in Ids] +~~~~~~~~~~~~~~~~~~~ +A "wired-in" Id can be referred to directly in GHC (e.g. 'voidPrimId') +rather than by looking it up its name in some environment or fetching +it from an interface file. + +There are several reasons why an Id might appear in the wiredInIds: + +* ghcPrimIds: see Note [ghcPrimIds (aka pseudoops)] + +* magicIds: see Note [magicIds] + +* errorIds, defined in coreSyn/MkCore.hs. + These error functions (e.g. rUNTIME_ERROR_ID) are wired in + because the desugarer generates code that mentions them directly + +In all cases except ghcPrimIds, there is a definition site in a +library module, which may be called (e.g. in higher order situations); +but the wired-in version means that the details are never read from +that module's interface file; instead, the full definition is right +here. + +Note [ghcPrimIds (aka pseudoops)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The ghcPrimIds + + * Are exported from GHC.Prim + + * Can't be defined in Haskell, and hence no Haskell binding site, + but have perfectly reasonable unfoldings in Core + + * Either have a CompulsoryUnfolding (hence always inlined), or + of an EvaldUnfolding and void representation (e.g. void#) + + * Are (or should be) defined in primops.txt.pp as 'pseudoop' + Reason: that's how we generate documentation for them + +Note [magicIds] +~~~~~~~~~~~~~~~ +The magicIds + + * Are exported from GHC.Magic + + * Can be defined in Haskell (and are, in ghc-prim:GHC/Magic.hs). + This definition at least generates Haddock documentation for them. + + * May or may not have a CompulsoryUnfolding. + + * But have some special behaviour that can't be done via an + unfolding from an interface file +-} + +wiredInIds :: [Id] +wiredInIds + = magicIds + ++ ghcPrimIds + ++ errorIds -- Defined in MkCore + +magicIds :: [Id] -- See Note [magicIds] +magicIds = [lazyId, oneShotId, noinlineId] + +ghcPrimIds :: [Id] -- See Note [ghcPrimIds (aka pseudoops)] +ghcPrimIds + = [ realWorldPrimId + , voidPrimId + , unsafeCoerceId + , nullAddrId + , seqId + , magicDictId + , coerceId + , proxyHashId + ] + +{- +************************************************************************ +* * +\subsection{Data constructors} +* * +************************************************************************ + +The wrapper for a constructor is an ordinary top-level binding that evaluates +any strict args, unboxes any args that are going to be flattened, and calls +the worker. + +We're going to build a constructor that looks like: + + data (Data a, C b) => T a b = T1 !a !Int b + + T1 = /\ a b -> + \d1::Data a, d2::C b -> + \p q r -> case p of { p -> + case q of { q -> + Con T1 [a,b] [p,q,r]}} + +Notice that + +* d2 is thrown away --- a context in a data decl is used to make sure + one *could* construct dictionaries at the site the constructor + is used, but the dictionary isn't actually used. + +* We have to check that we can construct Data dictionaries for + the types a and Int. Once we've done that we can throw d1 away too. + +* We use (case p of q -> ...) to evaluate p, rather than "seq" because + all that matters is that the arguments are evaluated. "seq" is + very careful to preserve evaluation order, which we don't need + to be here. + + You might think that we could simply give constructors some strictness + info, like PrimOps, and let CoreToStg do the let-to-case transformation. + But we don't do that because in the case of primops and functions strictness + is a *property* not a *requirement*. In the case of constructors we need to + do something active to evaluate the argument. + + Making an explicit case expression allows the simplifier to eliminate + it in the (common) case where the constructor arg is already evaluated. + +Note [Wrappers for data instance tycons] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the case of data instances, the wrapper also applies the coercion turning +the representation type into the family instance type to cast the result of +the wrapper. For example, consider the declarations + + data family Map k :: * -> * + data instance Map (a, b) v = MapPair (Map a (Pair b v)) + +The tycon to which the datacon MapPair belongs gets a unique internal +name of the form :R123Map, and we call it the representation tycon. +In contrast, Map is the family tycon (accessible via +tyConFamInst_maybe). A coercion allows you to move between +representation and family type. It is accessible from :R123Map via +tyConFamilyCoercion_maybe and has kind + + Co123Map a b v :: {Map (a, b) v ~ :R123Map a b v} + +The wrapper and worker of MapPair get the types + + -- Wrapper + $WMapPair :: forall a b v. Map a (Map a b v) -> Map (a, b) v + $WMapPair a b v = MapPair a b v `cast` sym (Co123Map a b v) + + -- Worker + MapPair :: forall a b v. Map a (Map a b v) -> :R123Map a b v + +This coercion is conditionally applied by wrapFamInstBody. + +It's a bit more complicated if the data instance is a GADT as well! + + data instance T [a] where + T1 :: forall b. b -> T [Maybe b] + +Hence we translate to + + -- Wrapper + $WT1 :: forall b. b -> T [Maybe b] + $WT1 b v = T1 (Maybe b) b (Maybe b) v + `cast` sym (Co7T (Maybe b)) + + -- Worker + T1 :: forall c b. (c ~ Maybe b) => b -> :R7T c + + -- Coercion from family type to representation type + Co7T a :: T [a] ~ :R7T a + +Newtype instances through an additional wrinkle into the mix. Consider the +following example (adapted from #15318, comment:2): + + data family T a + newtype instance T [a] = MkT [a] + +Within the newtype instance, there are three distinct types at play: + +1. The newtype's underlying type, [a]. +2. The instance's representation type, TList a (where TList is the + representation tycon). +3. The family type, T [a]. + +We need two coercions in order to cast from (1) to (3): + +(a) A newtype coercion axiom: + + axiom coTList a :: TList a ~ [a] + + (Where TList is the representation tycon of the newtype instance.) + +(b) A data family instance coercion axiom: + + axiom coT a :: T [a] ~ TList a + +When we translate the newtype instance to Core, we obtain: + + -- Wrapper + $WMkT :: forall a. [a] -> T [a] + $WMkT a x = MkT a x |> Sym (coT a) + + -- Worker + MkT :: forall a. [a] -> TList [a] + MkT a x = x |> Sym (coTList a) + +Unlike for data instances, the worker for a newtype instance is actually an +executable function which expands to a cast, but otherwise, the general +strategy is essentially the same as for data instances. Also note that we have +a wrapper, which is unusual for a newtype, but we make GHC produce one anyway +for symmetry with the way data instances are handled. + +Note [Newtype datacons] +~~~~~~~~~~~~~~~~~~~~~~~ +The "data constructor" for a newtype should always be vanilla. At one +point this wasn't true, because the newtype arising from + class C a => D a +looked like + newtype T:D a = D:D (C a) +so the data constructor for T:C had a single argument, namely the +predicate (C a). But now we treat that as an ordinary argument, not +part of the theta-type, so all is well. + +Note [Compulsory newtype unfolding] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Newtype wrappers, just like workers, have compulsory unfoldings. +This is needed so that two optimizations involving newtypes have the same +effect whether a wrapper is present or not: + +(1) Case-of-known constructor. + See Note [beta-reduction in exprIsConApp_maybe]. + +(2) Matching against the map/coerce RULE. Suppose we have the RULE + + {-# RULE "map/coerce" map coerce = ... #-} + + As described in Note [Getting the map/coerce RULE to work], + the occurrence of 'coerce' is transformed into: + + {-# RULE "map/coerce" forall (c :: T1 ~R# T2). + map ((\v -> v) `cast` c) = ... #-} + + We'd like 'map Age' to match the LHS. For this to happen, Age + must be unfolded, otherwise we'll be stuck. This is tested in T16208. + +************************************************************************ +* * +\subsection{Dictionary selectors} +* * +************************************************************************ + +Selecting a field for a dictionary. If there is just one field, then +there's nothing to do. + +Dictionary selectors may get nested forall-types. Thus: + + class Foo a where + op :: forall b. Ord b => a -> b -> b + +Then the top-level type for op is + + op :: forall a. Foo a => + forall b. Ord b => + a -> b -> b + +-} + +mkDictSelId :: Name -- Name of one of the *value* selectors + -- (dictionary superclass or method) + -> Class -> Id +mkDictSelId name clas + = mkGlobalId (ClassOpId clas) name sel_ty info + where + tycon = classTyCon clas + sel_names = map idName (classAllSelIds clas) + new_tycon = isNewTyCon tycon + [data_con] = tyConDataCons tycon + tyvars = dataConUserTyVarBinders data_con + n_ty_args = length tyvars + arg_tys = dataConRepArgTys data_con -- Includes the dictionary superclasses + val_index = assoc "MkId.mkDictSelId" (sel_names `zip` [0..]) name + + sel_ty = mkForAllTys tyvars $ + mkInvisFunTy (mkClassPred clas (mkTyVarTys (binderVars tyvars))) $ + getNth arg_tys val_index + + base_info = noCafIdInfo + `setArityInfo` 1 + `setStrictnessInfo` strict_sig + `setLevityInfoWithType` sel_ty + + info | new_tycon + = base_info `setInlinePragInfo` alwaysInlinePragma + `setUnfoldingInfo` mkInlineUnfoldingWithArity 1 + (mkDictSelRhs clas val_index) + -- See Note [Single-method classes] in TcInstDcls + -- for why alwaysInlinePragma + + | otherwise + = base_info `setRuleInfo` mkRuleInfo [rule] + -- Add a magic BuiltinRule, but no unfolding + -- so that the rule is always available to fire. + -- See Note [ClassOp/DFun selection] in TcInstDcls + + -- This is the built-in rule that goes + -- op (dfT d1 d2) ---> opT d1 d2 + rule = BuiltinRule { ru_name = fsLit "Class op " `appendFS` + occNameFS (getOccName name) + , ru_fn = name + , ru_nargs = n_ty_args + 1 + , ru_try = dictSelRule val_index n_ty_args } + + -- The strictness signature is of the form U(AAAVAAAA) -> T + -- where the V depends on which item we are selecting + -- It's worth giving one, so that absence info etc is generated + -- even if the selector isn't inlined + + strict_sig = mkClosedStrictSig [arg_dmd] topRes + arg_dmd | new_tycon = evalDmd + | otherwise = mkManyUsedDmd $ + mkProdDmd [ if name == sel_name then evalDmd else absDmd + | sel_name <- sel_names ] + +mkDictSelRhs :: Class + -> Int -- 0-indexed selector among (superclasses ++ methods) + -> CoreExpr +mkDictSelRhs clas val_index + = mkLams tyvars (Lam dict_id rhs_body) + where + tycon = classTyCon clas + new_tycon = isNewTyCon tycon + [data_con] = tyConDataCons tycon + tyvars = dataConUnivTyVars data_con + arg_tys = dataConRepArgTys data_con -- Includes the dictionary superclasses + + the_arg_id = getNth arg_ids val_index + pred = mkClassPred clas (mkTyVarTys tyvars) + dict_id = mkTemplateLocal 1 pred + arg_ids = mkTemplateLocalsNum 2 arg_tys + + rhs_body | new_tycon = unwrapNewTypeBody tycon (mkTyVarTys tyvars) + (Var dict_id) + | otherwise = Case (Var dict_id) dict_id (idType the_arg_id) + [(DataAlt data_con, arg_ids, varToCoreExpr the_arg_id)] + -- varToCoreExpr needed for equality superclass selectors + -- sel a b d = case x of { MkC _ (g:a~b) _ -> CO g } + +dictSelRule :: Int -> Arity -> RuleFun +-- Tries to persuade the argument to look like a constructor +-- application, using exprIsConApp_maybe, and then selects +-- from it +-- sel_i t1..tk (D t1..tk op1 ... opm) = opi +-- +dictSelRule val_index n_ty_args _ id_unf _ args + | (dict_arg : _) <- drop n_ty_args args + , Just (_, floats, _, _, con_args) <- exprIsConApp_maybe id_unf dict_arg + = Just (wrapFloats floats $ getNth con_args val_index) + | otherwise + = Nothing + +{- +************************************************************************ +* * + Data constructors +* * +************************************************************************ +-} + +mkDataConWorkId :: Name -> DataCon -> Id +mkDataConWorkId wkr_name data_con + | isNewTyCon tycon + = mkGlobalId (DataConWrapId data_con) wkr_name wkr_ty nt_work_info + | otherwise + = mkGlobalId (DataConWorkId data_con) wkr_name wkr_ty alg_wkr_info + + where + tycon = dataConTyCon data_con -- The representation TyCon + wkr_ty = dataConRepType data_con + + ----------- Workers for data types -------------- + alg_wkr_info = noCafIdInfo + `setArityInfo` wkr_arity + `setStrictnessInfo` wkr_sig + `setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated, + -- even if arity = 0 + `setLevityInfoWithType` wkr_ty + -- NB: unboxed tuples have workers, so we can't use + -- setNeverLevPoly + + wkr_arity = dataConRepArity data_con + wkr_sig = mkClosedStrictSig (replicate wkr_arity topDmd) (dataConCPR data_con) + -- Note [Data-con worker strictness] + -- Notice that we do *not* say the worker Id is strict + -- even if the data constructor is declared strict + -- e.g. data T = MkT !(Int,Int) + -- Why? Because the *wrapper* $WMkT is strict (and its unfolding has + -- case expressions that do the evals) but the *worker* MkT itself is + -- not. If we pretend it is strict then when we see + -- case x of y -> MkT y + -- the simplifier thinks that y is "sure to be evaluated" (because + -- the worker MkT is strict) and drops the case. No, the workerId + -- MkT is not strict. + -- + -- However, the worker does have StrictnessMarks. When the simplifier + -- sees a pattern + -- case e of MkT x -> ... + -- it uses the dataConRepStrictness of MkT to mark x as evaluated; + -- but that's fine... dataConRepStrictness comes from the data con + -- not from the worker Id. + + ----------- Workers for newtypes -------------- + univ_tvs = dataConUnivTyVars data_con + arg_tys = dataConRepArgTys data_con -- Should be same as dataConOrigArgTys + nt_work_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo + `setArityInfo` 1 -- Arity 1 + `setInlinePragInfo` alwaysInlinePragma + `setUnfoldingInfo` newtype_unf + `setLevityInfoWithType` wkr_ty + id_arg1 = mkTemplateLocal 1 (head arg_tys) + res_ty_args = mkTyCoVarTys univ_tvs + newtype_unf = ASSERT2( isVanillaDataCon data_con && + isSingleton arg_tys + , ppr data_con ) + -- Note [Newtype datacons] + mkCompulsoryUnfolding $ + mkLams univ_tvs $ Lam id_arg1 $ + wrapNewTypeBody tycon res_ty_args (Var id_arg1) + +dataConCPR :: DataCon -> DmdResult +dataConCPR con + | isDataTyCon tycon -- Real data types only; that is, + -- not unboxed tuples or newtypes + , null (dataConExTyCoVars con) -- No existentials + , wkr_arity > 0 + , wkr_arity <= mAX_CPR_SIZE + = if is_prod then vanillaCprProdRes (dataConRepArity con) + else cprSumRes (dataConTag con) + | otherwise + = topRes + where + is_prod = isProductTyCon tycon + tycon = dataConTyCon con + wkr_arity = dataConRepArity con + + mAX_CPR_SIZE :: Arity + mAX_CPR_SIZE = 10 + -- We do not treat very big tuples as CPR-ish: + -- a) for a start we get into trouble because there aren't + -- "enough" unboxed tuple types (a tiresome restriction, + -- but hard to fix), + -- b) more importantly, big unboxed tuples get returned mainly + -- on the stack, and are often then allocated in the heap + -- by the caller. So doing CPR for them may in fact make + -- things worse. + +{- +------------------------------------------------- +-- Data constructor representation +-- +-- This is where we decide how to wrap/unwrap the +-- constructor fields +-- +-------------------------------------------------- +-} + +type Unboxer = Var -> UniqSM ([Var], CoreExpr -> CoreExpr) + -- Unbox: bind rep vars by decomposing src var + +data Boxer = UnitBox | Boxer (TCvSubst -> UniqSM ([Var], CoreExpr)) + -- Box: build src arg using these rep vars + +-- | Data Constructor Boxer +newtype DataConBoxer = DCB ([Type] -> [Var] -> UniqSM ([Var], [CoreBind])) + -- Bind these src-level vars, returning the + -- rep-level vars to bind in the pattern + +{- +Note [Inline partially-applied constructor wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We allow the wrapper to inline when partially applied to avoid +boxing values unnecessarily. For example, consider + + data Foo a = Foo !Int a + + instance Traversable Foo where + traverse f (Foo i a) = Foo i <$> f a + +This desugars to + + traverse f foo = case foo of + Foo i# a -> let i = I# i# + in map ($WFoo i) (f a) + +If the wrapper `$WFoo` is not inlined, we get a fruitless reboxing of `i`. +But if we inline the wrapper, we get + + map (\a. case i of I# i# a -> Foo i# a) (f a) + +and now case-of-known-constructor eliminates the redundant allocation. +-} + +mkDataConRep :: DynFlags + -> FamInstEnvs + -> Name + -> Maybe [HsImplBang] + -- See Note [Bangs on imported data constructors] + -> DataCon + -> UniqSM DataConRep +mkDataConRep dflags fam_envs wrap_name mb_bangs data_con + | not wrapper_reqd + = return NoDataConRep + + | otherwise + = do { wrap_args <- mapM newLocal wrap_arg_tys + ; wrap_body <- mk_rep_app (wrap_args `zip` dropList eq_spec unboxers) + initial_wrap_app + + ; let wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty wrap_info + wrap_info = noCafIdInfo + `setArityInfo` wrap_arity + -- It's important to specify the arity, so that partial + -- applications are treated as values + `setInlinePragInfo` wrap_prag + `setUnfoldingInfo` wrap_unf + `setStrictnessInfo` wrap_sig + -- We need to get the CAF info right here because TidyPgm + -- does not tidy the IdInfo of implicit bindings (like the wrapper) + -- so it not make sure that the CAF info is sane + `setNeverLevPoly` wrap_ty + + wrap_sig = mkClosedStrictSig wrap_arg_dmds (dataConCPR data_con) + + wrap_arg_dmds = + replicate (length theta) topDmd ++ map mk_dmd arg_ibangs + -- Don't forget the dictionary arguments when building + -- the strictness signature (#14290). + + mk_dmd str | isBanged str = evalDmd + | otherwise = topDmd + + wrap_prag = alwaysInlinePragma `setInlinePragmaActivation` + activeDuringFinal + -- See Note [Activation for data constructor wrappers] + + -- The wrapper will usually be inlined (see wrap_unf), so its + -- strictness and CPR info is usually irrelevant. But this is + -- not always the case; GHC may choose not to inline it. In + -- particular, the wrapper constructor is not inlined inside + -- an INLINE rhs or when it is not applied to any arguments. + -- See Note [Inline partially-applied constructor wrappers] + -- Passing Nothing here allows the wrapper to inline when + -- unsaturated. + wrap_unf | isNewTyCon tycon = mkCompulsoryUnfolding wrap_rhs + -- See Note [Compulsory newtype unfolding] + | otherwise = mkInlineUnfolding wrap_rhs + wrap_rhs = mkLams wrap_tvs $ + mkLams wrap_args $ + wrapFamInstBody tycon res_ty_args $ + wrap_body + + ; return (DCR { dcr_wrap_id = wrap_id + , dcr_boxer = mk_boxer boxers + , dcr_arg_tys = rep_tys + , dcr_stricts = rep_strs + -- For newtypes, dcr_bangs is always [HsLazy]. + -- See Note [HsImplBangs for newtypes]. + , dcr_bangs = arg_ibangs }) } + + where + (univ_tvs, ex_tvs, eq_spec, theta, orig_arg_tys, _orig_res_ty) + = dataConFullSig data_con + wrap_tvs = dataConUserTyVars data_con + res_ty_args = substTyVars (mkTvSubstPrs (map eqSpecPair eq_spec)) univ_tvs + + tycon = dataConTyCon data_con -- The representation TyCon (not family) + wrap_ty = dataConUserType data_con + ev_tys = eqSpecPreds eq_spec ++ theta + all_arg_tys = ev_tys ++ orig_arg_tys + ev_ibangs = map (const HsLazy) ev_tys + orig_bangs = dataConSrcBangs data_con + + wrap_arg_tys = theta ++ orig_arg_tys + wrap_arity = count isCoVar ex_tvs + length wrap_arg_tys + -- The wrap_args are the arguments *other than* the eq_spec + -- Because we are going to apply the eq_spec args manually in the + -- wrapper + + new_tycon = isNewTyCon tycon + arg_ibangs + | new_tycon + = ASSERT( isSingleton orig_arg_tys ) + [HsLazy] -- See Note [HsImplBangs for newtypes] + | otherwise + = case mb_bangs of + Nothing -> zipWith (dataConSrcToImplBang dflags fam_envs) + orig_arg_tys orig_bangs + Just bangs -> bangs + + (rep_tys_w_strs, wrappers) + = unzip (zipWith dataConArgRep all_arg_tys (ev_ibangs ++ arg_ibangs)) + + (unboxers, boxers) = unzip wrappers + (rep_tys, rep_strs) = unzip (concat rep_tys_w_strs) + + wrapper_reqd = + (not new_tycon + -- (Most) newtypes have only a worker, with the exception + -- of some newtypes written with GADT syntax. See below. + && (any isBanged (ev_ibangs ++ arg_ibangs) + -- Some forcing/unboxing (includes eq_spec) + || (not $ null eq_spec))) -- GADT + || isFamInstTyCon tycon -- Cast result + || dataConUserTyVarsArePermuted data_con + -- If the data type was written with GADT syntax and + -- orders the type variables differently from what the + -- worker expects, it needs a data con wrapper to reorder + -- the type variables. + -- See Note [Data con wrappers and GADT syntax]. + + initial_wrap_app = Var (dataConWorkId data_con) + `mkTyApps` res_ty_args + `mkVarApps` ex_tvs + `mkCoApps` map (mkReflCo Nominal . eqSpecType) eq_spec + + mk_boxer :: [Boxer] -> DataConBoxer + mk_boxer boxers = DCB (\ ty_args src_vars -> + do { let (ex_vars, term_vars) = splitAtList ex_tvs src_vars + subst1 = zipTvSubst univ_tvs ty_args + subst2 = extendTCvSubstList subst1 ex_tvs + (mkTyCoVarTys ex_vars) + ; (rep_ids, binds) <- go subst2 boxers term_vars + ; return (ex_vars ++ rep_ids, binds) } ) + + go _ [] src_vars = ASSERT2( null src_vars, ppr data_con ) return ([], []) + go subst (UnitBox : boxers) (src_var : src_vars) + = do { (rep_ids2, binds) <- go subst boxers src_vars + ; return (src_var : rep_ids2, binds) } + go subst (Boxer boxer : boxers) (src_var : src_vars) + = do { (rep_ids1, arg) <- boxer subst + ; (rep_ids2, binds) <- go subst boxers src_vars + ; return (rep_ids1 ++ rep_ids2, NonRec src_var arg : binds) } + go _ (_:_) [] = pprPanic "mk_boxer" (ppr data_con) + + mk_rep_app :: [(Id,Unboxer)] -> CoreExpr -> UniqSM CoreExpr + mk_rep_app [] con_app + = return con_app + mk_rep_app ((wrap_arg, unboxer) : prs) con_app + = do { (rep_ids, unbox_fn) <- unboxer wrap_arg + ; expr <- mk_rep_app prs (mkVarApps con_app rep_ids) + ; return (unbox_fn expr) } + +{- Note [Activation for data constructor wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The Activation on a data constructor wrapper allows it to inline only in Phase +0. This way rules have a chance to fire if they mention a data constructor on +the left + RULE "foo" f (K a b) = ... +Since the LHS of rules are simplified with InitialPhase, we won't +inline the wrapper on the LHS either. + +On the other hand, this means that exprIsConApp_maybe must be able to deal +with wrappers so that case-of-constructor is not delayed; see +Note [exprIsConApp_maybe on data constructors with wrappers] for details. + +It used to activate in phases 2 (afterInitial) and later, but it makes it +awkward to write a RULE[1] with a constructor on the left: it would work if a +constructor has no wrapper, but whether a constructor has a wrapper depends, for +instance, on the order of type argument of that constructors. Therefore changing +the order of type argument could make previously working RULEs fail. + +See also https://gitlab.haskell.org/ghc/ghc/issues/15840 . + + +Note [Bangs on imported data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We pass Maybe [HsImplBang] to mkDataConRep to make use of HsImplBangs +from imported modules. + +- Nothing <=> use HsSrcBangs +- Just bangs <=> use HsImplBangs + +For imported types we can't work it all out from the HsSrcBangs, +because we want to be very sure to follow what the original module +(where the data type was declared) decided, and that depends on what +flags were enabled when it was compiled. So we record the decisions in +the interface file. + +The HsImplBangs passed are in 1-1 correspondence with the +dataConOrigArgTys of the DataCon. + +Note [Data con wrappers and unlifted types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T = MkT !Int# + +We certainly do not want to make a wrapper + $WMkT x = case x of y { DEFAULT -> MkT y } + +For a start, it's still to generate a no-op. But worse, since wrappers +are currently injected at TidyCore, we don't even optimise it away! +So the stupid case expression stays there. This actually happened for +the Integer data type (see #1600 comment:66)! + +Note [Data con wrappers and GADT syntax] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider these two very similar data types: + + data T1 a b = MkT1 b + + data T2 a b where + MkT2 :: forall b a. b -> T2 a b + +Despite their similar appearance, T2 will have a data con wrapper but T1 will +not. What sets them apart? The types of their constructors, which are: + + MkT1 :: forall a b. b -> T1 a b + MkT2 :: forall b a. b -> T2 a b + +MkT2's use of GADT syntax allows it to permute the order in which `a` and `b` +would normally appear. See Note [DataCon user type variable binders] in DataCon +for further discussion on this topic. + +The worker data cons for T1 and T2, however, both have types such that `a` is +expected to come before `b` as arguments. Because MkT2 permutes this order, it +needs a data con wrapper to swizzle around the type variables to be in the +order the worker expects. + +A somewhat surprising consequence of this is that *newtypes* can have data con +wrappers! After all, a newtype can also be written with GADT syntax: + + newtype T3 a b where + MkT3 :: forall b a. b -> T3 a b + +Again, this needs a wrapper data con to reorder the type variables. It does +mean that this newtype constructor requires another level of indirection when +being called, but the inliner should make swift work of that. + +Note [HsImplBangs for newtypes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Most of the time, we use the dataConSrctoImplBang function to decide what +strictness/unpackedness to use for the fields of a data type constructor. But +there is an exception to this rule: newtype constructors. You might not think +that newtypes would pose a challenge, since newtypes are seemingly forbidden +from having strictness annotations in the first place. But consider this +(from #16141): + + {-# LANGUAGE StrictData #-} + {-# OPTIONS_GHC -O #-} + newtype T a b where + MkT :: forall b a. Int -> T a b + +Because StrictData (plus optimization) is enabled, invoking +dataConSrcToImplBang would sneak in and unpack the field of type Int to Int#! +This would be disastrous, since the wrapper for `MkT` uses a coercion involving +Int, not Int#. + +Bottom line: dataConSrcToImplBang should never be invoked for newtypes. In the +case of a newtype constructor, we simply hardcode its dcr_bangs field to +[HsLazy]. +-} + +------------------------- +newLocal :: Type -> UniqSM Var +newLocal ty = do { uniq <- getUniqueM + ; return (mkSysLocalOrCoVar (fsLit "dt") uniq ty) } + +-- | Unpack/Strictness decisions from source module. +-- +-- This function should only ever be invoked for data constructor fields, and +-- never on the field of a newtype constructor. +-- See @Note [HsImplBangs for newtypes]@. +dataConSrcToImplBang + :: DynFlags + -> FamInstEnvs + -> Type + -> HsSrcBang + -> HsImplBang + +dataConSrcToImplBang dflags fam_envs arg_ty + (HsSrcBang ann unpk NoSrcStrict) + | xopt LangExt.StrictData dflags -- StrictData => strict field + = dataConSrcToImplBang dflags fam_envs arg_ty + (HsSrcBang ann unpk SrcStrict) + | otherwise -- no StrictData => lazy field + = HsLazy + +dataConSrcToImplBang _ _ _ (HsSrcBang _ _ SrcLazy) + = HsLazy + +dataConSrcToImplBang dflags fam_envs arg_ty + (HsSrcBang _ unpk_prag SrcStrict) + | isUnliftedType arg_ty + = HsLazy -- For !Int#, say, use HsLazy + -- See Note [Data con wrappers and unlifted types] + + | not (gopt Opt_OmitInterfacePragmas dflags) -- Don't unpack if -fomit-iface-pragmas + -- Don't unpack if we aren't optimising; rather arbitrarily, + -- we use -fomit-iface-pragmas as the indication + , let mb_co = topNormaliseType_maybe fam_envs arg_ty + -- Unwrap type families and newtypes + arg_ty' = case mb_co of { Just (_,ty) -> ty; Nothing -> arg_ty } + , isUnpackableType dflags fam_envs arg_ty' + , (rep_tys, _) <- dataConArgUnpack arg_ty' + , case unpk_prag of + NoSrcUnpack -> + gopt Opt_UnboxStrictFields dflags + || (gopt Opt_UnboxSmallStrictFields dflags + && rep_tys `lengthAtMost` 1) -- See Note [Unpack one-wide fields] + srcUnpack -> isSrcUnpacked srcUnpack + = case mb_co of + Nothing -> HsUnpack Nothing + Just (co,_) -> HsUnpack (Just co) + + | otherwise -- Record the strict-but-no-unpack decision + = HsStrict + + +-- | Wrappers/Workers and representation following Unpack/Strictness +-- decisions +dataConArgRep + :: Type + -> HsImplBang + -> ([(Type,StrictnessMark)] -- Rep types + ,(Unboxer,Boxer)) + +dataConArgRep arg_ty HsLazy + = ([(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer)) + +dataConArgRep arg_ty HsStrict + = ([(arg_ty, MarkedStrict)], (seqUnboxer, unitBoxer)) + +dataConArgRep arg_ty (HsUnpack Nothing) + | (rep_tys, wrappers) <- dataConArgUnpack arg_ty + = (rep_tys, wrappers) + +dataConArgRep _ (HsUnpack (Just co)) + | let co_rep_ty = pSnd (coercionKind co) + , (rep_tys, wrappers) <- dataConArgUnpack co_rep_ty + = (rep_tys, wrapCo co co_rep_ty wrappers) + + +------------------------- +wrapCo :: Coercion -> Type -> (Unboxer, Boxer) -> (Unboxer, Boxer) +wrapCo co rep_ty (unbox_rep, box_rep) -- co :: arg_ty ~ rep_ty + = (unboxer, boxer) + where + unboxer arg_id = do { rep_id <- newLocal rep_ty + ; (rep_ids, rep_fn) <- unbox_rep rep_id + ; let co_bind = NonRec rep_id (Var arg_id `Cast` co) + ; return (rep_ids, Let co_bind . rep_fn) } + boxer = Boxer $ \ subst -> + do { (rep_ids, rep_expr) + <- case box_rep of + UnitBox -> do { rep_id <- newLocal (TcType.substTy subst rep_ty) + ; return ([rep_id], Var rep_id) } + Boxer boxer -> boxer subst + ; let sco = substCoUnchecked subst co + ; return (rep_ids, rep_expr `Cast` mkSymCo sco) } + +------------------------ +seqUnboxer :: Unboxer +seqUnboxer v = return ([v], \e -> Case (Var v) v (exprType e) [(DEFAULT, [], e)]) + +unitUnboxer :: Unboxer +unitUnboxer v = return ([v], \e -> e) + +unitBoxer :: Boxer +unitBoxer = UnitBox + +------------------------- +dataConArgUnpack + :: Type + -> ( [(Type, StrictnessMark)] -- Rep types + , (Unboxer, Boxer) ) + +dataConArgUnpack arg_ty + | Just (tc, tc_args) <- splitTyConApp_maybe arg_ty + , Just con <- tyConSingleAlgDataCon_maybe tc + -- NB: check for an *algebraic* data type + -- A recursive newtype might mean that + -- 'arg_ty' is a newtype + , let rep_tys = dataConInstArgTys con tc_args + = ASSERT( null (dataConExTyCoVars con) ) + -- Note [Unpacking GADTs and existentials] + ( rep_tys `zip` dataConRepStrictness con + ,( \ arg_id -> + do { rep_ids <- mapM newLocal rep_tys + ; let unbox_fn body + = Case (Var arg_id) arg_id (exprType body) + [(DataAlt con, rep_ids, body)] + ; return (rep_ids, unbox_fn) } + , Boxer $ \ subst -> + do { rep_ids <- mapM (newLocal . TcType.substTyUnchecked subst) rep_tys + ; return (rep_ids, Var (dataConWorkId con) + `mkTyApps` (substTysUnchecked subst tc_args) + `mkVarApps` rep_ids ) } ) ) + | otherwise + = pprPanic "dataConArgUnpack" (ppr arg_ty) + -- An interface file specified Unpacked, but we couldn't unpack it + +isUnpackableType :: DynFlags -> FamInstEnvs -> Type -> Bool +-- True if we can unpack the UNPACK the argument type +-- See Note [Recursive unboxing] +-- We look "deeply" inside rather than relying on the DataCons +-- we encounter on the way, because otherwise we might well +-- end up relying on ourselves! +isUnpackableType dflags fam_envs ty + | Just data_con <- unpackable_type ty + = ok_con_args emptyNameSet data_con + | otherwise + = False + where + ok_con_args dcs con + | dc_name `elemNameSet` dcs + = False + | otherwise + = all (ok_arg dcs') + (dataConOrigArgTys con `zip` dataConSrcBangs con) + -- NB: dataConSrcBangs gives the *user* request; + -- We'd get a black hole if we used dataConImplBangs + where + dc_name = getName con + dcs' = dcs `extendNameSet` dc_name + + ok_arg dcs (ty, bang) + = not (attempt_unpack bang) || ok_ty dcs norm_ty + where + norm_ty = topNormaliseType fam_envs ty + + ok_ty dcs ty + | Just data_con <- unpackable_type ty + = ok_con_args dcs data_con + | otherwise + = True -- NB True here, in contrast to False at top level + + attempt_unpack (HsSrcBang _ SrcUnpack NoSrcStrict) + = xopt LangExt.StrictData dflags + attempt_unpack (HsSrcBang _ SrcUnpack SrcStrict) + = True + attempt_unpack (HsSrcBang _ NoSrcUnpack SrcStrict) + = True -- Be conservative + attempt_unpack (HsSrcBang _ NoSrcUnpack NoSrcStrict) + = xopt LangExt.StrictData dflags -- Be conservative + attempt_unpack _ = False + + unpackable_type :: Type -> Maybe DataCon + -- Works just on a single level + unpackable_type ty + | Just (tc, _) <- splitTyConApp_maybe ty + , Just data_con <- tyConSingleAlgDataCon_maybe tc + , null (dataConExTyCoVars data_con) + -- See Note [Unpacking GADTs and existentials] + = Just data_con + | otherwise + = Nothing + +{- +Note [Unpacking GADTs and existentials] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There is nothing stopping us unpacking a data type with equality +components, like + data Equal a b where + Equal :: Equal a a + +And it'd be fine to unpack a product type with existential components +too, but that would require a bit more plumbing, so currently we don't. + +So for now we require: null (dataConExTyCoVars data_con) +See #14978 + +Note [Unpack one-wide fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The flag UnboxSmallStrictFields ensures that any field that can +(safely) be unboxed to a word-sized unboxed field, should be so unboxed. +For example: + + data A = A Int# + newtype B = B A + data C = C !B + data D = D !C + data E = E !() + data F = F !D + data G = G !F !F + +All of these should have an Int# as their representation, except +G which should have two Int#s. + +However + + data T = T !(S Int) + data S = S !a + +Here we can represent T with an Int#. + +Note [Recursive unboxing] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data R = MkR {-# UNPACK #-} !S Int + data S = MkS {-# UNPACK #-} !Int +The representation arguments of MkR are the *representation* arguments +of S (plus Int); the rep args of MkS are Int#. This is all fine. + +But be careful not to try to unbox this! + data T = MkT {-# UNPACK #-} !T Int +Because then we'd get an infinite number of arguments. + +Here is a more complicated case: + data S = MkS {-# UNPACK #-} !T Int + data T = MkT {-# UNPACK #-} !S Int +Each of S and T must decide independently whether to unpack +and they had better not both say yes. So they must both say no. + +Also behave conservatively when there is no UNPACK pragma + data T = MkS !T Int +with -funbox-strict-fields or -funbox-small-strict-fields +we need to behave as if there was an UNPACK pragma there. + +But it's the *argument* type that matters. This is fine: + data S = MkS S !Int +because Int is non-recursive. + +************************************************************************ +* * + Wrapping and unwrapping newtypes and type families +* * +************************************************************************ +-} + +wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr +-- The wrapper for the data constructor for a newtype looks like this: +-- newtype T a = MkT (a,Int) +-- MkT :: forall a. (a,Int) -> T a +-- MkT = /\a. \(x:(a,Int)). x `cast` sym (CoT a) +-- where CoT is the coercion TyCon associated with the newtype +-- +-- The call (wrapNewTypeBody T [a] e) returns the +-- body of the wrapper, namely +-- e `cast` (CoT [a]) +-- +-- If a coercion constructor is provided in the newtype, then we use +-- it, otherwise the wrap/unwrap are both no-ops + +wrapNewTypeBody tycon args result_expr + = ASSERT( isNewTyCon tycon ) + mkCast result_expr (mkSymCo co) + where + co = mkUnbranchedAxInstCo Representational (newTyConCo tycon) args [] + +-- When unwrapping, we do *not* apply any family coercion, because this will +-- be done via a CoPat by the type checker. We have to do it this way as +-- computing the right type arguments for the coercion requires more than just +-- a spliting operation (cf, TcPat.tcConPat). + +unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr +unwrapNewTypeBody tycon args result_expr + = ASSERT( isNewTyCon tycon ) + mkCast result_expr (mkUnbranchedAxInstCo Representational (newTyConCo tycon) args []) + +-- If the type constructor is a representation type of a data instance, wrap +-- the expression into a cast adjusting the expression type, which is an +-- instance of the representation type, to the corresponding instance of the +-- family instance type. +-- See Note [Wrappers for data instance tycons] +wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr +wrapFamInstBody tycon args body + | Just co_con <- tyConFamilyCoercion_maybe tycon + = mkCast body (mkSymCo (mkUnbranchedAxInstCo Representational co_con args [])) + | otherwise + = body + +{- +************************************************************************ +* * +\subsection{Primitive operations} +* * +************************************************************************ +-} + +mkPrimOpId :: PrimOp -> Id +mkPrimOpId prim_op + = id + where + (tyvars,arg_tys,res_ty, arity, strict_sig) = primOpSig prim_op + ty = mkSpecForAllTys tyvars (mkVisFunTys arg_tys res_ty) + name = mkWiredInName gHC_PRIM (primOpOcc prim_op) + (mkPrimOpIdUnique (primOpTag prim_op)) + (AnId id) UserSyntax + id = mkGlobalId (PrimOpId prim_op) name ty info + + info = noCafIdInfo + `setRuleInfo` mkRuleInfo (maybeToList $ primOpRules name prim_op) + `setArityInfo` arity + `setStrictnessInfo` strict_sig + `setInlinePragInfo` neverInlinePragma + `setLevityInfoWithType` res_ty + -- We give PrimOps a NOINLINE pragma so that we don't + -- get silly warnings from Desugar.dsRule (the inline_shadows_rule + -- test) about a RULE conflicting with a possible inlining + -- cf #7287 + +-- For each ccall we manufacture a separate CCallOpId, giving it +-- a fresh unique, a type that is correct for this particular ccall, +-- and a CCall structure that gives the correct details about calling +-- convention etc. +-- +-- The *name* of this Id is a local name whose OccName gives the full +-- details of the ccall, type and all. This means that the interface +-- file reader can reconstruct a suitable Id + +mkFCallId :: DynFlags -> Unique -> ForeignCall -> Type -> Id +mkFCallId dflags uniq fcall ty + = ASSERT( noFreeVarsOfType ty ) + -- A CCallOpId should have no free type variables; + -- when doing substitutions won't substitute over it + mkGlobalId (FCallId fcall) name ty info + where + occ_str = showSDoc dflags (braces (ppr fcall <+> ppr ty)) + -- The "occurrence name" of a ccall is the full info about the + -- ccall; it is encoded, but may have embedded spaces etc! + + name = mkFCallName uniq occ_str + + info = noCafIdInfo + `setArityInfo` arity + `setStrictnessInfo` strict_sig + `setLevityInfoWithType` ty + + (bndrs, _) = tcSplitPiTys ty + arity = count isAnonTyCoBinder bndrs + strict_sig = mkClosedStrictSig (replicate arity topDmd) topRes + -- the call does not claim to be strict in its arguments, since they + -- may be lifted (foreign import prim) and the called code doesn't + -- necessarily force them. See #11076. +{- +************************************************************************ +* * +\subsection{DictFuns and default methods} +* * +************************************************************************ + +Note [Dict funs and default methods] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Dict funs and default methods are *not* ImplicitIds. Their definition +involves user-written code, so we can't figure out their strictness etc +based on fixed info, as we can for constructors and record selectors (say). + +NB: See also Note [Exported LocalIds] in Id +-} + +mkDictFunId :: Name -- Name to use for the dict fun; + -> [TyVar] + -> ThetaType + -> Class + -> [Type] + -> Id +-- Implements the DFun Superclass Invariant (see TcInstDcls) +-- See Note [Dict funs and default methods] + +mkDictFunId dfun_name tvs theta clas tys + = mkExportedLocalId (DFunId is_nt) + dfun_name + dfun_ty + where + is_nt = isNewTyCon (classTyCon clas) + dfun_ty = mkDictFunTy tvs theta clas tys + +mkDictFunTy :: [TyVar] -> ThetaType -> Class -> [Type] -> Type +mkDictFunTy tvs theta clas tys + = mkSpecSigmaTy tvs theta (mkClassPred clas tys) + +{- +************************************************************************ +* * +\subsection{Un-definable} +* * +************************************************************************ + +These Ids can't be defined in Haskell. They could be defined in +unfoldings in the wired-in GHC.Prim interface file, but we'd have to +ensure that they were definitely, definitely inlined, because there is +no curried identifier for them. That's what mkCompulsoryUnfolding +does. If we had a way to get a compulsory unfolding from an interface +file, we could do that, but we don't right now. + +unsafeCoerce# isn't so much a PrimOp as a phantom identifier, that +just gets expanded into a type coercion wherever it occurs. Hence we +add it as a built-in Id with an unfolding here. + +The type variables we use here are "open" type variables: this means +they can unify with both unlifted and lifted types. Hence we provide +another gun with which to shoot yourself in the foot. +-} + +unsafeCoerceName, nullAddrName, seqName, + realWorldName, voidPrimIdName, coercionTokenName, + magicDictName, coerceName, proxyName :: Name +unsafeCoerceName = mkWiredInIdName gHC_PRIM (fsLit "unsafeCoerce#") unsafeCoerceIdKey unsafeCoerceId +nullAddrName = mkWiredInIdName gHC_PRIM (fsLit "nullAddr#") nullAddrIdKey nullAddrId +seqName = mkWiredInIdName gHC_PRIM (fsLit "seq") seqIdKey seqId +realWorldName = mkWiredInIdName gHC_PRIM (fsLit "realWorld#") realWorldPrimIdKey realWorldPrimId +voidPrimIdName = mkWiredInIdName gHC_PRIM (fsLit "void#") voidPrimIdKey voidPrimId +coercionTokenName = mkWiredInIdName gHC_PRIM (fsLit "coercionToken#") coercionTokenIdKey coercionTokenId +magicDictName = mkWiredInIdName gHC_PRIM (fsLit "magicDict") magicDictKey magicDictId +coerceName = mkWiredInIdName gHC_PRIM (fsLit "coerce") coerceKey coerceId +proxyName = mkWiredInIdName gHC_PRIM (fsLit "proxy#") proxyHashKey proxyHashId + +lazyIdName, oneShotName, noinlineIdName :: Name +lazyIdName = mkWiredInIdName gHC_MAGIC (fsLit "lazy") lazyIdKey lazyId +oneShotName = mkWiredInIdName gHC_MAGIC (fsLit "oneShot") oneShotKey oneShotId +noinlineIdName = mkWiredInIdName gHC_MAGIC (fsLit "noinline") noinlineIdKey noinlineId + +------------------------------------------------ +proxyHashId :: Id +proxyHashId + = pcMiscPrelId proxyName ty + (noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings] + `setNeverLevPoly` ty ) + where + -- proxy# :: forall {k} (a:k). Proxy# k a + -- + -- The visibility of the `k` binder is Inferred to match the type of the + -- Proxy data constructor (#16293). + [kv,tv] = mkTemplateKiTyVars [liftedTypeKind] id + kv_ty = mkTyVarTy kv + tv_ty = mkTyVarTy tv + ty = mkInvForAllTy kv $ mkSpecForAllTy tv $ mkProxyPrimTy kv_ty tv_ty + +------------------------------------------------ +unsafeCoerceId :: Id +unsafeCoerceId + = pcMiscPrelId unsafeCoerceName ty info + where + info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma + `setUnfoldingInfo` mkCompulsoryUnfolding rhs + + -- unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) + -- (a :: TYPE r1) (b :: TYPE r2). + -- a -> b + bndrs = mkTemplateKiTyVars [runtimeRepTy, runtimeRepTy] + (\ks -> map tYPE ks) + + [_, _, a, b] = mkTyVarTys bndrs + + ty = mkSpecForAllTys bndrs (mkVisFunTy a b) + + [x] = mkTemplateLocals [a] + rhs = mkLams (bndrs ++ [x]) $ + Cast (Var x) (mkUnsafeCo Representational a b) + +------------------------------------------------ +nullAddrId :: Id +-- nullAddr# :: Addr# +-- The reason it is here is because we don't provide +-- a way to write this literal in Haskell. +nullAddrId = pcMiscPrelId nullAddrName addrPrimTy info + where + info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma + `setUnfoldingInfo` mkCompulsoryUnfolding (Lit nullAddrLit) + `setNeverLevPoly` addrPrimTy + +------------------------------------------------ +seqId :: Id -- See Note [seqId magic] +seqId = pcMiscPrelId seqName ty info + where + info = noCafIdInfo `setInlinePragInfo` inline_prag + `setUnfoldingInfo` mkCompulsoryUnfolding rhs + `setNeverLevPoly` ty + + inline_prag + = alwaysInlinePragma `setInlinePragmaActivation` ActiveAfter + NoSourceText 0 + -- Make 'seq' not inline-always, so that simpleOptExpr + -- (see CoreSubst.simple_app) won't inline 'seq' on the + -- LHS of rules. That way we can have rules for 'seq'; + -- see Note [seqId magic] + + ty = mkSpecForAllTys [alphaTyVar,betaTyVar] + (mkVisFunTy alphaTy (mkVisFunTy betaTy betaTy)) + + [x,y] = mkTemplateLocals [alphaTy, betaTy] + rhs = mkLams [alphaTyVar,betaTyVar,x,y] (Case (Var x) x betaTy [(DEFAULT, [], Var y)]) + +------------------------------------------------ +lazyId :: Id -- See Note [lazyId magic] +lazyId = pcMiscPrelId lazyIdName ty info + where + info = noCafIdInfo `setNeverLevPoly` ty + ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTy alphaTy alphaTy) + +noinlineId :: Id -- See Note [noinlineId magic] +noinlineId = pcMiscPrelId noinlineIdName ty info + where + info = noCafIdInfo `setNeverLevPoly` ty + ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTy alphaTy alphaTy) + +oneShotId :: Id -- See Note [The oneShot function] +oneShotId = pcMiscPrelId oneShotName ty info + where + info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma + `setUnfoldingInfo` mkCompulsoryUnfolding rhs + ty = mkSpecForAllTys [ runtimeRep1TyVar, runtimeRep2TyVar + , openAlphaTyVar, openBetaTyVar ] + (mkVisFunTy fun_ty fun_ty) + fun_ty = mkVisFunTy openAlphaTy openBetaTy + [body, x] = mkTemplateLocals [fun_ty, openAlphaTy] + x' = setOneShotLambda x -- Here is the magic bit! + rhs = mkLams [ runtimeRep1TyVar, runtimeRep2TyVar + , openAlphaTyVar, openBetaTyVar + , body, x'] $ + Var body `App` Var x + +-------------------------------------------------------------------------------- +magicDictId :: Id -- See Note [magicDictId magic] +magicDictId = pcMiscPrelId magicDictName ty info + where + info = noCafIdInfo `setInlinePragInfo` neverInlinePragma + `setNeverLevPoly` ty + ty = mkSpecForAllTys [alphaTyVar] alphaTy + +-------------------------------------------------------------------------------- + +coerceId :: Id +coerceId = pcMiscPrelId coerceName ty info + where + info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma + `setUnfoldingInfo` mkCompulsoryUnfolding rhs + `setNeverLevPoly` ty + eqRTy = mkTyConApp coercibleTyCon [ liftedTypeKind + , alphaTy, betaTy ] + eqRPrimTy = mkTyConApp eqReprPrimTyCon [ liftedTypeKind + , liftedTypeKind + , alphaTy, betaTy ] + ty = mkSpecForAllTys [alphaTyVar, betaTyVar] $ + mkInvisFunTy eqRTy $ + mkVisFunTy alphaTy betaTy + + [eqR,x,eq] = mkTemplateLocals [eqRTy, alphaTy, eqRPrimTy] + rhs = mkLams [alphaTyVar, betaTyVar, eqR, x] $ + mkWildCase (Var eqR) eqRTy betaTy $ + [(DataAlt coercibleDataCon, [eq], Cast (Var x) (mkCoVarCo eq))] + +{- +Note [Unsafe coerce magic] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +We define a *primitive* + GHC.Prim.unsafeCoerce# +and then in the base library we define the ordinary function + Unsafe.Coerce.unsafeCoerce :: forall (a:*) (b:*). a -> b + unsafeCoerce x = unsafeCoerce# x + +Notice that unsafeCoerce has a civilized (albeit still dangerous) +polymorphic type, whose type args have kind *. So you can't use it on +unboxed values (unsafeCoerce 3#). + +In contrast unsafeCoerce# is even more dangerous because you *can* use +it on unboxed things, (unsafeCoerce# 3#) :: Int. Its type is + forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) (a: TYPE r1) (b: TYPE r2). a -> b + +Note [seqId magic] +~~~~~~~~~~~~~~~~~~ +'GHC.Prim.seq' is special in several ways. + +a) In source Haskell its second arg can have an unboxed type + x `seq` (v +# w) + But see Note [Typing rule for seq] in TcExpr, which + explains why we give seq itself an ordinary type + seq :: forall a b. a -> b -> b + and treat it as a language construct from a typing point of view. + +b) Its fixity is set in LoadIface.ghcPrimIface + +c) It has quite a bit of desugaring magic. + See DsUtils.hs Note [Desugaring seq (1)] and (2) and (3) + +d) There is some special rule handing: Note [User-defined RULES for seq] + +Note [User-defined RULES for seq] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Roman found situations where he had + case (f n) of _ -> e +where he knew that f (which was strict in n) would terminate if n did. +Notice that the result of (f n) is discarded. So it makes sense to +transform to + case n of _ -> e + +Rather than attempt some general analysis to support this, I've added +enough support that you can do this using a rewrite rule: + + RULE "f/seq" forall n. seq (f n) = seq n + +You write that rule. When GHC sees a case expression that discards +its result, it mentally transforms it to a call to 'seq' and looks for +a RULE. (This is done in Simplify.trySeqRules.) As usual, the +correctness of the rule is up to you. + +VERY IMPORTANT: to make this work, we give the RULE an arity of 1, not 2. +If we wrote + RULE "f/seq" forall n e. seq (f n) e = seq n e +with rule arity 2, then two bad things would happen: + + - The magical desugaring done in Note [seqId magic] item (c) + for saturated application of 'seq' would turn the LHS into + a case expression! + + - The code in Simplify.rebuildCase would need to actually supply + the value argument, which turns out to be awkward. + +Note [lazyId magic] +~~~~~~~~~~~~~~~~~~~ +lazy :: forall a?. a? -> a? (i.e. works for unboxed types too) + +'lazy' is used to make sure that a sub-expression, and its free variables, +are truly used call-by-need, with no code motion. Key examples: + +* pseq: pseq a b = a `seq` lazy b + We want to make sure that the free vars of 'b' are not evaluated + before 'a', even though the expression is plainly strict in 'b'. + +* catch: catch a b = catch# (lazy a) b + Again, it's clear that 'a' will be evaluated strictly (and indeed + applied to a state token) but we want to make sure that any exceptions + arising from the evaluation of 'a' are caught by the catch (see + #11555). + +Implementing 'lazy' is a bit tricky: + +* It must not have a strictness signature: by being a built-in Id, + all the info about lazyId comes from here, not from GHC.Base.hi. + This is important, because the strictness analyser will spot it as + strict! + +* It must not have an unfolding: it gets "inlined" by a HACK in + CorePrep. It's very important to do this inlining *after* unfoldings + are exposed in the interface file. Otherwise, the unfolding for + (say) pseq in the interface file will not mention 'lazy', so if we + inline 'pseq' we'll totally miss the very thing that 'lazy' was + there for in the first place. See #3259 for a real world + example. + +* Suppose CorePrep sees (catch# (lazy e) b). At all costs we must + avoid using call by value here: + case e of r -> catch# r b + Avoiding that is the whole point of 'lazy'. So in CorePrep (which + generate the 'case' expression for a call-by-value call) we must + spot the 'lazy' on the arg (in CorePrep.cpeApp), and build a 'let' + instead. + +* lazyId is defined in GHC.Base, so we don't *have* to inline it. If it + appears un-applied, we'll end up just calling it. + +Note [noinlineId magic] +~~~~~~~~~~~~~~~~~~~~~~~ +noinline :: forall a. a -> a + +'noinline' is used to make sure that a function f is never inlined, +e.g., as in 'noinline f x'. Ordinarily, the identity function with NOINLINE +could be used to achieve this effect; however, this has the unfortunate +result of leaving a (useless) call to noinline at runtime. So we have +a little bit of magic to optimize away 'noinline' after we are done +running the simplifier. + +'noinline' needs to be wired-in because it gets inserted automatically +when we serialize an expression to the interface format. See +Note [Inlining and hs-boot files] in ToIface + +Note [The oneShot function] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the context of making left-folds fuse somewhat okish (see ticket #7994 +and Note [Left folds via right fold]) it was determined that it would be useful +if library authors could explicitly tell the compiler that a certain lambda is +called at most once. The oneShot function allows that. + +'oneShot' is levity-polymorphic, i.e. the type variables can refer to unlifted +types as well (#10744); e.g. + oneShot (\x:Int# -> x +# 1#) + +Like most magic functions it has a compulsory unfolding, so there is no need +for a real definition somewhere. We have one in GHC.Magic for the convenience +of putting the documentation there. + +It uses `setOneShotLambda` on the lambda's binder. That is the whole magic: + +A typical call looks like + oneShot (\y. e) +after unfolding the definition `oneShot = \f \x[oneshot]. f x` we get + (\f \x[oneshot]. f x) (\y. e) + --> \x[oneshot]. ((\y.e) x) + --> \x[oneshot] e[x/y] +which is what we want. + +It is only effective if the one-shot info survives as long as possible; in +particular it must make it into the interface in unfoldings. See Note [Preserve +OneShotInfo] in CoreTidy. + +Also see https://gitlab.haskell.org/ghc/ghc/wikis/one-shot. + + +Note [magicDictId magic] +~~~~~~~~~~~~~~~~~~~~~~~~~ +The identifier `magicDict` is just a place-holder, which is used to +implement a primitive that we cannot define in Haskell but we can write +in Core. It is declared with a place-holder type: + + magicDict :: forall a. a + +The intention is that the identifier will be used in a very specific way, +to create dictionaries for classes with a single method. Consider a class +like this: + + class C a where + f :: T a + +We are going to use `magicDict`, in conjunction with a built-in Prelude +rule, to cast values of type `T a` into dictionaries for `C a`. To do +this, we define a function like this in the library: + + data WrapC a b = WrapC (C a => Proxy a -> b) + + withT :: (C a => Proxy a -> b) + -> T a -> Proxy a -> b + withT f x y = magicDict (WrapC f) x y + +The purpose of `WrapC` is to avoid having `f` instantiated. +Also, it avoids impredicativity, because `magicDict`'s type +cannot be instantiated with a forall. The field of `WrapC` contains +a `Proxy` parameter which is used to link the type of the constraint, +`C a`, with the type of the `Wrap` value being made. + +Next, we add a built-in Prelude rule (see prelude/PrelRules.hs), +which will replace the RHS of this definition with the appropriate +definition in Core. The rewrite rule works as follows: + + magicDict @t (wrap @a @b f) x y +----> + f (x `cast` co a) y + +The `co` coercion is the newtype-coercion extracted from the type-class. +The type class is obtain by looking at the type of wrap. + + +------------------------------------------------------------- +@realWorld#@ used to be a magic literal, \tr{void#}. If things get +nasty as-is, change it back to a literal (@Literal@). + +voidArgId is a Local Id used simply as an argument in functions +where we just want an arg to avoid having a thunk of unlifted type. +E.g. + x = \ void :: Void# -> (# p, q #) + +This comes up in strictness analysis + +Note [evaldUnfoldings] +~~~~~~~~~~~~~~~~~~~~~~ +The evaldUnfolding makes it look that some primitive value is +evaluated, which in turn makes Simplify.interestingArg return True, +which in turn makes INLINE things applied to said value likely to be +inlined. +-} + +realWorldPrimId :: Id -- :: State# RealWorld +realWorldPrimId = pcMiscPrelId realWorldName realWorldStatePrimTy + (noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings] + `setOneShotInfo` stateHackOneShot + `setNeverLevPoly` realWorldStatePrimTy) + +voidPrimId :: Id -- Global constant :: Void# +voidPrimId = pcMiscPrelId voidPrimIdName voidPrimTy + (noCafIdInfo `setUnfoldingInfo` evaldUnfolding -- Note [evaldUnfoldings] + `setNeverLevPoly` voidPrimTy) + +voidArgId :: Id -- Local lambda-bound :: Void# +voidArgId = mkSysLocal (fsLit "void") voidArgIdKey voidPrimTy + +coercionTokenId :: Id -- :: () ~ () +coercionTokenId -- Used to replace Coercion terms when we go to STG + = pcMiscPrelId coercionTokenName + (mkTyConApp eqPrimTyCon [liftedTypeKind, liftedTypeKind, unitTy, unitTy]) + noCafIdInfo + +pcMiscPrelId :: Name -> Type -> IdInfo -> Id +pcMiscPrelId name ty info + = mkVanillaGlobalWithInfo name ty info + -- We lie and say the thing is imported; otherwise, we get into + -- a mess with dependency analysis; e.g., core2stg may heave in + -- random calls to GHCbase.unpackPS__. If GHCbase is the module + -- being compiled, then it's just a matter of luck if the definition + -- will be in "the right place" to be in scope. diff --git a/compiler/basicTypes/MkId.hs-boot b/compiler/basicTypes/MkId.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/basicTypes/MkId.hs-boot @@ -0,0 +1,15 @@ +module MkId where +import Name( Name ) +import Var( Id ) +import Class( Class ) +import {-# SOURCE #-} DataCon( DataCon ) +import {-# SOURCE #-} PrimOp( PrimOp ) + +data DataConBoxer + +mkDataConWorkId :: Name -> DataCon -> Id +mkDictSelId :: Name -> Class -> Id + +mkPrimOpId :: PrimOp -> Id + +magicDictId :: Id diff --git a/compiler/basicTypes/Module.hs b/compiler/basicTypes/Module.hs new file mode 100644 --- /dev/null +++ b/compiler/basicTypes/Module.hs @@ -0,0 +1,1303 @@ +{- +(c) The University of Glasgow, 2004-2006 + + +Module +~~~~~~~~~~ +Simply the name of a module, represented as a FastString. +These are Uniquable, hence we can build Maps with Modules as +the keys. +-} + +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Module + ( + -- * The ModuleName type + ModuleName, + pprModuleName, + moduleNameFS, + moduleNameString, + moduleNameSlashes, moduleNameColons, + moduleStableString, + moduleFreeHoles, + moduleIsDefinite, + mkModuleName, + mkModuleNameFS, + stableModuleNameCmp, + + -- * The UnitId type + ComponentId(..), + UnitId(..), + unitIdFS, + unitIdKey, + IndefUnitId(..), + IndefModule(..), + indefUnitIdToUnitId, + indefModuleToModule, + InstalledUnitId(..), + toInstalledUnitId, + ShHoleSubst, + + unitIdIsDefinite, + unitIdString, + unitIdFreeHoles, + + newUnitId, + newIndefUnitId, + newSimpleUnitId, + hashUnitId, + fsToUnitId, + stringToUnitId, + stableUnitIdCmp, + + -- * HOLE renaming + renameHoleUnitId, + renameHoleModule, + renameHoleUnitId', + renameHoleModule', + + -- * Generalization + splitModuleInsts, + splitUnitIdInsts, + generalizeIndefUnitId, + generalizeIndefModule, + + -- * Parsers + parseModuleName, + parseUnitId, + parseComponentId, + parseModuleId, + parseModSubst, + + -- * Wired-in UnitIds + -- $wired_in_packages + primUnitId, + integerUnitId, + baseUnitId, + rtsUnitId, + thUnitId, + mainUnitId, + thisGhcUnitId, + isHoleModule, + interactiveUnitId, isInteractiveModule, + wiredInUnitIds, + + -- * The Module type + Module(Module), + moduleUnitId, moduleName, + pprModule, + mkModule, + mkHoleModule, + stableModuleCmp, + HasModule(..), + ContainsModule(..), + + -- * Installed unit ids and modules + InstalledModule(..), + InstalledModuleEnv, + installedModuleEq, + installedUnitIdEq, + installedUnitIdString, + fsToInstalledUnitId, + componentIdToInstalledUnitId, + stringToInstalledUnitId, + emptyInstalledModuleEnv, + lookupInstalledModuleEnv, + extendInstalledModuleEnv, + filterInstalledModuleEnv, + delInstalledModuleEnv, + DefUnitId(..), + + -- * The ModuleLocation type + ModLocation(..), + addBootSuffix, addBootSuffix_maybe, + addBootSuffixLocn, addBootSuffixLocnOut, + + -- * Module mappings + ModuleEnv, + elemModuleEnv, extendModuleEnv, extendModuleEnvList, + extendModuleEnvList_C, plusModuleEnv_C, + delModuleEnvList, delModuleEnv, plusModuleEnv, lookupModuleEnv, + lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv, + moduleEnvKeys, moduleEnvElts, moduleEnvToList, + unitModuleEnv, isEmptyModuleEnv, + extendModuleEnvWith, filterModuleEnv, + + -- * ModuleName mappings + ModuleNameEnv, DModuleNameEnv, + + -- * Sets of Modules + ModuleSet, + emptyModuleSet, mkModuleSet, moduleSetElts, + extendModuleSet, extendModuleSetList, delModuleSet, + elemModuleSet, intersectModuleSet, minusModuleSet, unionModuleSet, + unitModuleSet + ) where + +import GhcPrelude + +import Outputable +import Unique +import UniqFM +import UniqDFM +import UniqDSet +import FastString +import Binary +import Util +import Data.List +import Data.Ord +import GHC.PackageDb (BinaryStringRep(..), DbUnitIdModuleRep(..), DbModule(..), DbUnitId(..)) +import Fingerprint + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS.Char8 +import Encoding + +import qualified Text.ParserCombinators.ReadP as Parse +import Text.ParserCombinators.ReadP (ReadP, (<++)) +import Data.Char (isAlphaNum) +import Control.DeepSeq +import Data.Coerce +import Data.Data +import Data.Function +import Data.Map (Map) +import Data.Set (Set) +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified FiniteMap as Map +import System.FilePath + +import {-# SOURCE #-} DynFlags (DynFlags) +import {-# SOURCE #-} Packages (componentIdString, improveUnitId, PackageConfigMap, getPackageConfigMap, displayInstalledUnitId) + +-- Note [The identifier lexicon] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Unit IDs, installed package IDs, ABI hashes, package names, +-- versions, there are a *lot* of different identifiers for closely +-- related things. What do they all mean? Here's what. (See also +-- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/packages/concepts ) +-- +-- THE IMPORTANT ONES +-- +-- ComponentId: An opaque identifier provided by Cabal, which should +-- uniquely identify such things as the package name, the package +-- version, the name of the component, the hash of the source code +-- tarball, the selected Cabal flags, GHC flags, direct dependencies of +-- the component. These are very similar to InstalledPackageId, but +-- an 'InstalledPackageId' implies that it identifies a package, while +-- a package may install multiple components with different +-- 'ComponentId's. +-- - Same as Distribution.Package.ComponentId +-- +-- UnitId/InstalledUnitId: A ComponentId + a mapping from hole names +-- (ModuleName) to Modules. This is how the compiler identifies instantiated +-- components, and also is the main identifier by which GHC identifies things. +-- - When Backpack is not being used, UnitId = ComponentId. +-- this means a useful fiction for end-users is that there are +-- only ever ComponentIds, and some ComponentIds happen to have +-- more information (UnitIds). +-- - Same as Language.Haskell.TH.Syntax:PkgName, see +-- https://gitlab.haskell.org/ghc/ghc/issues/10279 +-- - The same as PackageKey in GHC 7.10 (we renamed it because +-- they don't necessarily identify packages anymore.) +-- - Same as -this-package-key/-package-name flags +-- - An InstalledUnitId corresponds to an actual package which +-- we have installed on disk. It could be definite or indefinite, +-- but if it's indefinite, it has nothing instantiated (we +-- never install partially instantiated units.) +-- +-- Module/InstalledModule: A UnitId/InstalledUnitId + ModuleName. This is how +-- the compiler identifies modules (e.g. a Name is a Module + OccName) +-- - Same as Language.Haskell.TH.Syntax:Module +-- +-- THE LESS IMPORTANT ONES +-- +-- PackageName: The "name" field in a Cabal file, something like "lens". +-- - Same as Distribution.Package.PackageName +-- - DIFFERENT FROM Language.Haskell.TH.Syntax:PkgName, see +-- https://gitlab.haskell.org/ghc/ghc/issues/10279 +-- - DIFFERENT FROM -package-name flag +-- - DIFFERENT FROM the 'name' field in an installed package +-- information. This field could more accurately be described +-- as a munged package name: when it's for the main library +-- it is the same as the package name, but if it's an internal +-- library it's a munged combination of the package name and +-- the component name. +-- +-- LEGACY ONES +-- +-- InstalledPackageId: This is what we used to call ComponentId. +-- It's a still pretty useful concept for packages that have only +-- one library; in that case the logical InstalledPackageId = +-- ComponentId. Also, the Cabal nix-local-build continues to +-- compute an InstalledPackageId which is then forcibly used +-- for all components in a package. This means that if a dependency +-- from one component in a package changes, the InstalledPackageId +-- changes: you don't get as fine-grained dependency tracking, +-- but it means your builds are hermetic. Eventually, Cabal will +-- deal completely in components and we can get rid of this. +-- +-- PackageKey: This is what we used to call UnitId. We ditched +-- "Package" from the name when we realized that you might want to +-- assign different "PackageKeys" to components from the same package. +-- (For a brief, non-released period of time, we also called these +-- UnitKeys). + +{- +************************************************************************ +* * +\subsection{Module locations} +* * +************************************************************************ +-} + +-- | Module Location +-- +-- Where a module lives on the file system: the actual locations +-- of the .hs, .hi and .o files, if we have them +data ModLocation + = ModLocation { + ml_hs_file :: Maybe FilePath, + -- The source file, if we have one. Package modules + -- probably don't have source files. + + ml_hi_file :: FilePath, + -- Where the .hi file is, whether or not it exists + -- yet. Always of form foo.hi, even if there is an + -- hi-boot file (we add the -boot suffix later) + + ml_obj_file :: FilePath, + -- Where the .o file is, whether or not it exists yet. + -- (might not exist either because the module hasn't + -- been compiled yet, or because it is part of a + -- package with a .a file) + ml_hie_file :: FilePath + } deriving Show + +instance Outputable ModLocation where + ppr = text . show + +{- +For a module in another package, the hs_file and obj_file +components of ModLocation are undefined. + +The locations specified by a ModLocation may or may not +correspond to actual files yet: for example, even if the object +file doesn't exist, the ModLocation still contains the path to +where the object file will reside if/when it is created. +-} + +addBootSuffix :: FilePath -> FilePath +-- ^ Add the @-boot@ suffix to .hs, .hi and .o files +addBootSuffix path = path ++ "-boot" + +addBootSuffix_maybe :: Bool -> FilePath -> FilePath +-- ^ Add the @-boot@ suffix if the @Bool@ argument is @True@ +addBootSuffix_maybe is_boot path + | is_boot = addBootSuffix path + | otherwise = path + +addBootSuffixLocn :: ModLocation -> ModLocation +-- ^ Add the @-boot@ suffix to all file paths associated with the module +addBootSuffixLocn locn + = locn { ml_hs_file = fmap addBootSuffix (ml_hs_file locn) + , ml_hi_file = addBootSuffix (ml_hi_file locn) + , ml_obj_file = addBootSuffix (ml_obj_file locn) + , ml_hie_file = addBootSuffix (ml_hie_file locn) } + +addBootSuffixLocnOut :: ModLocation -> ModLocation +-- ^ Add the @-boot@ suffix to all output file paths associated with the +-- module, not including the input file itself +addBootSuffixLocnOut locn + = locn { ml_hi_file = addBootSuffix (ml_hi_file locn) + , ml_obj_file = addBootSuffix (ml_obj_file locn) + , ml_hie_file = addBootSuffix (ml_hie_file locn) } + +{- +************************************************************************ +* * +\subsection{The name of a module} +* * +************************************************************************ +-} + +-- | A ModuleName is essentially a simple string, e.g. @Data.List@. +newtype ModuleName = ModuleName FastString + +instance Uniquable ModuleName where + getUnique (ModuleName nm) = getUnique nm + +instance Eq ModuleName where + nm1 == nm2 = getUnique nm1 == getUnique nm2 + +instance Ord ModuleName where + nm1 `compare` nm2 = stableModuleNameCmp nm1 nm2 + +instance Outputable ModuleName where + ppr = pprModuleName + +instance Binary ModuleName where + put_ bh (ModuleName fs) = put_ bh fs + get bh = do fs <- get bh; return (ModuleName fs) + +instance BinaryStringRep ModuleName where + fromStringRep = mkModuleNameFS . mkFastStringByteString + toStringRep = bytesFS . moduleNameFS + +instance Data ModuleName where + -- don't traverse? + toConstr _ = abstractConstr "ModuleName" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "ModuleName" + +instance NFData ModuleName where + rnf x = x `seq` () + +stableModuleNameCmp :: ModuleName -> ModuleName -> Ordering +-- ^ Compares module names lexically, rather than by their 'Unique's +stableModuleNameCmp n1 n2 = moduleNameFS n1 `compare` moduleNameFS n2 + +pprModuleName :: ModuleName -> SDoc +pprModuleName (ModuleName nm) = + getPprStyle $ \ sty -> + if codeStyle sty + then ztext (zEncodeFS nm) + else ftext nm + +moduleNameFS :: ModuleName -> FastString +moduleNameFS (ModuleName mod) = mod + +moduleNameString :: ModuleName -> String +moduleNameString (ModuleName mod) = unpackFS mod + +-- | Get a string representation of a 'Module' that's unique and stable +-- across recompilations. +-- eg. "$aeson_70dylHtv1FFGeai1IoxcQr$Data.Aeson.Types.Internal" +moduleStableString :: Module -> String +moduleStableString Module{..} = + "$" ++ unitIdString moduleUnitId ++ "$" ++ moduleNameString moduleName + +mkModuleName :: String -> ModuleName +mkModuleName s = ModuleName (mkFastString s) + +mkModuleNameFS :: FastString -> ModuleName +mkModuleNameFS s = ModuleName s + +-- |Returns the string version of the module name, with dots replaced by slashes. +-- +moduleNameSlashes :: ModuleName -> String +moduleNameSlashes = dots_to_slashes . moduleNameString + where dots_to_slashes = map (\c -> if c == '.' then pathSeparator else c) + +-- |Returns the string version of the module name, with dots replaced by colons. +-- +moduleNameColons :: ModuleName -> String +moduleNameColons = dots_to_colons . moduleNameString + where dots_to_colons = map (\c -> if c == '.' then ':' else c) + +{- +************************************************************************ +* * +\subsection{A fully qualified module} +* * +************************************************************************ +-} + +-- | A Module is a pair of a 'UnitId' and a 'ModuleName'. +-- +-- Module variables (i.e. @@) which can be instantiated to a +-- specific module at some later point in time are represented +-- with 'moduleUnitId' set to 'holeUnitId' (this allows us to +-- avoid having to make 'moduleUnitId' a partial operation.) +-- +data Module = Module { + moduleUnitId :: !UnitId, -- pkg-1.0 + moduleName :: !ModuleName -- A.B.C + } + deriving (Eq, Ord) + +-- | Calculate the free holes of a 'Module'. If this set is non-empty, +-- this module was defined in an indefinite library that had required +-- signatures. +-- +-- If a module has free holes, that means that substitutions can operate on it; +-- if it has no free holes, substituting over a module has no effect. +moduleFreeHoles :: Module -> UniqDSet ModuleName +moduleFreeHoles m + | isHoleModule m = unitUniqDSet (moduleName m) + | otherwise = unitIdFreeHoles (moduleUnitId m) + +-- | A 'Module' is definite if it has no free holes. +moduleIsDefinite :: Module -> Bool +moduleIsDefinite = isEmptyUniqDSet . moduleFreeHoles + +-- | Create a module variable at some 'ModuleName'. +-- See Note [Representation of module/name variables] +mkHoleModule :: ModuleName -> Module +mkHoleModule = mkModule holeUnitId + +instance Uniquable Module where + getUnique (Module p n) = getUnique (unitIdFS p `appendFS` moduleNameFS n) + +instance Outputable Module where + ppr = pprModule + +instance Binary Module where + put_ bh (Module p n) = put_ bh p >> put_ bh n + get bh = do p <- get bh; n <- get bh; return (Module p n) + +instance Data Module where + -- don't traverse? + toConstr _ = abstractConstr "Module" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "Module" + +instance NFData Module where + rnf x = x `seq` () + +-- | This gives a stable ordering, as opposed to the Ord instance which +-- gives an ordering based on the 'Unique's of the components, which may +-- not be stable from run to run of the compiler. +stableModuleCmp :: Module -> Module -> Ordering +stableModuleCmp (Module p1 n1) (Module p2 n2) + = (p1 `stableUnitIdCmp` p2) `thenCmp` + (n1 `stableModuleNameCmp` n2) + +mkModule :: UnitId -> ModuleName -> Module +mkModule = Module + +pprModule :: Module -> SDoc +pprModule mod@(Module p n) = getPprStyle doc + where + doc sty + | codeStyle sty = + (if p == mainUnitId + then empty -- never qualify the main package in code + else ztext (zEncodeFS (unitIdFS p)) <> char '_') + <> pprModuleName n + | qualModule sty mod = + if isHoleModule mod + then angleBrackets (pprModuleName n) + else ppr (moduleUnitId mod) <> char ':' <> pprModuleName n + | otherwise = + pprModuleName n + +class ContainsModule t where + extractModule :: t -> Module + +class HasModule m where + getModule :: m Module + +instance DbUnitIdModuleRep InstalledUnitId ComponentId UnitId ModuleName Module where + fromDbModule (DbModule uid mod_name) = mkModule uid mod_name + fromDbModule (DbModuleVar mod_name) = mkHoleModule mod_name + fromDbUnitId (DbUnitId cid insts) = newUnitId cid insts + fromDbUnitId (DbInstalledUnitId iuid) = DefiniteUnitId (DefUnitId iuid) + -- GHC never writes to the database, so it's not needed + toDbModule = error "toDbModule: not implemented" + toDbUnitId = error "toDbUnitId: not implemented" + +{- +************************************************************************ +* * +\subsection{ComponentId} +* * +************************************************************************ +-} + +-- | A 'ComponentId' consists of the package name, package version, component +-- ID, the transitive dependencies of the component, and other information to +-- uniquely identify the source code and build configuration of a component. +-- +-- This used to be known as an 'InstalledPackageId', but a package can contain +-- multiple components and a 'ComponentId' uniquely identifies a component +-- within a package. When a package only has one component, the 'ComponentId' +-- coincides with the 'InstalledPackageId' +newtype ComponentId = ComponentId FastString deriving (Eq, Ord) + +instance BinaryStringRep ComponentId where + fromStringRep = ComponentId . mkFastStringByteString + toStringRep (ComponentId s) = bytesFS s + +instance Uniquable ComponentId where + getUnique (ComponentId n) = getUnique n + +instance Outputable ComponentId where + ppr cid@(ComponentId fs) = + getPprStyle $ \sty -> + sdocWithDynFlags $ \dflags -> + case componentIdString dflags cid of + Just str | not (debugStyle sty) -> text str + _ -> ftext fs + +{- +************************************************************************ +* * +\subsection{UnitId} +* * +************************************************************************ +-} + +-- | A unit identifier identifies a (possibly partially) instantiated +-- library. It is primarily used as part of 'Module', which in turn +-- is used in 'Name', which is used to give names to entities when +-- typechecking. +-- +-- There are two possible forms for a 'UnitId'. It can be a +-- 'DefiniteUnitId', in which case we just have a string that uniquely +-- identifies some fully compiled, installed library we have on disk. +-- However, when we are typechecking a library with missing holes, +-- we may need to instantiate a library on the fly (in which case +-- we don't have any on-disk representation.) In that case, you +-- have an 'IndefiniteUnitId', which explicitly records the +-- instantiation, so that we can substitute over it. +data UnitId + = IndefiniteUnitId {-# UNPACK #-} !IndefUnitId + | DefiniteUnitId {-# UNPACK #-} !DefUnitId + +unitIdFS :: UnitId -> FastString +unitIdFS (IndefiniteUnitId x) = indefUnitIdFS x +unitIdFS (DefiniteUnitId (DefUnitId x)) = installedUnitIdFS x + +unitIdKey :: UnitId -> Unique +unitIdKey (IndefiniteUnitId x) = indefUnitIdKey x +unitIdKey (DefiniteUnitId (DefUnitId x)) = installedUnitIdKey x + +-- | A unit identifier which identifies an indefinite +-- library (with holes) that has been *on-the-fly* instantiated +-- with a substitution 'indefUnitIdInsts'. In fact, an indefinite +-- unit identifier could have no holes, but we haven't gotten +-- around to compiling the actual library yet. +-- +-- An indefinite unit identifier pretty-prints to something like +-- @p[H=,A=aimpl:A>]@ (@p@ is the 'ComponentId', and the +-- brackets enclose the module substitution). +data IndefUnitId + = IndefUnitId { + -- | A private, uniquely identifying representation of + -- a UnitId. This string is completely private to GHC + -- and is just used to get a unique; in particular, we don't use it for + -- symbols (indefinite libraries are not compiled). + indefUnitIdFS :: FastString, + -- | Cached unique of 'unitIdFS'. + indefUnitIdKey :: Unique, + -- | The component identity of the indefinite library that + -- is being instantiated. + indefUnitIdComponentId :: !ComponentId, + -- | The sorted (by 'ModuleName') instantiations of this library. + indefUnitIdInsts :: ![(ModuleName, Module)], + -- | A cache of the free module variables of 'unitIdInsts'. + -- This lets us efficiently tell if a 'UnitId' has been + -- fully instantiated (free module variables are empty) + -- and whether or not a substitution can have any effect. + indefUnitIdFreeHoles :: UniqDSet ModuleName + } + +instance Eq IndefUnitId where + u1 == u2 = indefUnitIdKey u1 == indefUnitIdKey u2 + +instance Ord IndefUnitId where + u1 `compare` u2 = indefUnitIdFS u1 `compare` indefUnitIdFS u2 + +instance Binary IndefUnitId where + put_ bh indef = do + put_ bh (indefUnitIdComponentId indef) + put_ bh (indefUnitIdInsts indef) + get bh = do + cid <- get bh + insts <- get bh + let fs = hashUnitId cid insts + return IndefUnitId { + indefUnitIdComponentId = cid, + indefUnitIdInsts = insts, + indefUnitIdFreeHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts), + indefUnitIdFS = fs, + indefUnitIdKey = getUnique fs + } + +-- | Create a new 'IndefUnitId' given an explicit module substitution. +newIndefUnitId :: ComponentId -> [(ModuleName, Module)] -> IndefUnitId +newIndefUnitId cid insts = + IndefUnitId { + indefUnitIdComponentId = cid, + indefUnitIdInsts = sorted_insts, + indefUnitIdFreeHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts), + indefUnitIdFS = fs, + indefUnitIdKey = getUnique fs + } + where + fs = hashUnitId cid sorted_insts + sorted_insts = sortBy (stableModuleNameCmp `on` fst) insts + +-- | Injects an 'IndefUnitId' (indefinite library which +-- was on-the-fly instantiated) to a 'UnitId' (either +-- an indefinite or definite library). +indefUnitIdToUnitId :: DynFlags -> IndefUnitId -> UnitId +indefUnitIdToUnitId dflags iuid = + -- NB: suppose that we want to compare the indefinite + -- unit id p[H=impl:H] against p+abcd (where p+abcd + -- happens to be the existing, installed version of + -- p[H=impl:H]. If we *only* wrap in p[H=impl:H] + -- IndefiniteUnitId, they won't compare equal; only + -- after improvement will the equality hold. + improveUnitId (getPackageConfigMap dflags) $ + IndefiniteUnitId iuid + +data IndefModule = IndefModule { + indefModuleUnitId :: IndefUnitId, + indefModuleName :: ModuleName + } deriving (Eq, Ord) + +instance Outputable IndefModule where + ppr (IndefModule uid m) = + ppr uid <> char ':' <> ppr m + +-- | Injects an 'IndefModule' to 'Module' (see also +-- 'indefUnitIdToUnitId'. +indefModuleToModule :: DynFlags -> IndefModule -> Module +indefModuleToModule dflags (IndefModule iuid mod_name) = + mkModule (indefUnitIdToUnitId dflags iuid) mod_name + +-- | An installed unit identifier identifies a library which has +-- been installed to the package database. These strings are +-- provided to us via the @-this-unit-id@ flag. The library +-- in question may be definite or indefinite; if it is indefinite, +-- none of the holes have been filled (we never install partially +-- instantiated libraries.) Put another way, an installed unit id +-- is either fully instantiated, or not instantiated at all. +-- +-- Installed unit identifiers look something like @p+af23SAj2dZ219@, +-- or maybe just @p@ if they don't use Backpack. +newtype InstalledUnitId = + InstalledUnitId { + -- | The full hashed unit identifier, including the component id + -- and the hash. + installedUnitIdFS :: FastString + } + +instance Binary InstalledUnitId where + put_ bh (InstalledUnitId fs) = put_ bh fs + get bh = do fs <- get bh; return (InstalledUnitId fs) + +instance BinaryStringRep InstalledUnitId where + fromStringRep bs = InstalledUnitId (mkFastStringByteString bs) + -- GHC doesn't write to database + toStringRep = error "BinaryStringRep InstalledUnitId: not implemented" + +instance Eq InstalledUnitId where + uid1 == uid2 = installedUnitIdKey uid1 == installedUnitIdKey uid2 + +instance Ord InstalledUnitId where + u1 `compare` u2 = installedUnitIdFS u1 `compare` installedUnitIdFS u2 + +instance Uniquable InstalledUnitId where + getUnique = installedUnitIdKey + +instance Outputable InstalledUnitId where + ppr uid@(InstalledUnitId fs) = + getPprStyle $ \sty -> + sdocWithDynFlags $ \dflags -> + case displayInstalledUnitId dflags uid of + Just str | not (debugStyle sty) -> text str + _ -> ftext fs + +installedUnitIdKey :: InstalledUnitId -> Unique +installedUnitIdKey = getUnique . installedUnitIdFS + +-- | Lossy conversion to the on-disk 'InstalledUnitId' for a component. +toInstalledUnitId :: UnitId -> InstalledUnitId +toInstalledUnitId (DefiniteUnitId (DefUnitId iuid)) = iuid +toInstalledUnitId (IndefiniteUnitId indef) = + componentIdToInstalledUnitId (indefUnitIdComponentId indef) + +installedUnitIdString :: InstalledUnitId -> String +installedUnitIdString = unpackFS . installedUnitIdFS + +instance Outputable IndefUnitId where + ppr uid = + -- getPprStyle $ \sty -> + ppr cid <> + (if not (null insts) -- pprIf + then + brackets (hcat + (punctuate comma $ + [ ppr modname <> text "=" <> ppr m + | (modname, m) <- insts])) + else empty) + where + cid = indefUnitIdComponentId uid + insts = indefUnitIdInsts uid + +-- | A 'InstalledModule' is a 'Module' which contains a 'InstalledUnitId'. +data InstalledModule = InstalledModule { + installedModuleUnitId :: !InstalledUnitId, + installedModuleName :: !ModuleName + } + deriving (Eq, Ord) + +instance Outputable InstalledModule where + ppr (InstalledModule p n) = + ppr p <> char ':' <> pprModuleName n + +fsToInstalledUnitId :: FastString -> InstalledUnitId +fsToInstalledUnitId fs = InstalledUnitId fs + +componentIdToInstalledUnitId :: ComponentId -> InstalledUnitId +componentIdToInstalledUnitId (ComponentId fs) = fsToInstalledUnitId fs + +stringToInstalledUnitId :: String -> InstalledUnitId +stringToInstalledUnitId = fsToInstalledUnitId . mkFastString + +-- | Test if a 'Module' corresponds to a given 'InstalledModule', +-- modulo instantiation. +installedModuleEq :: InstalledModule -> Module -> Bool +installedModuleEq imod mod = + fst (splitModuleInsts mod) == imod + +-- | Test if a 'UnitId' corresponds to a given 'InstalledUnitId', +-- modulo instantiation. +installedUnitIdEq :: InstalledUnitId -> UnitId -> Bool +installedUnitIdEq iuid uid = + fst (splitUnitIdInsts uid) == iuid + +-- | A 'DefUnitId' is an 'InstalledUnitId' with the invariant that +-- it only refers to a definite library; i.e., one we have generated +-- code for. +newtype DefUnitId = DefUnitId { unDefUnitId :: InstalledUnitId } + deriving (Eq, Ord) + +instance Outputable DefUnitId where + ppr (DefUnitId uid) = ppr uid + +instance Binary DefUnitId where + put_ bh (DefUnitId uid) = put_ bh uid + get bh = do uid <- get bh; return (DefUnitId uid) + +-- | A map keyed off of 'InstalledModule' +newtype InstalledModuleEnv elt = InstalledModuleEnv (Map InstalledModule elt) + +emptyInstalledModuleEnv :: InstalledModuleEnv a +emptyInstalledModuleEnv = InstalledModuleEnv Map.empty + +lookupInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> Maybe a +lookupInstalledModuleEnv (InstalledModuleEnv e) m = Map.lookup m e + +extendInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> a -> InstalledModuleEnv a +extendInstalledModuleEnv (InstalledModuleEnv e) m x = InstalledModuleEnv (Map.insert m x e) + +filterInstalledModuleEnv :: (InstalledModule -> a -> Bool) -> InstalledModuleEnv a -> InstalledModuleEnv a +filterInstalledModuleEnv f (InstalledModuleEnv e) = + InstalledModuleEnv (Map.filterWithKey f e) + +delInstalledModuleEnv :: InstalledModuleEnv a -> InstalledModule -> InstalledModuleEnv a +delInstalledModuleEnv (InstalledModuleEnv e) m = InstalledModuleEnv (Map.delete m e) + +-- Note [UnitId to InstalledUnitId improvement] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Just because a UnitId is definite (has no holes) doesn't +-- mean it's necessarily a InstalledUnitId; it could just be +-- that over the course of renaming UnitIds on the fly +-- while typechecking an indefinite library, we +-- ended up with a fully instantiated unit id with no hash, +-- since we haven't built it yet. This is fine. +-- +-- However, if there is a hashed unit id for this instantiation +-- in the package database, we *better use it*, because +-- that hashed unit id may be lurking in another interface, +-- and chaos will ensue if we attempt to compare the two +-- (the unitIdFS for a UnitId never corresponds to a Cabal-provided +-- hash of a compiled instantiated library). +-- +-- There is one last niggle: improvement based on the package database means +-- that we might end up developing on a package that is not transitively +-- depended upon by the packages the user specified directly via command line +-- flags. This could lead to strange and difficult to understand bugs if those +-- instantiations are out of date. The solution is to only improve a +-- unit id if the new unit id is part of the 'preloadClosure'; i.e., the +-- closure of all the packages which were explicitly specified. + +-- | Retrieve the set of free holes of a 'UnitId'. +unitIdFreeHoles :: UnitId -> UniqDSet ModuleName +unitIdFreeHoles (IndefiniteUnitId x) = indefUnitIdFreeHoles x +-- Hashed unit ids are always fully instantiated +unitIdFreeHoles (DefiniteUnitId _) = emptyUniqDSet + +instance Show UnitId where + show = unitIdString + +-- | A 'UnitId' is definite if it has no free holes. +unitIdIsDefinite :: UnitId -> Bool +unitIdIsDefinite = isEmptyUniqDSet . unitIdFreeHoles + +-- | Generate a uniquely identifying 'FastString' for a unit +-- identifier. This is a one-way function. You can rely on one special +-- property: if a unit identifier is in most general form, its 'FastString' +-- coincides with its 'ComponentId'. This hash is completely internal +-- to GHC and is not used for symbol names or file paths. +hashUnitId :: ComponentId -> [(ModuleName, Module)] -> FastString +hashUnitId cid sorted_holes = + mkFastStringByteString + . fingerprintUnitId (toStringRep cid) + $ rawHashUnitId sorted_holes + +-- | Generate a hash for a sorted module substitution. +rawHashUnitId :: [(ModuleName, Module)] -> Fingerprint +rawHashUnitId sorted_holes = + fingerprintByteString + . BS.concat $ do + (m, b) <- sorted_holes + [ toStringRep m, BS.Char8.singleton ' ', + bytesFS (unitIdFS (moduleUnitId b)), BS.Char8.singleton ':', + toStringRep (moduleName b), BS.Char8.singleton '\n'] + +fingerprintUnitId :: BS.ByteString -> Fingerprint -> BS.ByteString +fingerprintUnitId prefix (Fingerprint a b) + = BS.concat + $ [ prefix + , BS.Char8.singleton '-' + , BS.Char8.pack (toBase62Padded a) + , BS.Char8.pack (toBase62Padded b) ] + +-- | Create a new, un-hashed unit identifier. +newUnitId :: ComponentId -> [(ModuleName, Module)] -> UnitId +newUnitId cid [] = newSimpleUnitId cid -- TODO: this indicates some latent bug... +newUnitId cid insts = IndefiniteUnitId $ newIndefUnitId cid insts + +pprUnitId :: UnitId -> SDoc +pprUnitId (DefiniteUnitId uid) = ppr uid +pprUnitId (IndefiniteUnitId uid) = ppr uid + +instance Eq UnitId where + uid1 == uid2 = unitIdKey uid1 == unitIdKey uid2 + +instance Uniquable UnitId where + getUnique = unitIdKey + +instance Ord UnitId where + nm1 `compare` nm2 = stableUnitIdCmp nm1 nm2 + +instance Data UnitId where + -- don't traverse? + toConstr _ = abstractConstr "UnitId" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "UnitId" + +instance NFData UnitId where + rnf x = x `seq` () + +stableUnitIdCmp :: UnitId -> UnitId -> Ordering +-- ^ Compares package ids lexically, rather than by their 'Unique's +stableUnitIdCmp p1 p2 = unitIdFS p1 `compare` unitIdFS p2 + +instance Outputable UnitId where + ppr pk = pprUnitId pk + +-- Performance: would prefer to have a NameCache like thing +instance Binary UnitId where + put_ bh (DefiniteUnitId def_uid) = do + putByte bh 0 + put_ bh def_uid + put_ bh (IndefiniteUnitId indef_uid) = do + putByte bh 1 + put_ bh indef_uid + get bh = do b <- getByte bh + case b of + 0 -> fmap DefiniteUnitId (get bh) + _ -> fmap IndefiniteUnitId (get bh) + +instance Binary ComponentId where + put_ bh (ComponentId fs) = put_ bh fs + get bh = do { fs <- get bh; return (ComponentId fs) } + +-- | Create a new simple unit identifier (no holes) from a 'ComponentId'. +newSimpleUnitId :: ComponentId -> UnitId +newSimpleUnitId (ComponentId fs) = fsToUnitId fs + +-- | Create a new simple unit identifier from a 'FastString'. Internally, +-- this is primarily used to specify wired-in unit identifiers. +fsToUnitId :: FastString -> UnitId +fsToUnitId = DefiniteUnitId . DefUnitId . InstalledUnitId + +stringToUnitId :: String -> UnitId +stringToUnitId = fsToUnitId . mkFastString + +unitIdString :: UnitId -> String +unitIdString = unpackFS . unitIdFS + +{- +************************************************************************ +* * + Hole substitutions +* * +************************************************************************ +-} + +-- | Substitution on module variables, mapping module names to module +-- identifiers. +type ShHoleSubst = ModuleNameEnv Module + +-- | Substitutes holes in a 'Module'. NOT suitable for being called +-- directly on a 'nameModule', see Note [Representation of module/name variable]. +-- @p[A=]:B@ maps to @p[A=q():A]:B@ with @A=q():A@; +-- similarly, @@ maps to @q():A@. +renameHoleModule :: DynFlags -> ShHoleSubst -> Module -> Module +renameHoleModule dflags = renameHoleModule' (getPackageConfigMap dflags) + +-- | Substitutes holes in a 'UnitId', suitable for renaming when +-- an include occurs; see Note [Representation of module/name variable]. +-- +-- @p[A=]@ maps to @p[A=]@ with @A=@. +renameHoleUnitId :: DynFlags -> ShHoleSubst -> UnitId -> UnitId +renameHoleUnitId dflags = renameHoleUnitId' (getPackageConfigMap dflags) + +-- | Like 'renameHoleModule', but requires only 'PackageConfigMap' +-- so it can be used by "Packages". +renameHoleModule' :: PackageConfigMap -> ShHoleSubst -> Module -> Module +renameHoleModule' pkg_map env m + | not (isHoleModule m) = + let uid = renameHoleUnitId' pkg_map env (moduleUnitId m) + in mkModule uid (moduleName m) + | Just m' <- lookupUFM env (moduleName m) = m' + -- NB m = , that's what's in scope. + | otherwise = m + +-- | Like 'renameHoleUnitId, but requires only 'PackageConfigMap' +-- so it can be used by "Packages". +renameHoleUnitId' :: PackageConfigMap -> ShHoleSubst -> UnitId -> UnitId +renameHoleUnitId' pkg_map env uid = + case uid of + (IndefiniteUnitId + IndefUnitId{ indefUnitIdComponentId = cid + , indefUnitIdInsts = insts + , indefUnitIdFreeHoles = fh }) + -> if isNullUFM (intersectUFM_C const (udfmToUfm (getUniqDSet fh)) env) + then uid + -- Functorially apply the substitution to the instantiation, + -- then check the 'PackageConfigMap' to see if there is + -- a compiled version of this 'UnitId' we can improve to. + -- See Note [UnitId to InstalledUnitId] improvement + else improveUnitId pkg_map $ + newUnitId cid + (map (\(k,v) -> (k, renameHoleModule' pkg_map env v)) insts) + _ -> uid + +-- | Given a possibly on-the-fly instantiated module, split it into +-- a 'Module' that we definitely can find on-disk, as well as an +-- instantiation if we need to instantiate it on the fly. If the +-- instantiation is @Nothing@ no on-the-fly renaming is needed. +splitModuleInsts :: Module -> (InstalledModule, Maybe IndefModule) +splitModuleInsts m = + let (uid, mb_iuid) = splitUnitIdInsts (moduleUnitId m) + in (InstalledModule uid (moduleName m), + fmap (\iuid -> IndefModule iuid (moduleName m)) mb_iuid) + +-- | See 'splitModuleInsts'. +splitUnitIdInsts :: UnitId -> (InstalledUnitId, Maybe IndefUnitId) +splitUnitIdInsts (IndefiniteUnitId iuid) = + (componentIdToInstalledUnitId (indefUnitIdComponentId iuid), Just iuid) +splitUnitIdInsts (DefiniteUnitId (DefUnitId uid)) = (uid, Nothing) + +generalizeIndefUnitId :: IndefUnitId -> IndefUnitId +generalizeIndefUnitId IndefUnitId{ indefUnitIdComponentId = cid + , indefUnitIdInsts = insts } = + newIndefUnitId cid (map (\(m,_) -> (m, mkHoleModule m)) insts) + +generalizeIndefModule :: IndefModule -> IndefModule +generalizeIndefModule (IndefModule uid n) = IndefModule (generalizeIndefUnitId uid) n + +parseModuleName :: ReadP ModuleName +parseModuleName = fmap mkModuleName + $ Parse.munch1 (\c -> isAlphaNum c || c `elem` "_.") + +parseUnitId :: ReadP UnitId +parseUnitId = parseFullUnitId <++ parseDefiniteUnitId <++ parseSimpleUnitId + where + parseFullUnitId = do + cid <- parseComponentId + insts <- parseModSubst + return (newUnitId cid insts) + parseDefiniteUnitId = do + s <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "-_.+") + return (stringToUnitId s) + parseSimpleUnitId = do + cid <- parseComponentId + return (newSimpleUnitId cid) + +parseComponentId :: ReadP ComponentId +parseComponentId = (ComponentId . mkFastString) `fmap` Parse.munch1 abi_char + where abi_char c = isAlphaNum c || c `elem` "-_." + +parseModuleId :: ReadP Module +parseModuleId = parseModuleVar <++ parseModule + where + parseModuleVar = do + _ <- Parse.char '<' + modname <- parseModuleName + _ <- Parse.char '>' + return (mkHoleModule modname) + parseModule = do + uid <- parseUnitId + _ <- Parse.char ':' + modname <- parseModuleName + return (mkModule uid modname) + +parseModSubst :: ReadP [(ModuleName, Module)] +parseModSubst = Parse.between (Parse.char '[') (Parse.char ']') + . flip Parse.sepBy (Parse.char ',') + $ do k <- parseModuleName + _ <- Parse.char '=' + v <- parseModuleId + return (k, v) + + +{- +Note [Wired-in packages] +~~~~~~~~~~~~~~~~~~~~~~~~ + +Certain packages are known to the compiler, in that we know about certain +entities that reside in these packages, and the compiler needs to +declare static Modules and Names that refer to these packages. Hence +the wired-in packages can't include version numbers in their package UnitId, +since we don't want to bake the version numbers of these packages into GHC. + +So here's the plan. Wired-in packages are still versioned as +normal in the packages database, and you can still have multiple +versions of them installed. To the user, everything looks normal. + +However, for each invocation of GHC, only a single instance of each wired-in +package will be recognised (the desired one is selected via +@-package@\/@-hide-package@), and GHC will internall pretend that it has the +*unversioned* 'UnitId', including in .hi files and object file symbols. + +Unselected versions of wired-in packages will be ignored, as will any other +package that depends directly or indirectly on it (much as if you +had used @-ignore-package@). + +The affected packages are compiled with, e.g., @-this-unit-id base@, so that +the symbols in the object files have the unversioned unit id in their name. + +Make sure you change 'Packages.findWiredInPackages' if you add an entry here. + +For `integer-gmp`/`integer-simple` we also change the base name to +`integer-wired-in`, but this is fundamentally no different. +See Note [The integer library] in PrelNames. +-} + +integerUnitId, primUnitId, + baseUnitId, rtsUnitId, + thUnitId, mainUnitId, thisGhcUnitId, interactiveUnitId :: UnitId +primUnitId = fsToUnitId (fsLit "ghc-prim") +integerUnitId = fsToUnitId (fsLit "integer-wired-in") + -- See Note [The integer library] in PrelNames +baseUnitId = fsToUnitId (fsLit "base") +rtsUnitId = fsToUnitId (fsLit "rts") +thUnitId = fsToUnitId (fsLit "template-haskell") +thisGhcUnitId = fsToUnitId (fsLit "ghc") +interactiveUnitId = fsToUnitId (fsLit "interactive") + +-- | This is the package Id for the current program. It is the default +-- package Id if you don't specify a package name. We don't add this prefix +-- to symbol names, since there can be only one main package per program. +mainUnitId = fsToUnitId (fsLit "main") + +-- | This is a fake package id used to provide identities to any un-implemented +-- signatures. The set of hole identities is global over an entire compilation. +-- Don't use this directly: use 'mkHoleModule' or 'isHoleModule' instead. +-- See Note [Representation of module/name variables] +holeUnitId :: UnitId +holeUnitId = fsToUnitId (fsLit "hole") + +isInteractiveModule :: Module -> Bool +isInteractiveModule mod = moduleUnitId mod == interactiveUnitId + +-- Note [Representation of module/name variables] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- In our ICFP'16, we use to represent module holes, and {A.T} to represent +-- name holes. This could have been represented by adding some new cases +-- to the core data types, but this would have made the existing 'nameModule' +-- and 'moduleUnitId' partial, which would have required a lot of modifications +-- to existing code. +-- +-- Instead, we adopted the following encoding scheme: +-- +-- ===> hole:A +-- {A.T} ===> hole:A.T +-- +-- This encoding is quite convenient, but it is also a bit dangerous too, +-- because if you have a 'hole:A' you need to know if it's actually a +-- 'Module' or just a module stored in a 'Name'; these two cases must be +-- treated differently when doing substitutions. 'renameHoleModule' +-- and 'renameHoleUnitId' assume they are NOT operating on a +-- 'Name'; 'NameShape' handles name substitutions exclusively. + +isHoleModule :: Module -> Bool +isHoleModule mod = moduleUnitId mod == holeUnitId + +wiredInUnitIds :: [UnitId] +wiredInUnitIds = [ primUnitId, + integerUnitId, + baseUnitId, + rtsUnitId, + thUnitId, + thisGhcUnitId ] + +{- +************************************************************************ +* * +\subsection{@ModuleEnv@s} +* * +************************************************************************ +-} + +-- | A map keyed off of 'Module's +newtype ModuleEnv elt = ModuleEnv (Map NDModule elt) + +{- +Note [ModuleEnv performance and determinism] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To prevent accidental reintroduction of nondeterminism the Ord instance +for Module was changed to not depend on Unique ordering and to use the +lexicographic order. This is potentially expensive, but when measured +there was no difference in performance. + +To be on the safe side and not pessimize ModuleEnv uses nondeterministic +ordering on Module and normalizes by doing the lexicographic sort when +turning the env to a list. +See Note [Unique Determinism] for more information about the source of +nondeterminismand and Note [Deterministic UniqFM] for explanation of why +it matters for maps. +-} + +newtype NDModule = NDModule { unNDModule :: Module } + deriving Eq + -- A wrapper for Module with faster nondeterministic Ord. + -- Don't export, See [ModuleEnv performance and determinism] + +instance Ord NDModule where + compare (NDModule (Module p1 n1)) (NDModule (Module p2 n2)) = + (getUnique p1 `nonDetCmpUnique` getUnique p2) `thenCmp` + (getUnique n1 `nonDetCmpUnique` getUnique n2) + +filterModuleEnv :: (Module -> a -> Bool) -> ModuleEnv a -> ModuleEnv a +filterModuleEnv f (ModuleEnv e) = + ModuleEnv (Map.filterWithKey (f . unNDModule) e) + +elemModuleEnv :: Module -> ModuleEnv a -> Bool +elemModuleEnv m (ModuleEnv e) = Map.member (NDModule m) e + +extendModuleEnv :: ModuleEnv a -> Module -> a -> ModuleEnv a +extendModuleEnv (ModuleEnv e) m x = ModuleEnv (Map.insert (NDModule m) x e) + +extendModuleEnvWith :: (a -> a -> a) -> ModuleEnv a -> Module -> a + -> ModuleEnv a +extendModuleEnvWith f (ModuleEnv e) m x = + ModuleEnv (Map.insertWith f (NDModule m) x e) + +extendModuleEnvList :: ModuleEnv a -> [(Module, a)] -> ModuleEnv a +extendModuleEnvList (ModuleEnv e) xs = + ModuleEnv (Map.insertList [(NDModule k, v) | (k,v) <- xs] e) + +extendModuleEnvList_C :: (a -> a -> a) -> ModuleEnv a -> [(Module, a)] + -> ModuleEnv a +extendModuleEnvList_C f (ModuleEnv e) xs = + ModuleEnv (Map.insertListWith f [(NDModule k, v) | (k,v) <- xs] e) + +plusModuleEnv_C :: (a -> a -> a) -> ModuleEnv a -> ModuleEnv a -> ModuleEnv a +plusModuleEnv_C f (ModuleEnv e1) (ModuleEnv e2) = + ModuleEnv (Map.unionWith f e1 e2) + +delModuleEnvList :: ModuleEnv a -> [Module] -> ModuleEnv a +delModuleEnvList (ModuleEnv e) ms = + ModuleEnv (Map.deleteList (map NDModule ms) e) + +delModuleEnv :: ModuleEnv a -> Module -> ModuleEnv a +delModuleEnv (ModuleEnv e) m = ModuleEnv (Map.delete (NDModule m) e) + +plusModuleEnv :: ModuleEnv a -> ModuleEnv a -> ModuleEnv a +plusModuleEnv (ModuleEnv e1) (ModuleEnv e2) = ModuleEnv (Map.union e1 e2) + +lookupModuleEnv :: ModuleEnv a -> Module -> Maybe a +lookupModuleEnv (ModuleEnv e) m = Map.lookup (NDModule m) e + +lookupWithDefaultModuleEnv :: ModuleEnv a -> a -> Module -> a +lookupWithDefaultModuleEnv (ModuleEnv e) x m = + Map.findWithDefault x (NDModule m) e + +mapModuleEnv :: (a -> b) -> ModuleEnv a -> ModuleEnv b +mapModuleEnv f (ModuleEnv e) = ModuleEnv (Map.mapWithKey (\_ v -> f v) e) + +mkModuleEnv :: [(Module, a)] -> ModuleEnv a +mkModuleEnv xs = ModuleEnv (Map.fromList [(NDModule k, v) | (k,v) <- xs]) + +emptyModuleEnv :: ModuleEnv a +emptyModuleEnv = ModuleEnv Map.empty + +moduleEnvKeys :: ModuleEnv a -> [Module] +moduleEnvKeys (ModuleEnv e) = sort $ map unNDModule $ Map.keys e + -- See Note [ModuleEnv performance and determinism] + +moduleEnvElts :: ModuleEnv a -> [a] +moduleEnvElts e = map snd $ moduleEnvToList e + -- See Note [ModuleEnv performance and determinism] + +moduleEnvToList :: ModuleEnv a -> [(Module, a)] +moduleEnvToList (ModuleEnv e) = + sortBy (comparing fst) [(m, v) | (NDModule m, v) <- Map.toList e] + -- See Note [ModuleEnv performance and determinism] + +unitModuleEnv :: Module -> a -> ModuleEnv a +unitModuleEnv m x = ModuleEnv (Map.singleton (NDModule m) x) + +isEmptyModuleEnv :: ModuleEnv a -> Bool +isEmptyModuleEnv (ModuleEnv e) = Map.null e + +-- | A set of 'Module's +type ModuleSet = Set NDModule + +mkModuleSet :: [Module] -> ModuleSet +mkModuleSet = Set.fromList . coerce + +extendModuleSet :: ModuleSet -> Module -> ModuleSet +extendModuleSet s m = Set.insert (NDModule m) s + +extendModuleSetList :: ModuleSet -> [Module] -> ModuleSet +extendModuleSetList s ms = foldl' (coerce . flip Set.insert) s ms + +emptyModuleSet :: ModuleSet +emptyModuleSet = Set.empty + +moduleSetElts :: ModuleSet -> [Module] +moduleSetElts = sort . coerce . Set.toList + +elemModuleSet :: Module -> ModuleSet -> Bool +elemModuleSet = Set.member . coerce + +intersectModuleSet :: ModuleSet -> ModuleSet -> ModuleSet +intersectModuleSet = coerce Set.intersection + +minusModuleSet :: ModuleSet -> ModuleSet -> ModuleSet +minusModuleSet = coerce Set.difference + +delModuleSet :: ModuleSet -> Module -> ModuleSet +delModuleSet = coerce (flip Set.delete) + +unionModuleSet :: ModuleSet -> ModuleSet -> ModuleSet +unionModuleSet = coerce Set.union + +unitModuleSet :: Module -> ModuleSet +unitModuleSet = coerce Set.singleton + +{- +A ModuleName has a Unique, so we can build mappings of these using +UniqFM. +-} + +-- | A map keyed off of 'ModuleName's (actually, their 'Unique's) +type ModuleNameEnv elt = UniqFM elt + + +-- | A map keyed off of 'ModuleName's (actually, their 'Unique's) +-- Has deterministic folds and can be deterministically converted to a list +type DModuleNameEnv elt = UniqDFM elt diff --git a/compiler/basicTypes/Module.hs-boot b/compiler/basicTypes/Module.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/basicTypes/Module.hs-boot @@ -0,0 +1,14 @@ +module Module where + +import GhcPrelude +import FastString + +data Module +data ModuleName +data UnitId +data InstalledUnitId +newtype ComponentId = ComponentId FastString + +moduleName :: Module -> ModuleName +moduleUnitId :: Module -> UnitId +unitIdString :: UnitId -> String diff --git a/compiler/basicTypes/Name.hs b/compiler/basicTypes/Name.hs new file mode 100644 --- /dev/null +++ b/compiler/basicTypes/Name.hs @@ -0,0 +1,701 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[Name]{@Name@: to transmit name info from renamer to typechecker} +-} + +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternSynonyms #-} + +-- | +-- #name_types# +-- GHC uses several kinds of name internally: +-- +-- * 'OccName.OccName': see "OccName#name_types" +-- +-- * 'RdrName.RdrName': see "RdrName#name_types" +-- +-- * 'Name.Name' is the type of names that have had their scoping and binding resolved. They +-- have an 'OccName.OccName' but also a 'Unique.Unique' that disambiguates Names that have +-- the same 'OccName.OccName' and indeed is used for all 'Name.Name' comparison. Names +-- also contain information about where they originated from, see "Name#name_sorts" +-- +-- * 'Id.Id': see "Id#name_types" +-- +-- * 'Var.Var': see "Var#name_types" +-- +-- #name_sorts# +-- Names are one of: +-- +-- * External, if they name things declared in other modules. Some external +-- Names are wired in, i.e. they name primitives defined in the compiler itself +-- +-- * Internal, if they name things in the module being compiled. Some internal +-- Names are system names, if they are names manufactured by the compiler + +module Name ( + -- * The main types + Name, -- Abstract + BuiltInSyntax(..), + + -- ** Creating 'Name's + mkSystemName, mkSystemNameAt, + mkInternalName, mkClonedInternalName, mkDerivedInternalName, + mkSystemVarName, mkSysTvName, + mkFCallName, + mkExternalName, mkWiredInName, + + -- ** Manipulating and deconstructing 'Name's + nameUnique, setNameUnique, + nameOccName, nameModule, nameModule_maybe, + setNameLoc, + tidyNameOcc, + localiseName, + + nameSrcLoc, nameSrcSpan, pprNameDefnLoc, pprDefinedAt, + + -- ** Predicates on 'Name's + isSystemName, isInternalName, isExternalName, + isTyVarName, isTyConName, isDataConName, + isValName, isVarName, + isWiredInName, isBuiltInSyntax, + isHoleName, + wiredInNameTyThing_maybe, + nameIsLocalOrFrom, nameIsHomePackage, + nameIsHomePackageImport, nameIsFromExternalPackage, + stableNameCmp, + + -- * Class 'NamedThing' and overloaded friends + NamedThing(..), + getSrcLoc, getSrcSpan, getOccString, getOccFS, + + pprInfixName, pprPrefixName, pprModulePrefix, pprNameUnqualified, + nameStableString, + + -- Re-export the OccName stuff + module OccName + ) where + +import GhcPrelude + +import {-# SOURCE #-} TyCoRep( TyThing ) + +import OccName +import Module +import SrcLoc +import Unique +import Util +import Maybes +import Binary +import DynFlags +import FastString +import Outputable + +import Control.DeepSeq +import Data.Data + +{- +************************************************************************ +* * +\subsection[Name-datatype]{The @Name@ datatype, and name construction} +* * +************************************************************************ +-} + +-- | A unique, unambiguous name for something, containing information about where +-- that thing originated. +data Name = Name { + n_sort :: NameSort, -- What sort of name it is + n_occ :: !OccName, -- Its occurrence name + n_uniq :: {-# UNPACK #-} !Unique, + n_loc :: !SrcSpan -- Definition site + } + +-- NOTE: we make the n_loc field strict to eliminate some potential +-- (and real!) space leaks, due to the fact that we don't look at +-- the SrcLoc in a Name all that often. + +-- See Note [About the NameSorts] +data NameSort + = External Module + + | WiredIn Module TyThing BuiltInSyntax + -- A variant of External, for wired-in things + + | Internal -- A user-defined Id or TyVar + -- defined in the module being compiled + + | System -- A system-defined Id or TyVar. Typically the + -- OccName is very uninformative (like 's') + +instance Outputable NameSort where + ppr (External _) = text "external" + ppr (WiredIn _ _ _) = text "wired-in" + ppr Internal = text "internal" + ppr System = text "system" + +instance NFData Name where + rnf Name{..} = rnf n_sort + +instance NFData NameSort where + rnf (External m) = rnf m + rnf (WiredIn m t b) = rnf m `seq` t `seq` b `seq` () + -- XXX this is a *lie*, we're not going to rnf the TyThing, but + -- since the TyThings for WiredIn Names are all static they can't + -- be hiding space leaks or errors. + rnf Internal = () + rnf System = () + +-- | BuiltInSyntax is for things like @(:)@, @[]@ and tuples, +-- which have special syntactic forms. They aren't in scope +-- as such. +data BuiltInSyntax = BuiltInSyntax | UserSyntax + +{- +Note [About the NameSorts] + +1. Initially, top-level Ids (including locally-defined ones) get External names, + and all other local Ids get Internal names + +2. In any invocation of GHC, an External Name for "M.x" has one and only one + unique. This unique association is ensured via the Name Cache; + see Note [The Name Cache] in IfaceEnv. + +3. Things with a External name are given C static labels, so they finally + appear in the .o file's symbol table. They appear in the symbol table + in the form M.n. If originally-local things have this property they + must be made @External@ first. + +4. In the tidy-core phase, a External that is not visible to an importer + is changed to Internal, and a Internal that is visible is changed to External + +5. A System Name differs in the following ways: + a) has unique attached when printing dumps + b) unifier eliminates sys tyvars in favour of user provs where possible + + Before anything gets printed in interface files or output code, it's + fed through a 'tidy' processor, which zaps the OccNames to have + unique names; and converts all sys-locals to user locals + If any desugarer sys-locals have survived that far, they get changed to + "ds1", "ds2", etc. + +Built-in syntax => It's a syntactic form, not "in scope" (e.g. []) + +Wired-in thing => The thing (Id, TyCon) is fully known to the compiler, + not read from an interface file. + E.g. Bool, True, Int, Float, and many others + +All built-in syntax is for wired-in things. +-} + +instance HasOccName Name where + occName = nameOccName + +nameUnique :: Name -> Unique +nameOccName :: Name -> OccName +nameModule :: HasDebugCallStack => Name -> Module +nameSrcLoc :: Name -> SrcLoc +nameSrcSpan :: Name -> SrcSpan + +nameUnique name = n_uniq name +nameOccName name = n_occ name +nameSrcLoc name = srcSpanStart (n_loc name) +nameSrcSpan name = n_loc name + +type instance SrcSpanLess Name = Name +instance HasSrcSpan Name where + composeSrcSpan (L sp n) = n {n_loc = sp} + decomposeSrcSpan n = L (n_loc n) n + + +{- +************************************************************************ +* * +\subsection{Predicates on names} +* * +************************************************************************ +-} + +isInternalName :: Name -> Bool +isExternalName :: Name -> Bool +isSystemName :: Name -> Bool +isWiredInName :: Name -> Bool + +isWiredInName (Name {n_sort = WiredIn _ _ _}) = True +isWiredInName _ = False + +wiredInNameTyThing_maybe :: Name -> Maybe TyThing +wiredInNameTyThing_maybe (Name {n_sort = WiredIn _ thing _}) = Just thing +wiredInNameTyThing_maybe _ = Nothing + +isBuiltInSyntax :: Name -> Bool +isBuiltInSyntax (Name {n_sort = WiredIn _ _ BuiltInSyntax}) = True +isBuiltInSyntax _ = False + +isExternalName (Name {n_sort = External _}) = True +isExternalName (Name {n_sort = WiredIn _ _ _}) = True +isExternalName _ = False + +isInternalName name = not (isExternalName name) + +isHoleName :: Name -> Bool +isHoleName = isHoleModule . nameModule + +nameModule name = + nameModule_maybe name `orElse` + pprPanic "nameModule" (ppr (n_sort name) <+> ppr name) + +nameModule_maybe :: Name -> Maybe Module +nameModule_maybe (Name { n_sort = External mod}) = Just mod +nameModule_maybe (Name { n_sort = WiredIn mod _ _}) = Just mod +nameModule_maybe _ = Nothing + +nameIsLocalOrFrom :: Module -> Name -> Bool +-- ^ Returns True if the name is +-- (a) Internal +-- (b) External but from the specified module +-- (c) External but from the 'interactive' package +-- +-- The key idea is that +-- False means: the entity is defined in some other module +-- you can find the details (type, fixity, instances) +-- in some interface file +-- those details will be stored in the EPT or HPT +-- +-- True means: the entity is defined in this module or earlier in +-- the GHCi session +-- you can find details (type, fixity, instances) in the +-- TcGblEnv or TcLclEnv +-- +-- The isInteractiveModule part is because successive interactions of a GHCi session +-- each give rise to a fresh module (Ghci1, Ghci2, etc), but they all come +-- from the magic 'interactive' package; and all the details are kept in the +-- TcLclEnv, TcGblEnv, NOT in the HPT or EPT. +-- See Note [The interactive package] in HscTypes + +nameIsLocalOrFrom from name + | Just mod <- nameModule_maybe name = from == mod || isInteractiveModule mod + | otherwise = True + +nameIsHomePackage :: Module -> Name -> Bool +-- True if the Name is defined in module of this package +nameIsHomePackage this_mod + = \nm -> case n_sort nm of + External nm_mod -> moduleUnitId nm_mod == this_pkg + WiredIn nm_mod _ _ -> moduleUnitId nm_mod == this_pkg + Internal -> True + System -> False + where + this_pkg = moduleUnitId this_mod + +nameIsHomePackageImport :: Module -> Name -> Bool +-- True if the Name is defined in module of this package +-- /other than/ the this_mod +nameIsHomePackageImport this_mod + = \nm -> case nameModule_maybe nm of + Nothing -> False + Just nm_mod -> nm_mod /= this_mod + && moduleUnitId nm_mod == this_pkg + where + this_pkg = moduleUnitId this_mod + +-- | Returns True if the Name comes from some other package: neither this +-- package nor the interactive package. +nameIsFromExternalPackage :: UnitId -> Name -> Bool +nameIsFromExternalPackage this_pkg name + | Just mod <- nameModule_maybe name + , moduleUnitId mod /= this_pkg -- Not this package + , not (isInteractiveModule mod) -- Not the 'interactive' package + = True + | otherwise + = False + +isTyVarName :: Name -> Bool +isTyVarName name = isTvOcc (nameOccName name) + +isTyConName :: Name -> Bool +isTyConName name = isTcOcc (nameOccName name) + +isDataConName :: Name -> Bool +isDataConName name = isDataOcc (nameOccName name) + +isValName :: Name -> Bool +isValName name = isValOcc (nameOccName name) + +isVarName :: Name -> Bool +isVarName = isVarOcc . nameOccName + +isSystemName (Name {n_sort = System}) = True +isSystemName _ = False + +{- +************************************************************************ +* * +\subsection{Making names} +* * +************************************************************************ +-} + +-- | Create a name which is (for now at least) local to the current module and hence +-- does not need a 'Module' to disambiguate it from other 'Name's +mkInternalName :: Unique -> OccName -> SrcSpan -> Name +mkInternalName uniq occ loc = Name { n_uniq = uniq + , n_sort = Internal + , n_occ = occ + , n_loc = loc } + -- NB: You might worry that after lots of huffing and + -- puffing we might end up with two local names with distinct + -- uniques, but the same OccName. Indeed we can, but that's ok + -- * the insides of the compiler don't care: they use the Unique + -- * when printing for -ddump-xxx you can switch on -dppr-debug to get the + -- uniques if you get confused + -- * for interface files we tidyCore first, which makes + -- the OccNames distinct when they need to be + +mkClonedInternalName :: Unique -> Name -> Name +mkClonedInternalName uniq (Name { n_occ = occ, n_loc = loc }) + = Name { n_uniq = uniq, n_sort = Internal + , n_occ = occ, n_loc = loc } + +mkDerivedInternalName :: (OccName -> OccName) -> Unique -> Name -> Name +mkDerivedInternalName derive_occ uniq (Name { n_occ = occ, n_loc = loc }) + = Name { n_uniq = uniq, n_sort = Internal + , n_occ = derive_occ occ, n_loc = loc } + +-- | Create a name which definitely originates in the given module +mkExternalName :: Unique -> Module -> OccName -> SrcSpan -> Name +-- WATCH OUT! External Names should be in the Name Cache +-- (see Note [The Name Cache] in IfaceEnv), so don't just call mkExternalName +-- with some fresh unique without populating the Name Cache +mkExternalName uniq mod occ loc + = Name { n_uniq = uniq, n_sort = External mod, + n_occ = occ, n_loc = loc } + +-- | Create a name which is actually defined by the compiler itself +mkWiredInName :: Module -> OccName -> Unique -> TyThing -> BuiltInSyntax -> Name +mkWiredInName mod occ uniq thing built_in + = Name { n_uniq = uniq, + n_sort = WiredIn mod thing built_in, + n_occ = occ, n_loc = wiredInSrcSpan } + +-- | Create a name brought into being by the compiler +mkSystemName :: Unique -> OccName -> Name +mkSystemName uniq occ = mkSystemNameAt uniq occ noSrcSpan + +mkSystemNameAt :: Unique -> OccName -> SrcSpan -> Name +mkSystemNameAt uniq occ loc = Name { n_uniq = uniq, n_sort = System + , n_occ = occ, n_loc = loc } + +mkSystemVarName :: Unique -> FastString -> Name +mkSystemVarName uniq fs = mkSystemName uniq (mkVarOccFS fs) + +mkSysTvName :: Unique -> FastString -> Name +mkSysTvName uniq fs = mkSystemName uniq (mkTyVarOccFS fs) + +-- | Make a name for a foreign call +mkFCallName :: Unique -> String -> Name +mkFCallName uniq str = mkInternalName uniq (mkVarOcc str) noSrcSpan + -- The encoded string completely describes the ccall + +-- When we renumber/rename things, we need to be +-- able to change a Name's Unique to match the cached +-- one in the thing it's the name of. If you know what I mean. +setNameUnique :: Name -> Unique -> Name +setNameUnique name uniq = name {n_uniq = uniq} + +-- This is used for hsigs: we want to use the name of the originally exported +-- entity, but edit the location to refer to the reexport site +setNameLoc :: Name -> SrcSpan -> Name +setNameLoc name loc = name {n_loc = loc} + +tidyNameOcc :: Name -> OccName -> Name +-- We set the OccName of a Name when tidying +-- In doing so, we change System --> Internal, so that when we print +-- it we don't get the unique by default. It's tidy now! +tidyNameOcc name@(Name { n_sort = System }) occ = name { n_occ = occ, n_sort = Internal} +tidyNameOcc name occ = name { n_occ = occ } + +-- | Make the 'Name' into an internal name, regardless of what it was to begin with +localiseName :: Name -> Name +localiseName n = n { n_sort = Internal } + +{- +************************************************************************ +* * +\subsection{Hashing and comparison} +* * +************************************************************************ +-} + +cmpName :: Name -> Name -> Ordering +cmpName n1 n2 = n_uniq n1 `nonDetCmpUnique` n_uniq n2 + +-- | Compare Names lexicographically +-- This only works for Names that originate in the source code or have been +-- tidied. +stableNameCmp :: Name -> Name -> Ordering +stableNameCmp (Name { n_sort = s1, n_occ = occ1 }) + (Name { n_sort = s2, n_occ = occ2 }) + = (s1 `sort_cmp` s2) `thenCmp` (occ1 `compare` occ2) + -- The ordinary compare on OccNames is lexicographic + where + -- Later constructors are bigger + sort_cmp (External m1) (External m2) = m1 `stableModuleCmp` m2 + sort_cmp (External {}) _ = LT + sort_cmp (WiredIn {}) (External {}) = GT + sort_cmp (WiredIn m1 _ _) (WiredIn m2 _ _) = m1 `stableModuleCmp` m2 + sort_cmp (WiredIn {}) _ = LT + sort_cmp Internal (External {}) = GT + sort_cmp Internal (WiredIn {}) = GT + sort_cmp Internal Internal = EQ + sort_cmp Internal System = LT + sort_cmp System System = EQ + sort_cmp System _ = GT + +{- +************************************************************************ +* * +\subsection[Name-instances]{Instance declarations} +* * +************************************************************************ +-} + +-- | The same comments as for `Name`'s `Ord` instance apply. +instance Eq Name where + a == b = case (a `compare` b) of { EQ -> True; _ -> False } + a /= b = case (a `compare` b) of { EQ -> False; _ -> True } + +-- | __Caution__: This instance is implemented via `nonDetCmpUnique`, which +-- means that the ordering is not stable across deserialization or rebuilds. +-- +-- See `nonDetCmpUnique` for further information, and trac #15240 for a bug +-- caused by improper use of this instance. + +-- For a deterministic lexicographic ordering, use `stableNameCmp`. +instance Ord Name where + a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } + a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } + a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } + a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } + compare a b = cmpName a b + +instance Uniquable Name where + getUnique = nameUnique + +instance NamedThing Name where + getName n = n + +instance Data Name where + -- don't traverse? + toConstr _ = abstractConstr "Name" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "Name" + +{- +************************************************************************ +* * +\subsection{Binary} +* * +************************************************************************ +-} + +-- | Assumes that the 'Name' is a non-binding one. See +-- 'IfaceSyn.putIfaceTopBndr' and 'IfaceSyn.getIfaceTopBndr' for serializing +-- binding 'Name's. See 'UserData' for the rationale for this distinction. +instance Binary Name where + put_ bh name = + case getUserData bh of + UserData{ ud_put_nonbinding_name = put_name } -> put_name bh name + + get bh = + case getUserData bh of + UserData { ud_get_name = get_name } -> get_name bh + +{- +************************************************************************ +* * +\subsection{Pretty printing} +* * +************************************************************************ +-} + +instance Outputable Name where + ppr name = pprName name + +instance OutputableBndr Name where + pprBndr _ name = pprName name + pprInfixOcc = pprInfixName + pprPrefixOcc = pprPrefixName + +pprName :: Name -> SDoc +pprName (Name {n_sort = sort, n_uniq = uniq, n_occ = occ}) + = getPprStyle $ \ sty -> + case sort of + WiredIn mod _ builtin -> pprExternal sty uniq mod occ True builtin + External mod -> pprExternal sty uniq mod occ False UserSyntax + System -> pprSystem sty uniq occ + Internal -> pprInternal sty uniq occ + +-- | Print the string of Name unqualifiedly directly. +pprNameUnqualified :: Name -> SDoc +pprNameUnqualified Name { n_occ = occ } = ppr_occ_name occ + +pprExternal :: PprStyle -> Unique -> Module -> OccName -> Bool -> BuiltInSyntax -> SDoc +pprExternal sty uniq mod occ is_wired is_builtin + | codeStyle sty = ppr mod <> char '_' <> ppr_z_occ_name occ + -- In code style, always qualify + -- ToDo: maybe we could print all wired-in things unqualified + -- in code style, to reduce symbol table bloat? + | debugStyle sty = pp_mod <> ppr_occ_name occ + <> braces (hsep [if is_wired then text "(w)" else empty, + pprNameSpaceBrief (occNameSpace occ), + pprUnique uniq]) + | BuiltInSyntax <- is_builtin = ppr_occ_name occ -- Never qualify builtin syntax + | otherwise = + if isHoleModule mod + then case qualName sty mod occ of + NameUnqual -> ppr_occ_name occ + _ -> braces (ppr (moduleName mod) <> dot <> ppr_occ_name occ) + else pprModulePrefix sty mod occ <> ppr_occ_name occ + where + pp_mod = sdocWithDynFlags $ \dflags -> + if gopt Opt_SuppressModulePrefixes dflags + then empty + else ppr mod <> dot + +pprInternal :: PprStyle -> Unique -> OccName -> SDoc +pprInternal sty uniq occ + | codeStyle sty = pprUniqueAlways uniq + | debugStyle sty = ppr_occ_name occ <> braces (hsep [pprNameSpaceBrief (occNameSpace occ), + pprUnique uniq]) + | dumpStyle sty = ppr_occ_name occ <> ppr_underscore_unique uniq + -- For debug dumps, we're not necessarily dumping + -- tidied code, so we need to print the uniques. + | otherwise = ppr_occ_name occ -- User style + +-- Like Internal, except that we only omit the unique in Iface style +pprSystem :: PprStyle -> Unique -> OccName -> SDoc +pprSystem sty uniq occ + | codeStyle sty = pprUniqueAlways uniq + | debugStyle sty = ppr_occ_name occ <> ppr_underscore_unique uniq + <> braces (pprNameSpaceBrief (occNameSpace occ)) + | otherwise = ppr_occ_name occ <> ppr_underscore_unique uniq + -- If the tidy phase hasn't run, the OccName + -- is unlikely to be informative (like 's'), + -- so print the unique + + +pprModulePrefix :: PprStyle -> Module -> OccName -> SDoc +-- Print the "M." part of a name, based on whether it's in scope or not +-- See Note [Printing original names] in HscTypes +pprModulePrefix sty mod occ = sdocWithDynFlags $ \dflags -> + if gopt Opt_SuppressModulePrefixes dflags + then empty + else + case qualName sty mod occ of -- See Outputable.QualifyName: + NameQual modname -> ppr modname <> dot -- Name is in scope + NameNotInScope1 -> ppr mod <> dot -- Not in scope + NameNotInScope2 -> ppr (moduleUnitId mod) <> colon -- Module not in + <> ppr (moduleName mod) <> dot -- scope either + NameUnqual -> empty -- In scope unqualified + +pprUnique :: Unique -> SDoc +-- Print a unique unless we are suppressing them +pprUnique uniq + = sdocWithDynFlags $ \dflags -> + ppUnless (gopt Opt_SuppressUniques dflags) $ + pprUniqueAlways uniq + +ppr_underscore_unique :: Unique -> SDoc +-- Print an underscore separating the name from its unique +-- But suppress it if we aren't printing the uniques anyway +ppr_underscore_unique uniq + = sdocWithDynFlags $ \dflags -> + ppUnless (gopt Opt_SuppressUniques dflags) $ + char '_' <> pprUniqueAlways uniq + +ppr_occ_name :: OccName -> SDoc +ppr_occ_name occ = ftext (occNameFS occ) + -- Don't use pprOccName; instead, just print the string of the OccName; + -- we print the namespace in the debug stuff above + +-- In code style, we Z-encode the strings. The results of Z-encoding each FastString are +-- cached behind the scenes in the FastString implementation. +ppr_z_occ_name :: OccName -> SDoc +ppr_z_occ_name occ = ztext (zEncodeFS (occNameFS occ)) + +-- Prints (if mod information is available) "Defined at " or +-- "Defined in " information for a Name. +pprDefinedAt :: Name -> SDoc +pprDefinedAt name = text "Defined" <+> pprNameDefnLoc name + +pprNameDefnLoc :: Name -> SDoc +-- Prints "at " or +-- or "in " depending on what info is available +pprNameDefnLoc name + = case nameSrcLoc name of + -- nameSrcLoc rather than nameSrcSpan + -- It seems less cluttered to show a location + -- rather than a span for the definition point + RealSrcLoc s -> text "at" <+> ppr s + UnhelpfulLoc s + | isInternalName name || isSystemName name + -> text "at" <+> ftext s + | otherwise + -> text "in" <+> quotes (ppr (nameModule name)) + + +-- | Get a string representation of a 'Name' that's unique and stable +-- across recompilations. Used for deterministic generation of binds for +-- derived instances. +-- eg. "$aeson_70dylHtv1FFGeai1IoxcQr$Data.Aeson.Types.Internal$String" +nameStableString :: Name -> String +nameStableString Name{..} = + nameSortStableString n_sort ++ "$" ++ occNameString n_occ + +nameSortStableString :: NameSort -> String +nameSortStableString System = "$_sys" +nameSortStableString Internal = "$_in" +nameSortStableString (External mod) = moduleStableString mod +nameSortStableString (WiredIn mod _ _) = moduleStableString mod + +{- +************************************************************************ +* * +\subsection{Overloaded functions related to Names} +* * +************************************************************************ +-} + +-- | A class allowing convenient access to the 'Name' of various datatypes +class NamedThing a where + getOccName :: a -> OccName + getName :: a -> Name + + getOccName n = nameOccName (getName n) -- Default method + +instance NamedThing e => NamedThing (Located e) where + getName = getName . unLoc + +getSrcLoc :: NamedThing a => a -> SrcLoc +getSrcSpan :: NamedThing a => a -> SrcSpan +getOccString :: NamedThing a => a -> String +getOccFS :: NamedThing a => a -> FastString + +getSrcLoc = nameSrcLoc . getName +getSrcSpan = nameSrcSpan . getName +getOccString = occNameString . getOccName +getOccFS = occNameFS . getOccName + +pprInfixName :: (Outputable a, NamedThing a) => a -> SDoc +-- See Outputable.pprPrefixVar, pprInfixVar; +-- add parens or back-quotes as appropriate +pprInfixName n = pprInfixVar (isSymOcc (getOccName n)) (ppr n) + +pprPrefixName :: NamedThing a => a -> SDoc +pprPrefixName thing = pprPrefixVar (isSymOcc (nameOccName name)) (ppr name) + where + name = getName thing diff --git a/compiler/basicTypes/Name.hs-boot b/compiler/basicTypes/Name.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/basicTypes/Name.hs-boot @@ -0,0 +1,5 @@ +module Name where + +import GhcPrelude () + +data Name diff --git a/compiler/basicTypes/NameCache.hs b/compiler/basicTypes/NameCache.hs new file mode 100644 --- /dev/null +++ b/compiler/basicTypes/NameCache.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} + +-- | The Name Cache +module NameCache + ( lookupOrigNameCache + , extendOrigNameCache + , extendNameCache + , initNameCache + , NameCache(..), OrigNameCache + ) where + +import GhcPrelude + +import Module +import Name +import UniqSupply +import TysWiredIn +import Util +import Outputable +import PrelNames + +#include "HsVersions.h" + +{- + +Note [The Name Cache] +~~~~~~~~~~~~~~~~~~~~~ +The Name Cache makes sure that, during any invocation of GHC, each +External Name "M.x" has one, and only one globally-agreed Unique. + +* The first time we come across M.x we make up a Unique and record that + association in the Name Cache. + +* When we come across "M.x" again, we look it up in the Name Cache, + and get a hit. + +The functions newGlobalBinder, allocateGlobalBinder do the main work. +When you make an External name, you should probably be calling one +of them. + + +Note [Built-in syntax and the OrigNameCache] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Built-in syntax like tuples and unboxed sums are quite ubiquitous. To lower +their cost we use two tricks, + + a. We specially encode tuple and sum Names in interface files' symbol tables + to avoid having to look up their names while loading interface files. + Namely these names are encoded as by their Uniques. We know how to get from + a Unique back to the Name which it represents via the mapping defined in + the SumTupleUniques module. See Note [Symbol table representation of names] + in BinIface and for details. + + b. We don't include them in the Orig name cache but instead parse their + OccNames (in isBuiltInOcc_maybe) to avoid bloating the name cache with + them. + +Why is the second measure necessary? Good question; afterall, 1) the parser +emits built-in syntax directly as Exact RdrNames, and 2) built-in syntax never +needs to looked-up during interface loading due to (a). It turns out that there +are two reasons why we might look up an Orig RdrName for built-in syntax, + + * If you use setRdrNameSpace on an Exact RdrName it may be + turned into an Orig RdrName. + + * Template Haskell turns a BuiltInSyntax Name into a TH.NameG + (DsMeta.globalVar), and parses a NameG into an Orig RdrName + (Convert.thRdrName). So, e.g. $(do { reify '(,); ... }) will + go this route (#8954). + +-} + +-- | Per-module cache of original 'OccName's given 'Name's +type OrigNameCache = ModuleEnv (OccEnv Name) + +lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name +lookupOrigNameCache nc mod occ + | mod == gHC_TYPES || mod == gHC_PRIM || mod == gHC_TUPLE + , Just name <- isBuiltInOcc_maybe occ + = -- See Note [Known-key names], 3(c) in PrelNames + -- Special case for tuples; there are too many + -- of them to pre-populate the original-name cache + Just name + + | otherwise + = case lookupModuleEnv nc mod of + Nothing -> Nothing + Just occ_env -> lookupOccEnv occ_env occ + +extendOrigNameCache :: OrigNameCache -> Name -> OrigNameCache +extendOrigNameCache nc name + = ASSERT2( isExternalName name, ppr name ) + extendNameCache nc (nameModule name) (nameOccName name) name + +extendNameCache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache +extendNameCache nc mod occ name + = extendModuleEnvWith combine nc mod (unitOccEnv occ name) + where + combine _ occ_env = extendOccEnv occ_env occ name + +-- | The NameCache makes sure that there is just one Unique assigned for +-- each original name; i.e. (module-name, occ-name) pair and provides +-- something of a lookup mechanism for those names. +data NameCache + = NameCache { nsUniqs :: !UniqSupply, + -- ^ Supply of uniques + nsNames :: !OrigNameCache + -- ^ Ensures that one original name gets one unique + } + +-- | Return a function to atomically update the name cache. +initNameCache :: UniqSupply -> [Name] -> NameCache +initNameCache us names + = NameCache { nsUniqs = us, + nsNames = initOrigNames names } + +initOrigNames :: [Name] -> OrigNameCache +initOrigNames names = foldl' extendOrigNameCache emptyModuleEnv names diff --git a/compiler/basicTypes/NameEnv.hs b/compiler/basicTypes/NameEnv.hs new file mode 100644 --- /dev/null +++ b/compiler/basicTypes/NameEnv.hs @@ -0,0 +1,154 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[NameEnv]{@NameEnv@: name environments} +-} + +{-# LANGUAGE CPP #-} +module NameEnv ( + -- * Var, Id and TyVar environments (maps) + NameEnv, + + -- ** Manipulating these environments + mkNameEnv, + emptyNameEnv, isEmptyNameEnv, + unitNameEnv, nameEnvElts, + extendNameEnv_C, extendNameEnv_Acc, extendNameEnv, + extendNameEnvList, extendNameEnvList_C, + filterNameEnv, anyNameEnv, + plusNameEnv, plusNameEnv_C, alterNameEnv, + lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, delListFromNameEnv, + elemNameEnv, mapNameEnv, disjointNameEnv, + + DNameEnv, + + emptyDNameEnv, + lookupDNameEnv, + mapDNameEnv, + alterDNameEnv, + -- ** Dependency analysis + depAnal + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import Digraph +import Name +import UniqFM +import UniqDFM +import Maybes + +{- +************************************************************************ +* * +\subsection{Name environment} +* * +************************************************************************ +-} + +{- +Note [depAnal determinism] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +depAnal is deterministic provided it gets the nodes in a deterministic order. +The order of lists that get_defs and get_uses return doesn't matter, as these +are only used to construct the edges, and stronglyConnCompFromEdgedVertices is +deterministic even when the edges are not in deterministic order as explained +in Note [Deterministic SCC] in Digraph. +-} + +depAnal :: (node -> [Name]) -- Defs + -> (node -> [Name]) -- Uses + -> [node] + -> [SCC node] +-- Perform dependency analysis on a group of definitions, +-- where each definition may define more than one Name +-- +-- The get_defs and get_uses functions are called only once per node +depAnal get_defs get_uses nodes + = stronglyConnCompFromEdgedVerticesUniq (map mk_node keyed_nodes) + where + keyed_nodes = nodes `zip` [(1::Int)..] + mk_node (node, key) = + DigraphNode node key (mapMaybe (lookupNameEnv key_map) (get_uses node)) + + key_map :: NameEnv Int -- Maps a Name to the key of the decl that defines it + key_map = mkNameEnv [(name,key) | (node, key) <- keyed_nodes, name <- get_defs node] + +{- +************************************************************************ +* * +\subsection{Name environment} +* * +************************************************************************ +-} + +-- | Name Environment +type NameEnv a = UniqFM a -- Domain is Name + +emptyNameEnv :: NameEnv a +isEmptyNameEnv :: NameEnv a -> Bool +mkNameEnv :: [(Name,a)] -> NameEnv a +nameEnvElts :: NameEnv a -> [a] +alterNameEnv :: (Maybe a-> Maybe a) -> NameEnv a -> Name -> NameEnv a +extendNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a +extendNameEnv_Acc :: (a->b->b) -> (a->b) -> NameEnv b -> Name -> a -> NameEnv b +extendNameEnv :: NameEnv a -> Name -> a -> NameEnv a +plusNameEnv :: NameEnv a -> NameEnv a -> NameEnv a +plusNameEnv_C :: (a->a->a) -> NameEnv a -> NameEnv a -> NameEnv a +extendNameEnvList :: NameEnv a -> [(Name,a)] -> NameEnv a +extendNameEnvList_C :: (a->a->a) -> NameEnv a -> [(Name,a)] -> NameEnv a +delFromNameEnv :: NameEnv a -> Name -> NameEnv a +delListFromNameEnv :: NameEnv a -> [Name] -> NameEnv a +elemNameEnv :: Name -> NameEnv a -> Bool +unitNameEnv :: Name -> a -> NameEnv a +lookupNameEnv :: NameEnv a -> Name -> Maybe a +lookupNameEnv_NF :: NameEnv a -> Name -> a +filterNameEnv :: (elt -> Bool) -> NameEnv elt -> NameEnv elt +anyNameEnv :: (elt -> Bool) -> NameEnv elt -> Bool +mapNameEnv :: (elt1 -> elt2) -> NameEnv elt1 -> NameEnv elt2 +disjointNameEnv :: NameEnv a -> NameEnv a -> Bool + +nameEnvElts x = eltsUFM x +emptyNameEnv = emptyUFM +isEmptyNameEnv = isNullUFM +unitNameEnv x y = unitUFM x y +extendNameEnv x y z = addToUFM x y z +extendNameEnvList x l = addListToUFM x l +lookupNameEnv x y = lookupUFM x y +alterNameEnv = alterUFM +mkNameEnv l = listToUFM l +elemNameEnv x y = elemUFM x y +plusNameEnv x y = plusUFM x y +plusNameEnv_C f x y = plusUFM_C f x y +extendNameEnv_C f x y z = addToUFM_C f x y z +mapNameEnv f x = mapUFM f x +extendNameEnv_Acc x y z a b = addToUFM_Acc x y z a b +extendNameEnvList_C x y z = addListToUFM_C x y z +delFromNameEnv x y = delFromUFM x y +delListFromNameEnv x y = delListFromUFM x y +filterNameEnv x y = filterUFM x y +anyNameEnv f x = foldUFM ((||) . f) False x +disjointNameEnv x y = isNullUFM (intersectUFM x y) + +lookupNameEnv_NF env n = expectJust "lookupNameEnv_NF" (lookupNameEnv env n) + +-- | Deterministic Name Environment +-- +-- See Note [Deterministic UniqFM] in UniqDFM for explanation why we need +-- DNameEnv. +type DNameEnv a = UniqDFM a + +emptyDNameEnv :: DNameEnv a +emptyDNameEnv = emptyUDFM + +lookupDNameEnv :: DNameEnv a -> Name -> Maybe a +lookupDNameEnv = lookupUDFM + +mapDNameEnv :: (a -> b) -> DNameEnv a -> DNameEnv b +mapDNameEnv = mapUDFM + +alterDNameEnv :: (Maybe a -> Maybe a) -> DNameEnv a -> Name -> DNameEnv a +alterDNameEnv = alterUDFM diff --git a/compiler/basicTypes/NameSet.hs b/compiler/basicTypes/NameSet.hs new file mode 100644 --- /dev/null +++ b/compiler/basicTypes/NameSet.hs @@ -0,0 +1,214 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1998 +-} + +{-# LANGUAGE CPP #-} +module NameSet ( + -- * Names set type + NameSet, + + -- ** Manipulating these sets + emptyNameSet, unitNameSet, mkNameSet, unionNameSet, unionNameSets, + minusNameSet, elemNameSet, extendNameSet, extendNameSetList, + delFromNameSet, delListFromNameSet, isEmptyNameSet, filterNameSet, + intersectsNameSet, intersectNameSet, + nameSetAny, nameSetAll, nameSetElemsStable, + + -- * Free variables + FreeVars, + + -- ** Manipulating sets of free variables + isEmptyFVs, emptyFVs, plusFVs, plusFV, + mkFVs, addOneFV, unitFV, delFV, delFVs, + intersectFVs, + + -- * Defs and uses + Defs, Uses, DefUse, DefUses, + + -- ** Manipulating defs and uses + emptyDUs, usesOnly, mkDUs, plusDU, + findUses, duDefs, duUses, allUses + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import Name +import UniqSet +import Data.List (sortBy) + +{- +************************************************************************ +* * +\subsection[Sets of names} +* * +************************************************************************ +-} + +type NameSet = UniqSet Name + +emptyNameSet :: NameSet +unitNameSet :: Name -> NameSet +extendNameSetList :: NameSet -> [Name] -> NameSet +extendNameSet :: NameSet -> Name -> NameSet +mkNameSet :: [Name] -> NameSet +unionNameSet :: NameSet -> NameSet -> NameSet +unionNameSets :: [NameSet] -> NameSet +minusNameSet :: NameSet -> NameSet -> NameSet +elemNameSet :: Name -> NameSet -> Bool +isEmptyNameSet :: NameSet -> Bool +delFromNameSet :: NameSet -> Name -> NameSet +delListFromNameSet :: NameSet -> [Name] -> NameSet +filterNameSet :: (Name -> Bool) -> NameSet -> NameSet +intersectNameSet :: NameSet -> NameSet -> NameSet +intersectsNameSet :: NameSet -> NameSet -> Bool +-- ^ True if there is a non-empty intersection. +-- @s1 `intersectsNameSet` s2@ doesn't compute @s2@ if @s1@ is empty + +isEmptyNameSet = isEmptyUniqSet +emptyNameSet = emptyUniqSet +unitNameSet = unitUniqSet +mkNameSet = mkUniqSet +extendNameSetList = addListToUniqSet +extendNameSet = addOneToUniqSet +unionNameSet = unionUniqSets +unionNameSets = unionManyUniqSets +minusNameSet = minusUniqSet +elemNameSet = elementOfUniqSet +delFromNameSet = delOneFromUniqSet +filterNameSet = filterUniqSet +intersectNameSet = intersectUniqSets + +delListFromNameSet set ns = foldl' delFromNameSet set ns + +intersectsNameSet s1 s2 = not (isEmptyNameSet (s1 `intersectNameSet` s2)) + +nameSetAny :: (Name -> Bool) -> NameSet -> Bool +nameSetAny = uniqSetAny + +nameSetAll :: (Name -> Bool) -> NameSet -> Bool +nameSetAll = uniqSetAll + +-- | Get the elements of a NameSet with some stable ordering. +-- This only works for Names that originate in the source code or have been +-- tidied. +-- See Note [Deterministic UniqFM] to learn about nondeterminism +nameSetElemsStable :: NameSet -> [Name] +nameSetElemsStable ns = + sortBy stableNameCmp $ nonDetEltsUniqSet ns + -- It's OK to use nonDetEltsUniqSet here because we immediately sort + -- with stableNameCmp + +{- +************************************************************************ +* * +\subsection{Free variables} +* * +************************************************************************ + +These synonyms are useful when we are thinking of free variables +-} + +type FreeVars = NameSet + +plusFV :: FreeVars -> FreeVars -> FreeVars +addOneFV :: FreeVars -> Name -> FreeVars +unitFV :: Name -> FreeVars +emptyFVs :: FreeVars +plusFVs :: [FreeVars] -> FreeVars +mkFVs :: [Name] -> FreeVars +delFV :: Name -> FreeVars -> FreeVars +delFVs :: [Name] -> FreeVars -> FreeVars +intersectFVs :: FreeVars -> FreeVars -> FreeVars + +isEmptyFVs :: NameSet -> Bool +isEmptyFVs = isEmptyNameSet +emptyFVs = emptyNameSet +plusFVs = unionNameSets +plusFV = unionNameSet +mkFVs = mkNameSet +addOneFV = extendNameSet +unitFV = unitNameSet +delFV n s = delFromNameSet s n +delFVs ns s = delListFromNameSet s ns +intersectFVs = intersectNameSet + +{- +************************************************************************ +* * + Defs and uses +* * +************************************************************************ +-} + +-- | A set of names that are defined somewhere +type Defs = NameSet + +-- | A set of names that are used somewhere +type Uses = NameSet + +-- | @(Just ds, us) =>@ The use of any member of the @ds@ +-- implies that all the @us@ are used too. +-- Also, @us@ may mention @ds@. +-- +-- @Nothing =>@ Nothing is defined in this group, but +-- nevertheless all the uses are essential. +-- Used for instance declarations, for example +type DefUse = (Maybe Defs, Uses) + +-- | A number of 'DefUse's in dependency order: earlier 'Defs' scope over later 'Uses' +-- In a single (def, use) pair, the defs also scope over the uses +type DefUses = [DefUse] + +emptyDUs :: DefUses +emptyDUs = [] + +usesOnly :: Uses -> DefUses +usesOnly uses = [(Nothing, uses)] + +mkDUs :: [(Defs,Uses)] -> DefUses +mkDUs pairs = [(Just defs, uses) | (defs,uses) <- pairs] + +plusDU :: DefUses -> DefUses -> DefUses +plusDU = (++) + +duDefs :: DefUses -> Defs +duDefs dus = foldr get emptyNameSet dus + where + get (Nothing, _u1) d2 = d2 + get (Just d1, _u1) d2 = d1 `unionNameSet` d2 + +allUses :: DefUses -> Uses +-- ^ Just like 'duUses', but 'Defs' are not eliminated from the 'Uses' returned +allUses dus = foldr get emptyNameSet dus + where + get (_d1, u1) u2 = u1 `unionNameSet` u2 + +duUses :: DefUses -> Uses +-- ^ Collect all 'Uses', regardless of whether the group is itself used, +-- but remove 'Defs' on the way +duUses dus = foldr get emptyNameSet dus + where + get (Nothing, rhs_uses) uses = rhs_uses `unionNameSet` uses + get (Just defs, rhs_uses) uses = (rhs_uses `unionNameSet` uses) + `minusNameSet` defs + +findUses :: DefUses -> Uses -> Uses +-- ^ Given some 'DefUses' and some 'Uses', find all the uses, transitively. +-- The result is a superset of the input 'Uses'; and includes things defined +-- in the input 'DefUses' (but only if they are used) +findUses dus uses + = foldr get uses dus + where + get (Nothing, rhs_uses) uses + = rhs_uses `unionNameSet` uses + get (Just defs, rhs_uses) uses + | defs `intersectsNameSet` uses -- Used + || nameSetAny (startsWithUnderscore . nameOccName) defs + -- At least one starts with an "_", + -- so treat the group as used + = rhs_uses `unionNameSet` uses + | otherwise -- No def is used + = uses diff --git a/compiler/basicTypes/OccName.hs b/compiler/basicTypes/OccName.hs new file mode 100644 --- /dev/null +++ b/compiler/basicTypes/OccName.hs @@ -0,0 +1,925 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- #name_types# +-- GHC uses several kinds of name internally: +-- +-- * 'OccName.OccName' represents names as strings with just a little more information: +-- the \"namespace\" that the name came from, e.g. the namespace of value, type constructors or +-- data constructors +-- +-- * 'RdrName.RdrName': see "RdrName#name_types" +-- +-- * 'Name.Name': see "Name#name_types" +-- +-- * 'Id.Id': see "Id#name_types" +-- +-- * 'Var.Var': see "Var#name_types" + +module OccName ( + -- * The 'NameSpace' type + NameSpace, -- Abstract + + nameSpacesRelated, + + -- ** Construction + -- $real_vs_source_data_constructors + tcName, clsName, tcClsName, dataName, varName, + tvName, srcDataName, + + -- ** Pretty Printing + pprNameSpace, pprNonVarNameSpace, pprNameSpaceBrief, + + -- * The 'OccName' type + OccName, -- Abstract, instance of Outputable + pprOccName, + + -- ** Construction + mkOccName, mkOccNameFS, + mkVarOcc, mkVarOccFS, + mkDataOcc, mkDataOccFS, + mkTyVarOcc, mkTyVarOccFS, + mkTcOcc, mkTcOccFS, + mkClsOcc, mkClsOccFS, + mkDFunOcc, + setOccNameSpace, + demoteOccName, + HasOccName(..), + + -- ** Derived 'OccName's + isDerivedOccName, + mkDataConWrapperOcc, mkWorkerOcc, + mkMatcherOcc, mkBuilderOcc, + mkDefaultMethodOcc, isDefaultMethodOcc, isTypeableBindOcc, + mkNewTyCoOcc, mkClassOpAuxOcc, + mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, + mkClassDataConOcc, mkDictOcc, mkIPOcc, + mkSpecOcc, mkForeignExportOcc, mkRepEqOcc, + mkGenR, mkGen1R, + mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, + mkSuperDictSelOcc, mkSuperDictAuxOcc, + mkLocalOcc, mkMethodOcc, mkInstTyTcOcc, + mkInstTyCoOcc, mkEqPredCoOcc, + mkRecFldSelOcc, + mkTyConRepOcc, + + -- ** Deconstruction + occNameFS, occNameString, occNameSpace, + + isVarOcc, isTvOcc, isTcOcc, isDataOcc, isDataSymOcc, isSymOcc, isValOcc, + parenSymOcc, startsWithUnderscore, + + isTcClsNameSpace, isTvNameSpace, isDataConNameSpace, isVarNameSpace, isValNameSpace, + + -- * The 'OccEnv' type + OccEnv, emptyOccEnv, unitOccEnv, extendOccEnv, mapOccEnv, + lookupOccEnv, mkOccEnv, mkOccEnv_C, extendOccEnvList, elemOccEnv, + occEnvElts, foldOccEnv, plusOccEnv, plusOccEnv_C, extendOccEnv_C, + extendOccEnv_Acc, filterOccEnv, delListFromOccEnv, delFromOccEnv, + alterOccEnv, pprOccEnv, + + -- * The 'OccSet' type + OccSet, emptyOccSet, unitOccSet, mkOccSet, extendOccSet, + extendOccSetList, + unionOccSets, unionManyOccSets, minusOccSet, elemOccSet, + isEmptyOccSet, intersectOccSet, intersectsOccSet, + filterOccSet, + + -- * Tidying up + TidyOccEnv, emptyTidyOccEnv, initTidyOccEnv, + tidyOccName, avoidClashesOccEnv, + + -- FsEnv + FastStringEnv, emptyFsEnv, lookupFsEnv, extendFsEnv, mkFsEnv + ) where + +import GhcPrelude + +import Util +import Unique +import DynFlags +import UniqFM +import UniqSet +import FastString +import FastStringEnv +import Outputable +import Lexeme +import Binary +import Control.DeepSeq +import Data.Char +import Data.Data + +{- +************************************************************************ +* * +\subsection{Name space} +* * +************************************************************************ +-} + +data NameSpace = VarName -- Variables, including "real" data constructors + | DataName -- "Source" data constructors + | TvName -- Type variables + | TcClsName -- Type constructors and classes; Haskell has them + -- in the same name space for now. + deriving( Eq, Ord ) + +-- Note [Data Constructors] +-- see also: Note [Data Constructor Naming] in DataCon.hs +-- +-- $real_vs_source_data_constructors +-- There are two forms of data constructor: +-- +-- [Source data constructors] The data constructors mentioned in Haskell source code +-- +-- [Real data constructors] The data constructors of the representation type, which may not be the same as the source type +-- +-- For example: +-- +-- > data T = T !(Int, Int) +-- +-- The source datacon has type @(Int, Int) -> T@ +-- The real datacon has type @Int -> Int -> T@ +-- +-- GHC chooses a representation based on the strictness etc. + +tcName, clsName, tcClsName :: NameSpace +dataName, srcDataName :: NameSpace +tvName, varName :: NameSpace + +-- Though type constructors and classes are in the same name space now, +-- the NameSpace type is abstract, so we can easily separate them later +tcName = TcClsName -- Type constructors +clsName = TcClsName -- Classes +tcClsName = TcClsName -- Not sure which! + +dataName = DataName +srcDataName = DataName -- Haskell-source data constructors should be + -- in the Data name space + +tvName = TvName +varName = VarName + +isDataConNameSpace :: NameSpace -> Bool +isDataConNameSpace DataName = True +isDataConNameSpace _ = False + +isTcClsNameSpace :: NameSpace -> Bool +isTcClsNameSpace TcClsName = True +isTcClsNameSpace _ = False + +isTvNameSpace :: NameSpace -> Bool +isTvNameSpace TvName = True +isTvNameSpace _ = False + +isVarNameSpace :: NameSpace -> Bool -- Variables or type variables, but not constructors +isVarNameSpace TvName = True +isVarNameSpace VarName = True +isVarNameSpace _ = False + +isValNameSpace :: NameSpace -> Bool +isValNameSpace DataName = True +isValNameSpace VarName = True +isValNameSpace _ = False + +pprNameSpace :: NameSpace -> SDoc +pprNameSpace DataName = text "data constructor" +pprNameSpace VarName = text "variable" +pprNameSpace TvName = text "type variable" +pprNameSpace TcClsName = text "type constructor or class" + +pprNonVarNameSpace :: NameSpace -> SDoc +pprNonVarNameSpace VarName = empty +pprNonVarNameSpace ns = pprNameSpace ns + +pprNameSpaceBrief :: NameSpace -> SDoc +pprNameSpaceBrief DataName = char 'd' +pprNameSpaceBrief VarName = char 'v' +pprNameSpaceBrief TvName = text "tv" +pprNameSpaceBrief TcClsName = text "tc" + +-- demoteNameSpace lowers the NameSpace if possible. We can not know +-- in advance, since a TvName can appear in an HsTyVar. +-- See Note [Demotion] in RnEnv +demoteNameSpace :: NameSpace -> Maybe NameSpace +demoteNameSpace VarName = Nothing +demoteNameSpace DataName = Nothing +demoteNameSpace TvName = Nothing +demoteNameSpace TcClsName = Just DataName + +{- +************************************************************************ +* * +\subsection[Name-pieces-datatypes]{The @OccName@ datatypes} +* * +************************************************************************ +-} + +-- | Occurrence Name +-- +-- In this context that means: +-- "classified (i.e. as a type name, value name, etc) but not qualified +-- and not yet resolved" +data OccName = OccName + { occNameSpace :: !NameSpace + , occNameFS :: !FastString + } + +instance Eq OccName where + (OccName sp1 s1) == (OccName sp2 s2) = s1 == s2 && sp1 == sp2 + +instance Ord OccName where + -- Compares lexicographically, *not* by Unique of the string + compare (OccName sp1 s1) (OccName sp2 s2) + = (s1 `compare` s2) `thenCmp` (sp1 `compare` sp2) + +instance Data OccName where + -- don't traverse? + toConstr _ = abstractConstr "OccName" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "OccName" + +instance HasOccName OccName where + occName = id + +instance NFData OccName where + rnf x = x `seq` () + +{- +************************************************************************ +* * +\subsection{Printing} +* * +************************************************************************ +-} + +instance Outputable OccName where + ppr = pprOccName + +instance OutputableBndr OccName where + pprBndr _ = ppr + pprInfixOcc n = pprInfixVar (isSymOcc n) (ppr n) + pprPrefixOcc n = pprPrefixVar (isSymOcc n) (ppr n) + +pprOccName :: OccName -> SDoc +pprOccName (OccName sp occ) + = getPprStyle $ \ sty -> + if codeStyle sty + then ztext (zEncodeFS occ) + else pp_occ <> pp_debug sty + where + pp_debug sty | debugStyle sty = braces (pprNameSpaceBrief sp) + | otherwise = empty + + pp_occ = sdocWithDynFlags $ \dflags -> + if gopt Opt_SuppressUniques dflags + then text (strip_th_unique (unpackFS occ)) + else ftext occ + + -- See Note [Suppressing uniques in OccNames] + strip_th_unique ('[' : c : _) | isAlphaNum c = [] + strip_th_unique (c : cs) = c : strip_th_unique cs + strip_th_unique [] = [] + +{- +Note [Suppressing uniques in OccNames] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This is a hack to de-wobblify the OccNames that contain uniques from +Template Haskell that have been turned into a string in the OccName. +See Note [Unique OccNames from Template Haskell] in Convert.hs + +************************************************************************ +* * +\subsection{Construction} +* * +************************************************************************ +-} + +mkOccName :: NameSpace -> String -> OccName +mkOccName occ_sp str = OccName occ_sp (mkFastString str) + +mkOccNameFS :: NameSpace -> FastString -> OccName +mkOccNameFS occ_sp fs = OccName occ_sp fs + +mkVarOcc :: String -> OccName +mkVarOcc s = mkOccName varName s + +mkVarOccFS :: FastString -> OccName +mkVarOccFS fs = mkOccNameFS varName fs + +mkDataOcc :: String -> OccName +mkDataOcc = mkOccName dataName + +mkDataOccFS :: FastString -> OccName +mkDataOccFS = mkOccNameFS dataName + +mkTyVarOcc :: String -> OccName +mkTyVarOcc = mkOccName tvName + +mkTyVarOccFS :: FastString -> OccName +mkTyVarOccFS fs = mkOccNameFS tvName fs + +mkTcOcc :: String -> OccName +mkTcOcc = mkOccName tcName + +mkTcOccFS :: FastString -> OccName +mkTcOccFS = mkOccNameFS tcName + +mkClsOcc :: String -> OccName +mkClsOcc = mkOccName clsName + +mkClsOccFS :: FastString -> OccName +mkClsOccFS = mkOccNameFS clsName + +-- demoteOccName lowers the Namespace of OccName. +-- see Note [Demotion] +demoteOccName :: OccName -> Maybe OccName +demoteOccName (OccName space name) = do + space' <- demoteNameSpace space + return $ OccName space' name + +-- Name spaces are related if there is a chance to mean the one when one writes +-- the other, i.e. variables <-> data constructors and type variables <-> type constructors +nameSpacesRelated :: NameSpace -> NameSpace -> Bool +nameSpacesRelated ns1 ns2 = ns1 == ns2 || otherNameSpace ns1 == ns2 + +otherNameSpace :: NameSpace -> NameSpace +otherNameSpace VarName = DataName +otherNameSpace DataName = VarName +otherNameSpace TvName = TcClsName +otherNameSpace TcClsName = TvName + + + +{- | Other names in the compiler add additional information to an OccName. +This class provides a consistent way to access the underlying OccName. -} +class HasOccName name where + occName :: name -> OccName + +{- +************************************************************************ +* * + Environments +* * +************************************************************************ + +OccEnvs are used mainly for the envts in ModIfaces. + +Note [The Unique of an OccName] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +They are efficient, because FastStrings have unique Int# keys. We assume +this key is less than 2^24, and indeed FastStrings are allocated keys +sequentially starting at 0. + +So we can make a Unique using + mkUnique ns key :: Unique +where 'ns' is a Char representing the name space. This in turn makes it +easy to build an OccEnv. +-} + +instance Uniquable OccName where + -- See Note [The Unique of an OccName] + getUnique (OccName VarName fs) = mkVarOccUnique fs + getUnique (OccName DataName fs) = mkDataOccUnique fs + getUnique (OccName TvName fs) = mkTvOccUnique fs + getUnique (OccName TcClsName fs) = mkTcOccUnique fs + +newtype OccEnv a = A (UniqFM a) + deriving Data + +emptyOccEnv :: OccEnv a +unitOccEnv :: OccName -> a -> OccEnv a +extendOccEnv :: OccEnv a -> OccName -> a -> OccEnv a +extendOccEnvList :: OccEnv a -> [(OccName, a)] -> OccEnv a +lookupOccEnv :: OccEnv a -> OccName -> Maybe a +mkOccEnv :: [(OccName,a)] -> OccEnv a +mkOccEnv_C :: (a -> a -> a) -> [(OccName,a)] -> OccEnv a +elemOccEnv :: OccName -> OccEnv a -> Bool +foldOccEnv :: (a -> b -> b) -> b -> OccEnv a -> b +occEnvElts :: OccEnv a -> [a] +extendOccEnv_C :: (a->a->a) -> OccEnv a -> OccName -> a -> OccEnv a +extendOccEnv_Acc :: (a->b->b) -> (a->b) -> OccEnv b -> OccName -> a -> OccEnv b +plusOccEnv :: OccEnv a -> OccEnv a -> OccEnv a +plusOccEnv_C :: (a->a->a) -> OccEnv a -> OccEnv a -> OccEnv a +mapOccEnv :: (a->b) -> OccEnv a -> OccEnv b +delFromOccEnv :: OccEnv a -> OccName -> OccEnv a +delListFromOccEnv :: OccEnv a -> [OccName] -> OccEnv a +filterOccEnv :: (elt -> Bool) -> OccEnv elt -> OccEnv elt +alterOccEnv :: (Maybe elt -> Maybe elt) -> OccEnv elt -> OccName -> OccEnv elt + +emptyOccEnv = A emptyUFM +unitOccEnv x y = A $ unitUFM x y +extendOccEnv (A x) y z = A $ addToUFM x y z +extendOccEnvList (A x) l = A $ addListToUFM x l +lookupOccEnv (A x) y = lookupUFM x y +mkOccEnv l = A $ listToUFM l +elemOccEnv x (A y) = elemUFM x y +foldOccEnv a b (A c) = foldUFM a b c +occEnvElts (A x) = eltsUFM x +plusOccEnv (A x) (A y) = A $ plusUFM x y +plusOccEnv_C f (A x) (A y) = A $ plusUFM_C f x y +extendOccEnv_C f (A x) y z = A $ addToUFM_C f x y z +extendOccEnv_Acc f g (A x) y z = A $ addToUFM_Acc f g x y z +mapOccEnv f (A x) = A $ mapUFM f x +mkOccEnv_C comb l = A $ addListToUFM_C comb emptyUFM l +delFromOccEnv (A x) y = A $ delFromUFM x y +delListFromOccEnv (A x) y = A $ delListFromUFM x y +filterOccEnv x (A y) = A $ filterUFM x y +alterOccEnv fn (A y) k = A $ alterUFM fn y k + +instance Outputable a => Outputable (OccEnv a) where + ppr x = pprOccEnv ppr x + +pprOccEnv :: (a -> SDoc) -> OccEnv a -> SDoc +pprOccEnv ppr_elt (A env) = pprUniqFM ppr_elt env + +type OccSet = UniqSet OccName + +emptyOccSet :: OccSet +unitOccSet :: OccName -> OccSet +mkOccSet :: [OccName] -> OccSet +extendOccSet :: OccSet -> OccName -> OccSet +extendOccSetList :: OccSet -> [OccName] -> OccSet +unionOccSets :: OccSet -> OccSet -> OccSet +unionManyOccSets :: [OccSet] -> OccSet +minusOccSet :: OccSet -> OccSet -> OccSet +elemOccSet :: OccName -> OccSet -> Bool +isEmptyOccSet :: OccSet -> Bool +intersectOccSet :: OccSet -> OccSet -> OccSet +intersectsOccSet :: OccSet -> OccSet -> Bool +filterOccSet :: (OccName -> Bool) -> OccSet -> OccSet + +emptyOccSet = emptyUniqSet +unitOccSet = unitUniqSet +mkOccSet = mkUniqSet +extendOccSet = addOneToUniqSet +extendOccSetList = addListToUniqSet +unionOccSets = unionUniqSets +unionManyOccSets = unionManyUniqSets +minusOccSet = minusUniqSet +elemOccSet = elementOfUniqSet +isEmptyOccSet = isEmptyUniqSet +intersectOccSet = intersectUniqSets +intersectsOccSet s1 s2 = not (isEmptyOccSet (s1 `intersectOccSet` s2)) +filterOccSet = filterUniqSet + +{- +************************************************************************ +* * +\subsection{Predicates and taking them apart} +* * +************************************************************************ +-} + +occNameString :: OccName -> String +occNameString (OccName _ s) = unpackFS s + +setOccNameSpace :: NameSpace -> OccName -> OccName +setOccNameSpace sp (OccName _ occ) = OccName sp occ + +isVarOcc, isTvOcc, isTcOcc, isDataOcc :: OccName -> Bool + +isVarOcc (OccName VarName _) = True +isVarOcc _ = False + +isTvOcc (OccName TvName _) = True +isTvOcc _ = False + +isTcOcc (OccName TcClsName _) = True +isTcOcc _ = False + +-- | /Value/ 'OccNames's are those that are either in +-- the variable or data constructor namespaces +isValOcc :: OccName -> Bool +isValOcc (OccName VarName _) = True +isValOcc (OccName DataName _) = True +isValOcc _ = False + +isDataOcc (OccName DataName _) = True +isDataOcc _ = False + +-- | Test if the 'OccName' is a data constructor that starts with +-- a symbol (e.g. @:@, or @[]@) +isDataSymOcc :: OccName -> Bool +isDataSymOcc (OccName DataName s) = isLexConSym s +isDataSymOcc _ = False +-- Pretty inefficient! + +-- | Test if the 'OccName' is that for any operator (whether +-- it is a data constructor or variable or whatever) +isSymOcc :: OccName -> Bool +isSymOcc (OccName DataName s) = isLexConSym s +isSymOcc (OccName TcClsName s) = isLexSym s +isSymOcc (OccName VarName s) = isLexSym s +isSymOcc (OccName TvName s) = isLexSym s +-- Pretty inefficient! + +parenSymOcc :: OccName -> SDoc -> SDoc +-- ^ Wrap parens around an operator +parenSymOcc occ doc | isSymOcc occ = parens doc + | otherwise = doc + +startsWithUnderscore :: OccName -> Bool +-- ^ Haskell 98 encourages compilers to suppress warnings about unsed +-- names in a pattern if they start with @_@: this implements that test +startsWithUnderscore occ = headFS (occNameFS occ) == '_' + +{- +************************************************************************ +* * +\subsection{Making system names} +* * +************************************************************************ + +Here's our convention for splitting up the interface file name space: + + d... dictionary identifiers + (local variables, so no name-clash worries) + +All of these other OccNames contain a mixture of alphabetic +and symbolic characters, and hence cannot possibly clash with +a user-written type or function name + + $f... Dict-fun identifiers (from inst decls) + $dmop Default method for 'op' + $pnC n'th superclass selector for class C + $wf Worker for function 'f' + $sf.. Specialised version of f + D:C Data constructor for dictionary for class C + NTCo:T Coercion connecting newtype T with its representation type + TFCo:R Coercion connecting a data family to its representation type R + +In encoded form these appear as Zdfxxx etc + + :... keywords (export:, letrec: etc.) +--- I THINK THIS IS WRONG! + +This knowledge is encoded in the following functions. + +@mk_deriv@ generates an @OccName@ from the prefix and a string. +NB: The string must already be encoded! +-} + +-- | Build an 'OccName' derived from another 'OccName'. +-- +-- Note that the pieces of the name are passed in as a @[FastString]@ so that +-- the whole name can be constructed with a single 'concatFS', minimizing +-- unnecessary intermediate allocations. +mk_deriv :: NameSpace + -> FastString -- ^ A prefix which distinguishes one sort of + -- derived name from another + -> [FastString] -- ^ The name we are deriving from in pieces which + -- will be concatenated. + -> OccName +mk_deriv occ_sp sys_prefix str = + mkOccNameFS occ_sp (concatFS $ sys_prefix : str) + +isDerivedOccName :: OccName -> Bool +-- ^ Test for definitions internally generated by GHC. This predicte +-- is used to suppress printing of internal definitions in some debug prints +isDerivedOccName occ = + case occNameString occ of + '$':c:_ | isAlphaNum c -> True -- E.g. $wfoo + c:':':_ | isAlphaNum c -> True -- E.g. N:blah newtype coercions + _other -> False + +isDefaultMethodOcc :: OccName -> Bool +isDefaultMethodOcc occ = + case occNameString occ of + '$':'d':'m':_ -> True + _ -> False + +-- | Is an 'OccName' one of a Typeable @TyCon@ or @Module@ binding? +-- This is needed as these bindings are renamed differently. +-- See Note [Grand plan for Typeable] in TcTypeable. +isTypeableBindOcc :: OccName -> Bool +isTypeableBindOcc occ = + case occNameString occ of + '$':'t':'c':_ -> True -- mkTyConRepOcc + '$':'t':'r':_ -> True -- Module binding + _ -> False + +mkDataConWrapperOcc, mkWorkerOcc, + mkMatcherOcc, mkBuilderOcc, + mkDefaultMethodOcc, + mkClassDataConOcc, mkDictOcc, + mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkRepEqOcc, + mkGenR, mkGen1R, + mkDataConWorkerOcc, mkNewTyCoOcc, + mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc, + mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, + mkTyConRepOcc + :: OccName -> OccName + +-- These derived variables have a prefix that no Haskell value could have +mkDataConWrapperOcc = mk_simple_deriv varName "$W" +mkWorkerOcc = mk_simple_deriv varName "$w" +mkMatcherOcc = mk_simple_deriv varName "$m" +mkBuilderOcc = mk_simple_deriv varName "$b" +mkDefaultMethodOcc = mk_simple_deriv varName "$dm" +mkClassOpAuxOcc = mk_simple_deriv varName "$c" +mkDictOcc = mk_simple_deriv varName "$d" +mkIPOcc = mk_simple_deriv varName "$i" +mkSpecOcc = mk_simple_deriv varName "$s" +mkForeignExportOcc = mk_simple_deriv varName "$f" +mkRepEqOcc = mk_simple_deriv tvName "$r" -- In RULES involving Coercible +mkClassDataConOcc = mk_simple_deriv dataName "C:" -- Data con for a class +mkNewTyCoOcc = mk_simple_deriv tcName "N:" -- Coercion for newtypes +mkInstTyCoOcc = mk_simple_deriv tcName "D:" -- Coercion for type functions +mkEqPredCoOcc = mk_simple_deriv tcName "$co" + +-- Used in derived instances +mkCon2TagOcc = mk_simple_deriv varName "$con2tag_" +mkTag2ConOcc = mk_simple_deriv varName "$tag2con_" +mkMaxTagOcc = mk_simple_deriv varName "$maxtag_" + +-- TyConRepName stuff; see Note [Grand plan for Typeable] in TcTypeable +mkTyConRepOcc occ = mk_simple_deriv varName prefix occ + where + prefix | isDataOcc occ = "$tc'" + | otherwise = "$tc" + +-- Generic deriving mechanism +mkGenR = mk_simple_deriv tcName "Rep_" +mkGen1R = mk_simple_deriv tcName "Rep1_" + +-- Overloaded record field selectors +mkRecFldSelOcc :: String -> OccName +mkRecFldSelOcc s = mk_deriv varName "$sel" [fsLit s] + +mk_simple_deriv :: NameSpace -> FastString -> OccName -> OccName +mk_simple_deriv sp px occ = mk_deriv sp px [occNameFS occ] + +-- Data constructor workers are made by setting the name space +-- of the data constructor OccName (which should be a DataName) +-- to VarName +mkDataConWorkerOcc datacon_occ = setOccNameSpace varName datacon_occ + +mkSuperDictAuxOcc :: Int -> OccName -> OccName +mkSuperDictAuxOcc index cls_tc_occ + = mk_deriv varName "$cp" [fsLit $ show index, occNameFS cls_tc_occ] + +mkSuperDictSelOcc :: Int -- ^ Index of superclass, e.g. 3 + -> OccName -- ^ Class, e.g. @Ord@ + -> OccName -- ^ Derived 'Occname', e.g. @$p3Ord@ +mkSuperDictSelOcc index cls_tc_occ + = mk_deriv varName "$p" [fsLit $ show index, occNameFS cls_tc_occ] + +mkLocalOcc :: Unique -- ^ Unique to combine with the 'OccName' + -> OccName -- ^ Local name, e.g. @sat@ + -> OccName -- ^ Nice unique version, e.g. @$L23sat@ +mkLocalOcc uniq occ + = mk_deriv varName "$L" [fsLit $ show uniq, occNameFS occ] + -- The Unique might print with characters + -- that need encoding (e.g. 'z'!) + +-- | Derive a name for the representation type constructor of a +-- @data@\/@newtype@ instance. +mkInstTyTcOcc :: String -- ^ Family name, e.g. @Map@ + -> OccSet -- ^ avoid these Occs + -> OccName -- ^ @R:Map@ +mkInstTyTcOcc str = chooseUniqueOcc tcName ('R' : ':' : str) + +mkDFunOcc :: String -- ^ Typically the class and type glommed together e.g. @OrdMaybe@. + -- Only used in debug mode, for extra clarity + -> Bool -- ^ Is this a hs-boot instance DFun? + -> OccSet -- ^ avoid these Occs + -> OccName -- ^ E.g. @$f3OrdMaybe@ + +-- In hs-boot files we make dict funs like $fx7ClsTy, which get bound to the real +-- thing when we compile the mother module. Reason: we don't know exactly +-- what the mother module will call it. + +mkDFunOcc info_str is_boot set + = chooseUniqueOcc VarName (prefix ++ info_str) set + where + prefix | is_boot = "$fx" + | otherwise = "$f" + +mkDataTOcc, mkDataCOcc + :: OccName -- ^ TyCon or data con string + -> OccSet -- ^ avoid these Occs + -> OccName -- ^ E.g. @$f3OrdMaybe@ +-- data T = MkT ... deriving( Data ) needs definitions for +-- $tT :: Data.Generics.Basics.DataType +-- $cMkT :: Data.Generics.Basics.Constr +mkDataTOcc occ = chooseUniqueOcc VarName ("$t" ++ occNameString occ) +mkDataCOcc occ = chooseUniqueOcc VarName ("$c" ++ occNameString occ) + +{- +Sometimes we need to pick an OccName that has not already been used, +given a set of in-use OccNames. +-} + +chooseUniqueOcc :: NameSpace -> String -> OccSet -> OccName +chooseUniqueOcc ns str set = loop (mkOccName ns str) (0::Int) + where + loop occ n + | occ `elemOccSet` set = loop (mkOccName ns (str ++ show n)) (n+1) + | otherwise = occ + +{- +We used to add a '$m' to indicate a method, but that gives rise to bad +error messages from the type checker when we print the function name or pattern +of an instance-decl binding. Why? Because the binding is zapped +to use the method name in place of the selector name. +(See TcClassDcl.tcMethodBind) + +The way it is now, -ddump-xx output may look confusing, but +you can always say -dppr-debug to get the uniques. + +However, we *do* have to zap the first character to be lower case, +because overloaded constructors (blarg) generate methods too. +And convert to VarName space + +e.g. a call to constructor MkFoo where + data (Ord a) => Foo a = MkFoo a + +If this is necessary, we do it by prefixing '$m'. These +guys never show up in error messages. What a hack. +-} + +mkMethodOcc :: OccName -> OccName +mkMethodOcc occ@(OccName VarName _) = occ +mkMethodOcc occ = mk_simple_deriv varName "$m" occ + +{- +************************************************************************ +* * +\subsection{Tidying them up} +* * +************************************************************************ + +Before we print chunks of code we like to rename it so that +we don't have to print lots of silly uniques in it. But we mustn't +accidentally introduce name clashes! So the idea is that we leave the +OccName alone unless it accidentally clashes with one that is already +in scope; if so, we tack on '1' at the end and try again, then '2', and +so on till we find a unique one. + +There's a wrinkle for operators. Consider '>>='. We can't use '>>=1' +because that isn't a single lexeme. So we encode it to 'lle' and *then* +tack on the '1', if necessary. + +Note [TidyOccEnv] +~~~~~~~~~~~~~~~~~ +type TidyOccEnv = UniqFM Int + +* Domain = The OccName's FastString. These FastStrings are "taken"; + make sure that we don't re-use + +* Int, n = A plausible starting point for new guesses + There is no guarantee that "FSn" is available; + you must look that up in the TidyOccEnv. But + it's a good place to start looking. + +* When looking for a renaming for "foo2" we strip off the "2" and start + with "foo". Otherwise if we tidy twice we get silly names like foo23. + + However, if it started with digits at the end, we always make a name + with digits at the end, rather than shortening "foo2" to just "foo", + even if "foo" is unused. Reasons: + - Plain "foo" might be used later + - We use trailing digits to subtly indicate a unification variable + in typechecker error message; see TypeRep.tidyTyVarBndr + +We have to take care though! Consider a machine-generated module (#10370) + module Foo where + a1 = e1 + a2 = e2 + ... + a2000 = e2000 +Then "a1", "a2" etc are all marked taken. But now if we come across "a7" again, +we have to do a linear search to find a free one, "a2001". That might just be +acceptable once. But if we now come across "a8" again, we don't want to repeat +that search. + +So we use the TidyOccEnv mapping for "a" (not "a7" or "a8") as our base for +starting the search; and we make sure to update the starting point for "a" +after we allocate a new one. + + +Note [Tidying multiple names at once] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Consider + + > :t (id,id,id) + +Every id contributes a type variable to the type signature, and all of them are +"a". If we tidy them one by one, we get + + (id,id,id) :: (a2 -> a2, a1 -> a1, a -> a) + +which is a bit unfortunate, as it unfairly renames only one of them. What we +would like to see is + + (id,id,id) :: (a3 -> a3, a2 -> a2, a1 -> a1) + +To achieve this, the function avoidClashesOccEnv can be used to prepare the +TidyEnv, by “blocking” every name that occurs twice in the map. This way, none +of the "a"s will get the privilege of keeping this name, and all of them will +get a suitable number by tidyOccName. + +This prepared TidyEnv can then be used with tidyOccName. See tidyTyCoVarBndrs +for an example where this is used. + +This is #12382. + +-} + +type TidyOccEnv = UniqFM Int -- The in-scope OccNames + -- See Note [TidyOccEnv] + +emptyTidyOccEnv :: TidyOccEnv +emptyTidyOccEnv = emptyUFM + +initTidyOccEnv :: [OccName] -> TidyOccEnv -- Initialise with names to avoid! +initTidyOccEnv = foldl' add emptyUFM + where + add env (OccName _ fs) = addToUFM env fs 1 + +-- see Note [Tidying multiple names at once] +avoidClashesOccEnv :: TidyOccEnv -> [OccName] -> TidyOccEnv +avoidClashesOccEnv env occs = go env emptyUFM occs + where + go env _ [] = env + go env seenOnce ((OccName _ fs):occs) + | fs `elemUFM` env = go env seenOnce occs + | fs `elemUFM` seenOnce = go (addToUFM env fs 1) seenOnce occs + | otherwise = go env (addToUFM seenOnce fs ()) occs + +tidyOccName :: TidyOccEnv -> OccName -> (TidyOccEnv, OccName) +tidyOccName env occ@(OccName occ_sp fs) + | not (fs `elemUFM` env) + = -- Desired OccName is free, so use it, + -- and record in 'env' that it's no longer available + (addToUFM env fs 1, occ) + + | otherwise + = case lookupUFM env base1 of + Nothing -> (addToUFM env base1 2, OccName occ_sp base1) + Just n -> find 1 n + where + base :: String -- Drop trailing digits (see Note [TidyOccEnv]) + base = dropWhileEndLE isDigit (unpackFS fs) + base1 = mkFastString (base ++ "1") + + find !k !n + = case lookupUFM env new_fs of + Just {} -> find (k+1 :: Int) (n+k) + -- By using n+k, the n argument to find goes + -- 1, add 1, add 2, add 3, etc which + -- moves at quadratic speed through a dense patch + + Nothing -> (new_env, OccName occ_sp new_fs) + where + new_fs = mkFastString (base ++ show n) + new_env = addToUFM (addToUFM env new_fs 1) base1 (n+1) + -- Update: base1, so that next time we'll start where we left off + -- new_fs, so that we know it is taken + -- If they are the same (n==1), the former wins + -- See Note [TidyOccEnv] + + +{- +************************************************************************ +* * + Binary instance + Here rather than BinIface because OccName is abstract +* * +************************************************************************ +-} + +instance Binary NameSpace where + put_ bh VarName = do + putByte bh 0 + put_ bh DataName = do + putByte bh 1 + put_ bh TvName = do + putByte bh 2 + put_ bh TcClsName = do + putByte bh 3 + get bh = do + h <- getByte bh + case h of + 0 -> do return VarName + 1 -> do return DataName + 2 -> do return TvName + _ -> do return TcClsName + +instance Binary OccName where + put_ bh (OccName aa ab) = do + put_ bh aa + put_ bh ab + get bh = do + aa <- get bh + ab <- get bh + return (OccName aa ab) diff --git a/compiler/basicTypes/OccName.hs-boot b/compiler/basicTypes/OccName.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/basicTypes/OccName.hs-boot @@ -0,0 +1,5 @@ +module OccName where + +import GhcPrelude () + +data OccName diff --git a/compiler/basicTypes/PatSyn.hs b/compiler/basicTypes/PatSyn.hs new file mode 100644 --- /dev/null +++ b/compiler/basicTypes/PatSyn.hs @@ -0,0 +1,469 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1998 + +\section[PatSyn]{@PatSyn@: Pattern synonyms} +-} + +{-# LANGUAGE CPP #-} + +module PatSyn ( + -- * Main data types + PatSyn, mkPatSyn, + + -- ** Type deconstruction + patSynName, patSynArity, patSynIsInfix, + patSynArgs, + patSynMatcher, patSynBuilder, + patSynUnivTyVarBinders, patSynExTyVars, patSynExTyVarBinders, patSynSig, + patSynInstArgTys, patSynInstResTy, patSynFieldLabels, + patSynFieldType, + + tidyPatSynIds, pprPatSynType + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import Type +import Name +import Outputable +import Unique +import Util +import BasicTypes +import Var +import FieldLabel + +import qualified Data.Data as Data +import Data.Function +import Data.List + +{- +************************************************************************ +* * +\subsection{Pattern synonyms} +* * +************************************************************************ +-} + +-- | Pattern Synonym +-- +-- See Note [Pattern synonym representation] +-- See Note [Pattern synonym signature contexts] +data PatSyn + = MkPatSyn { + psName :: Name, + psUnique :: Unique, -- Cached from Name + + psArgs :: [Type], + psArity :: Arity, -- == length psArgs + psInfix :: Bool, -- True <=> declared infix + psFieldLabels :: [FieldLabel], -- List of fields for a + -- record pattern synonym + -- INVARIANT: either empty if no + -- record pat syn or same length as + -- psArgs + + -- Universally-quantified type variables + psUnivTyVars :: [TyVarBinder], + + -- Required dictionaries (may mention psUnivTyVars) + psReqTheta :: ThetaType, + + -- Existentially-quantified type vars + psExTyVars :: [TyVarBinder], + + -- Provided dictionaries (may mention psUnivTyVars or psExTyVars) + psProvTheta :: ThetaType, + + -- Result type + psResultTy :: Type, -- Mentions only psUnivTyVars + -- See Note [Pattern synonym result type] + + -- See Note [Matchers and builders for pattern synonyms] + psMatcher :: (Id, Bool), + -- Matcher function. + -- If Bool is True then prov_theta and arg_tys are empty + -- and type is + -- forall (p :: RuntimeRep) (r :: TYPE p) univ_tvs. + -- req_theta + -- => res_ty + -- -> (forall ex_tvs. Void# -> r) + -- -> (Void# -> r) + -- -> r + -- + -- Otherwise type is + -- forall (p :: RuntimeRep) (r :: TYPE r) univ_tvs. + -- req_theta + -- => res_ty + -- -> (forall ex_tvs. prov_theta => arg_tys -> r) + -- -> (Void# -> r) + -- -> r + + psBuilder :: Maybe (Id, Bool) + -- Nothing => uni-directional pattern synonym + -- Just (builder, is_unlifted) => bi-directional + -- Builder function, of type + -- forall univ_tvs, ex_tvs. (req_theta, prov_theta) + -- => arg_tys -> res_ty + -- See Note [Builder for pattern synonyms with unboxed type] + } + +{- Note [Pattern synonym signature contexts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a pattern synonym signature we write + pattern P :: req => prov => t1 -> ... tn -> res_ty + +Note that the "required" context comes first, then the "provided" +context. Moreover, the "required" context must not mention +existentially-bound type variables; that is, ones not mentioned in +res_ty. See lots of discussion in #10928. + +If there is no "provided" context, you can omit it; but you +can't omit the "required" part (unless you omit both). + +Example 1: + pattern P1 :: (Num a, Eq a) => b -> Maybe (a,b) + pattern P1 x = Just (3,x) + + We require (Num a, Eq a) to match the 3; there is no provided + context. + +Example 2: + data T2 where + MkT2 :: (Num a, Eq a) => a -> a -> T2 + + pattern P2 :: () => (Num a, Eq a) => a -> T2 + pattern P2 x = MkT2 3 x + + When we match against P2 we get a Num dictionary provided. + We can use that to check the match against 3. + +Example 3: + pattern P3 :: Eq a => a -> b -> T3 b + + This signature is illegal because the (Eq a) is a required + constraint, but it mentions the existentially-bound variable 'a'. + You can see it's existential because it doesn't appear in the + result type (T3 b). + +Note [Pattern synonym result type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T a b = MkT b a + + pattern P :: a -> T [a] Bool + pattern P x = MkT True [x] + +P's psResultTy is (T a Bool), and it really only matches values of +type (T [a] Bool). For example, this is ill-typed + + f :: T p q -> String + f (P x) = "urk" + +This is different to the situation with GADTs: + + data S a where + MkS :: Int -> S Bool + +Now MkS (and pattern synonyms coming from MkS) can match a +value of type (S a), not just (S Bool); we get type refinement. + +That in turn means that if you have a pattern + + P x :: T [ty] Bool + +it's not entirely straightforward to work out the instantiation of +P's universal tyvars. You have to /match/ + the type of the pattern, (T [ty] Bool) +against + the psResultTy for the pattern synonym, T [a] Bool +to get the instantiation a := ty. + +This is very unlike DataCons, where univ tyvars match 1-1 the +arguments of the TyCon. + + +Note [Pattern synonym representation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following pattern synonym declaration + + pattern P x = MkT [x] (Just 42) + +where + data T a where + MkT :: (Show a, Ord b) => [b] -> a -> T a + +so pattern P has type + + b -> T (Maybe t) + +with the following typeclass constraints: + + requires: (Eq t, Num t) + provides: (Show (Maybe t), Ord b) + +In this case, the fields of MkPatSyn will be set as follows: + + psArgs = [b] + psArity = 1 + psInfix = False + + psUnivTyVars = [t] + psExTyVars = [b] + psProvTheta = (Show (Maybe t), Ord b) + psReqTheta = (Eq t, Num t) + psResultTy = T (Maybe t) + +Note [Matchers and builders for pattern synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For each pattern synonym P, we generate + + * a "matcher" function, used to desugar uses of P in patterns, + which implements pattern matching + + * A "builder" function (for bidirectional pattern synonyms only), + used to desugar uses of P in expressions, which constructs P-values. + +For the above example, the matcher function has type: + + $mP :: forall (r :: ?) t. (Eq t, Num t) + => T (Maybe t) + -> (forall b. (Show (Maybe t), Ord b) => b -> r) + -> (Void# -> r) + -> r + +with the following implementation: + + $mP @r @t $dEq $dNum scrut cont fail + = case scrut of + MkT @b $dShow $dOrd [x] (Just 42) -> cont @b $dShow $dOrd x + _ -> fail Void# + +Notice that the return type 'r' has an open kind, so that it can +be instantiated by an unboxed type; for example where we see + f (P x) = 3# + +The extra Void# argument for the failure continuation is needed so that +it is lazy even when the result type is unboxed. + +For the same reason, if the pattern has no arguments, an extra Void# +argument is added to the success continuation as well. + +For *bidirectional* pattern synonyms, we also generate a "builder" +function which implements the pattern synonym in an expression +context. For our running example, it will be: + + $bP :: forall t b. (Eq t, Num t, Show (Maybe t), Ord b) + => b -> T (Maybe t) + $bP x = MkT [x] (Just 42) + +NB: the existential/universal and required/provided split does not +apply to the builder since you are only putting stuff in, not getting +stuff out. + +Injectivity of bidirectional pattern synonyms is checked in +tcPatToExpr which walks the pattern and returns its corresponding +expression when available. + +Note [Builder for pattern synonyms with unboxed type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For bidirectional pattern synonyms that have no arguments and have an +unboxed type, we add an extra Void# argument to the builder, else it +would be a top-level declaration with an unboxed type. + + pattern P = 0# + + $bP :: Void# -> Int# + $bP _ = 0# + +This means that when typechecking an occurrence of P in an expression, +we must remember that the builder has this void argument. This is +done by TcPatSyn.patSynBuilderOcc. + +Note [Pattern synonyms and the data type Type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The type of a pattern synonym is of the form (See Note +[Pattern synonym signatures] in TcSigs): + + forall univ_tvs. req => forall ex_tvs. prov => ... + +We cannot in general represent this by a value of type Type: + + - if ex_tvs is empty, then req and prov cannot be distinguished from + each other + - if req is empty, then univ_tvs and ex_tvs cannot be distinguished + from each other, and moreover, prov is seen as the "required" context + (as it is the only context) + + +************************************************************************ +* * +\subsection{Instances} +* * +************************************************************************ +-} + +instance Eq PatSyn where + (==) = (==) `on` getUnique + (/=) = (/=) `on` getUnique + +instance Uniquable PatSyn where + getUnique = psUnique + +instance NamedThing PatSyn where + getName = patSynName + +instance Outputable PatSyn where + ppr = ppr . getName + +instance OutputableBndr PatSyn where + pprInfixOcc = pprInfixName . getName + pprPrefixOcc = pprPrefixName . getName + +instance Data.Data PatSyn where + -- don't traverse? + toConstr _ = abstractConstr "PatSyn" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "PatSyn" + +{- +************************************************************************ +* * +\subsection{Construction} +* * +************************************************************************ +-} + +-- | Build a new pattern synonym +mkPatSyn :: Name + -> Bool -- ^ Is the pattern synonym declared infix? + -> ([TyVarBinder], ThetaType) -- ^ Universially-quantified type + -- variables and required dicts + -> ([TyVarBinder], ThetaType) -- ^ Existentially-quantified type + -- variables and provided dicts + -> [Type] -- ^ Original arguments + -> Type -- ^ Original result type + -> (Id, Bool) -- ^ Name of matcher + -> Maybe (Id, Bool) -- ^ Name of builder + -> [FieldLabel] -- ^ Names of fields for + -- a record pattern synonym + -> PatSyn + -- NB: The univ and ex vars are both in TyBinder form and TyVar form for + -- convenience. All the TyBinders should be Named! +mkPatSyn name declared_infix + (univ_tvs, req_theta) + (ex_tvs, prov_theta) + orig_args + orig_res_ty + matcher builder field_labels + = MkPatSyn {psName = name, psUnique = getUnique name, + psUnivTyVars = univ_tvs, + psExTyVars = ex_tvs, + psProvTheta = prov_theta, psReqTheta = req_theta, + psInfix = declared_infix, + psArgs = orig_args, + psArity = length orig_args, + psResultTy = orig_res_ty, + psMatcher = matcher, + psBuilder = builder, + psFieldLabels = field_labels + } + +-- | The 'Name' of the 'PatSyn', giving it a unique, rooted identification +patSynName :: PatSyn -> Name +patSynName = psName + +-- | Should the 'PatSyn' be presented infix? +patSynIsInfix :: PatSyn -> Bool +patSynIsInfix = psInfix + +-- | Arity of the pattern synonym +patSynArity :: PatSyn -> Arity +patSynArity = psArity + +patSynArgs :: PatSyn -> [Type] +patSynArgs = psArgs + +patSynFieldLabels :: PatSyn -> [FieldLabel] +patSynFieldLabels = psFieldLabels + +-- | Extract the type for any given labelled field of the 'DataCon' +patSynFieldType :: PatSyn -> FieldLabelString -> Type +patSynFieldType ps label + = case find ((== label) . flLabel . fst) (psFieldLabels ps `zip` psArgs ps) of + Just (_, ty) -> ty + Nothing -> pprPanic "dataConFieldType" (ppr ps <+> ppr label) + +patSynUnivTyVarBinders :: PatSyn -> [TyVarBinder] +patSynUnivTyVarBinders = psUnivTyVars + +patSynExTyVars :: PatSyn -> [TyVar] +patSynExTyVars ps = binderVars (psExTyVars ps) + +patSynExTyVarBinders :: PatSyn -> [TyVarBinder] +patSynExTyVarBinders = psExTyVars + +patSynSig :: PatSyn -> ([TyVar], ThetaType, [TyVar], ThetaType, [Type], Type) +patSynSig (MkPatSyn { psUnivTyVars = univ_tvs, psExTyVars = ex_tvs + , psProvTheta = prov, psReqTheta = req + , psArgs = arg_tys, psResultTy = res_ty }) + = (binderVars univ_tvs, req, binderVars ex_tvs, prov, arg_tys, res_ty) + +patSynMatcher :: PatSyn -> (Id,Bool) +patSynMatcher = psMatcher + +patSynBuilder :: PatSyn -> Maybe (Id, Bool) +patSynBuilder = psBuilder + +tidyPatSynIds :: (Id -> Id) -> PatSyn -> PatSyn +tidyPatSynIds tidy_fn ps@(MkPatSyn { psMatcher = matcher, psBuilder = builder }) + = ps { psMatcher = tidy_pr matcher, psBuilder = fmap tidy_pr builder } + where + tidy_pr (id, dummy) = (tidy_fn id, dummy) + +patSynInstArgTys :: PatSyn -> [Type] -> [Type] +-- Return the types of the argument patterns +-- e.g. data D a = forall b. MkD a b (b->a) +-- pattern P f x y = MkD (x,True) y f +-- D :: forall a. forall b. a -> b -> (b->a) -> D a +-- P :: forall c. forall b. (b->(c,Bool)) -> c -> b -> P c +-- patSynInstArgTys P [Int,bb] = [bb->(Int,Bool), Int, bb] +-- NB: the inst_tys should be both universal and existential +patSynInstArgTys (MkPatSyn { psName = name, psUnivTyVars = univ_tvs + , psExTyVars = ex_tvs, psArgs = arg_tys }) + inst_tys + = ASSERT2( tyvars `equalLength` inst_tys + , text "patSynInstArgTys" <+> ppr name $$ ppr tyvars $$ ppr inst_tys ) + map (substTyWith tyvars inst_tys) arg_tys + where + tyvars = binderVars (univ_tvs ++ ex_tvs) + +patSynInstResTy :: PatSyn -> [Type] -> Type +-- Return the type of whole pattern +-- E.g. pattern P x y = Just (x,x,y) +-- P :: a -> b -> Just (a,a,b) +-- (patSynInstResTy P [Int,Bool] = Maybe (Int,Int,Bool) +-- NB: unlike patSynInstArgTys, the inst_tys should be just the *universal* tyvars +patSynInstResTy (MkPatSyn { psName = name, psUnivTyVars = univ_tvs + , psResultTy = res_ty }) + inst_tys + = ASSERT2( univ_tvs `equalLength` inst_tys + , text "patSynInstResTy" <+> ppr name $$ ppr univ_tvs $$ ppr inst_tys ) + substTyWith (binderVars univ_tvs) inst_tys res_ty + +-- | Print the type of a pattern synonym. The foralls are printed explicitly +pprPatSynType :: PatSyn -> SDoc +pprPatSynType (MkPatSyn { psUnivTyVars = univ_tvs, psReqTheta = req_theta + , psExTyVars = ex_tvs, psProvTheta = prov_theta + , psArgs = orig_args, psResultTy = orig_res_ty }) + = sep [ pprForAll univ_tvs + , pprThetaArrowTy req_theta + , ppWhen insert_empty_ctxt $ parens empty <+> darrow + , pprType sigma_ty ] + where + sigma_ty = mkForAllTys ex_tvs $ + mkInvisFunTys prov_theta $ + mkVisFunTys orig_args orig_res_ty + insert_empty_ctxt = null req_theta && not (null prov_theta && null ex_tvs) diff --git a/compiler/basicTypes/PatSyn.hs-boot b/compiler/basicTypes/PatSyn.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/basicTypes/PatSyn.hs-boot @@ -0,0 +1,13 @@ +module PatSyn where + +import BasicTypes (Arity) +import {-# SOURCE #-} TyCoRep (Type) +import Var (TyVar) +import Name (Name) + +data PatSyn + +patSynArity :: PatSyn -> Arity +patSynInstArgTys :: PatSyn -> [Type] -> [Type] +patSynExTyVars :: PatSyn -> [TyVar] +patSynName :: PatSyn -> Name diff --git a/compiler/basicTypes/RdrName.hs b/compiler/basicTypes/RdrName.hs new file mode 100644 --- /dev/null +++ b/compiler/basicTypes/RdrName.hs @@ -0,0 +1,1406 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE CPP, DeriveDataTypeable #-} + +-- | +-- #name_types# +-- GHC uses several kinds of name internally: +-- +-- * 'OccName.OccName': see "OccName#name_types" +-- +-- * 'RdrName.RdrName' is the type of names that come directly from the parser. They +-- have not yet had their scoping and binding resolved by the renamer and can be +-- thought of to a first approximation as an 'OccName.OccName' with an optional module +-- qualifier +-- +-- * 'Name.Name': see "Name#name_types" +-- +-- * 'Id.Id': see "Id#name_types" +-- +-- * 'Var.Var': see "Var#name_types" + +module RdrName ( + -- * The main type + RdrName(..), -- Constructors exported only to BinIface + + -- ** Construction + mkRdrUnqual, mkRdrQual, + mkUnqual, mkVarUnqual, mkQual, mkOrig, + nameRdrName, getRdrName, + + -- ** Destruction + rdrNameOcc, rdrNameSpace, demoteRdrName, + isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isQual_maybe, isUnqual, + isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName, + + -- * Local mapping of 'RdrName' to 'Name.Name' + LocalRdrEnv, emptyLocalRdrEnv, extendLocalRdrEnv, extendLocalRdrEnvList, + lookupLocalRdrEnv, lookupLocalRdrOcc, + elemLocalRdrEnv, inLocalRdrEnvScope, + localRdrEnvElts, delLocalRdrEnvList, + + -- * Global mapping of 'RdrName' to 'GlobalRdrElt's + GlobalRdrEnv, emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv, + lookupGlobalRdrEnv, extendGlobalRdrEnv, greOccName, shadowNames, + pprGlobalRdrEnv, globalRdrEnvElts, + lookupGRE_RdrName, lookupGRE_Name, lookupGRE_FieldLabel, + lookupGRE_Name_OccName, + getGRE_NameQualifier_maybes, + transformGREs, pickGREs, pickGREsModExp, + + -- * GlobalRdrElts + gresFromAvails, gresFromAvail, localGREsFromAvail, availFromGRE, + greRdrNames, greSrcSpan, greQualModName, + gresToAvailInfo, + + -- ** Global 'RdrName' mapping elements: 'GlobalRdrElt', 'Provenance', 'ImportSpec' + GlobalRdrElt(..), isLocalGRE, isRecFldGRE, greLabel, + unQualOK, qualSpecOK, unQualSpecOK, + pprNameProvenance, + Parent(..), greParent_maybe, + ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..), + importSpecLoc, importSpecModule, isExplicitItem, bestImport, + + -- * Utils for StarIsType + starInfo + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import Module +import Name +import Avail +import NameSet +import Maybes +import SrcLoc +import FastString +import FieldLabel +import Outputable +import Unique +import UniqFM +import UniqSet +import Util +import NameEnv + +import Data.Data +import Data.List( sortBy ) + +{- +************************************************************************ +* * +\subsection{The main data type} +* * +************************************************************************ +-} + +-- | Reader Name +-- +-- Do not use the data constructors of RdrName directly: prefer the family +-- of functions that creates them, such as 'mkRdrUnqual' +-- +-- - Note: A Located RdrName will only have API Annotations if it is a +-- compound one, +-- e.g. +-- +-- > `bar` +-- > ( ~ ) +-- +-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', +-- 'ApiAnnotation.AnnOpen' @'('@ or @'['@ or @'[:'@, +-- 'ApiAnnotation.AnnClose' @')'@ or @']'@ or @':]'@,, +-- 'ApiAnnotation.AnnBackquote' @'`'@, +-- 'ApiAnnotation.AnnVal' +-- 'ApiAnnotation.AnnTilde', + +-- For details on above see note [Api annotations] in ApiAnnotation +data RdrName + = Unqual OccName + -- ^ Unqualified name + -- + -- Used for ordinary, unqualified occurrences, e.g. @x@, @y@ or @Foo@. + -- Create such a 'RdrName' with 'mkRdrUnqual' + + | Qual ModuleName OccName + -- ^ Qualified name + -- + -- A qualified name written by the user in + -- /source/ code. The module isn't necessarily + -- the module where the thing is defined; + -- just the one from which it is imported. + -- Examples are @Bar.x@, @Bar.y@ or @Bar.Foo@. + -- Create such a 'RdrName' with 'mkRdrQual' + + | Orig Module OccName + -- ^ Original name + -- + -- An original name; the module is the /defining/ module. + -- This is used when GHC generates code that will be fed + -- into the renamer (e.g. from deriving clauses), but where + -- we want to say \"Use Prelude.map dammit\". One of these + -- can be created with 'mkOrig' + + | Exact Name + -- ^ Exact name + -- + -- We know exactly the 'Name'. This is used: + -- + -- (1) When the parser parses built-in syntax like @[]@ + -- and @(,)@, but wants a 'RdrName' from it + -- + -- (2) By Template Haskell, when TH has generated a unique name + -- + -- Such a 'RdrName' can be created by using 'getRdrName' on a 'Name' + deriving Data + +{- +************************************************************************ +* * +\subsection{Simple functions} +* * +************************************************************************ +-} + +instance HasOccName RdrName where + occName = rdrNameOcc + +rdrNameOcc :: RdrName -> OccName +rdrNameOcc (Qual _ occ) = occ +rdrNameOcc (Unqual occ) = occ +rdrNameOcc (Orig _ occ) = occ +rdrNameOcc (Exact name) = nameOccName name + +rdrNameSpace :: RdrName -> NameSpace +rdrNameSpace = occNameSpace . rdrNameOcc + +-- demoteRdrName lowers the NameSpace of RdrName. +-- see Note [Demotion] in OccName +demoteRdrName :: RdrName -> Maybe RdrName +demoteRdrName (Unqual occ) = fmap Unqual (demoteOccName occ) +demoteRdrName (Qual m occ) = fmap (Qual m) (demoteOccName occ) +demoteRdrName (Orig _ _) = panic "demoteRdrName" +demoteRdrName (Exact _) = panic "demoteRdrName" + + -- These two are the basic constructors +mkRdrUnqual :: OccName -> RdrName +mkRdrUnqual occ = Unqual occ + +mkRdrQual :: ModuleName -> OccName -> RdrName +mkRdrQual mod occ = Qual mod occ + +mkOrig :: Module -> OccName -> RdrName +mkOrig mod occ = Orig mod occ + +--------------- + -- These two are used when parsing source files + -- They do encode the module and occurrence names +mkUnqual :: NameSpace -> FastString -> RdrName +mkUnqual sp n = Unqual (mkOccNameFS sp n) + +mkVarUnqual :: FastString -> RdrName +mkVarUnqual n = Unqual (mkVarOccFS n) + +-- | Make a qualified 'RdrName' in the given namespace and where the 'ModuleName' and +-- the 'OccName' are taken from the first and second elements of the tuple respectively +mkQual :: NameSpace -> (FastString, FastString) -> RdrName +mkQual sp (m, n) = Qual (mkModuleNameFS m) (mkOccNameFS sp n) + +getRdrName :: NamedThing thing => thing -> RdrName +getRdrName name = nameRdrName (getName name) + +nameRdrName :: Name -> RdrName +nameRdrName name = Exact name +-- Keep the Name even for Internal names, so that the +-- unique is still there for debug printing, particularly +-- of Types (which are converted to IfaceTypes before printing) + +nukeExact :: Name -> RdrName +nukeExact n + | isExternalName n = Orig (nameModule n) (nameOccName n) + | otherwise = Unqual (nameOccName n) + +isRdrDataCon :: RdrName -> Bool +isRdrTyVar :: RdrName -> Bool +isRdrTc :: RdrName -> Bool + +isRdrDataCon rn = isDataOcc (rdrNameOcc rn) +isRdrTyVar rn = isTvOcc (rdrNameOcc rn) +isRdrTc rn = isTcOcc (rdrNameOcc rn) + +isSrcRdrName :: RdrName -> Bool +isSrcRdrName (Unqual _) = True +isSrcRdrName (Qual _ _) = True +isSrcRdrName _ = False + +isUnqual :: RdrName -> Bool +isUnqual (Unqual _) = True +isUnqual _ = False + +isQual :: RdrName -> Bool +isQual (Qual _ _) = True +isQual _ = False + +isQual_maybe :: RdrName -> Maybe (ModuleName, OccName) +isQual_maybe (Qual m n) = Just (m,n) +isQual_maybe _ = Nothing + +isOrig :: RdrName -> Bool +isOrig (Orig _ _) = True +isOrig _ = False + +isOrig_maybe :: RdrName -> Maybe (Module, OccName) +isOrig_maybe (Orig m n) = Just (m,n) +isOrig_maybe _ = Nothing + +isExact :: RdrName -> Bool +isExact (Exact _) = True +isExact _ = False + +isExact_maybe :: RdrName -> Maybe Name +isExact_maybe (Exact n) = Just n +isExact_maybe _ = Nothing + +{- +************************************************************************ +* * +\subsection{Instances} +* * +************************************************************************ +-} + +instance Outputable RdrName where + ppr (Exact name) = ppr name + ppr (Unqual occ) = ppr occ + ppr (Qual mod occ) = ppr mod <> dot <> ppr occ + ppr (Orig mod occ) = getPprStyle (\sty -> pprModulePrefix sty mod occ <> ppr occ) + +instance OutputableBndr RdrName where + pprBndr _ n + | isTvOcc (rdrNameOcc n) = char '@' <+> ppr n + | otherwise = ppr n + + pprInfixOcc rdr = pprInfixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) + pprPrefixOcc rdr + | Just name <- isExact_maybe rdr = pprPrefixName name + -- pprPrefixName has some special cases, so + -- we delegate to them rather than reproduce them + | otherwise = pprPrefixVar (isSymOcc (rdrNameOcc rdr)) (ppr rdr) + +instance Eq RdrName where + (Exact n1) == (Exact n2) = n1==n2 + -- Convert exact to orig + (Exact n1) == r2@(Orig _ _) = nukeExact n1 == r2 + r1@(Orig _ _) == (Exact n2) = r1 == nukeExact n2 + + (Orig m1 o1) == (Orig m2 o2) = m1==m2 && o1==o2 + (Qual m1 o1) == (Qual m2 o2) = m1==m2 && o1==o2 + (Unqual o1) == (Unqual o2) = o1==o2 + _ == _ = False + +instance Ord RdrName where + a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } + a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } + a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } + a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } + + -- Exact < Unqual < Qual < Orig + -- [Note: Apr 2004] We used to use nukeExact to convert Exact to Orig + -- before comparing so that Prelude.map == the exact Prelude.map, but + -- that meant that we reported duplicates when renaming bindings + -- generated by Template Haskell; e.g + -- do { n1 <- newName "foo"; n2 <- newName "foo"; + -- } + -- I think we can do without this conversion + compare (Exact n1) (Exact n2) = n1 `compare` n2 + compare (Exact _) _ = LT + + compare (Unqual _) (Exact _) = GT + compare (Unqual o1) (Unqual o2) = o1 `compare` o2 + compare (Unqual _) _ = LT + + compare (Qual _ _) (Exact _) = GT + compare (Qual _ _) (Unqual _) = GT + compare (Qual m1 o1) (Qual m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2) + compare (Qual _ _) (Orig _ _) = LT + + compare (Orig m1 o1) (Orig m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2) + compare (Orig _ _) _ = GT + +{- +************************************************************************ +* * + LocalRdrEnv +* * +************************************************************************ +-} + +-- | Local Reader Environment +-- +-- This environment is used to store local bindings +-- (@let@, @where@, lambda, @case@). +-- It is keyed by OccName, because we never use it for qualified names +-- We keep the current mapping, *and* the set of all Names in scope +-- Reason: see Note [Splicing Exact names] in RnEnv +data LocalRdrEnv = LRE { lre_env :: OccEnv Name + , lre_in_scope :: NameSet } + +instance Outputable LocalRdrEnv where + ppr (LRE {lre_env = env, lre_in_scope = ns}) + = hang (text "LocalRdrEnv {") + 2 (vcat [ text "env =" <+> pprOccEnv ppr_elt env + , text "in_scope =" + <+> pprUFM (getUniqSet ns) (braces . pprWithCommas ppr) + ] <+> char '}') + where + ppr_elt name = parens (ppr (getUnique (nameOccName name))) <+> ppr name + -- So we can see if the keys line up correctly + +emptyLocalRdrEnv :: LocalRdrEnv +emptyLocalRdrEnv = LRE { lre_env = emptyOccEnv + , lre_in_scope = emptyNameSet } + +extendLocalRdrEnv :: LocalRdrEnv -> Name -> LocalRdrEnv +-- The Name should be a non-top-level thing +extendLocalRdrEnv lre@(LRE { lre_env = env, lre_in_scope = ns }) name + = WARN( isExternalName name, ppr name ) + lre { lre_env = extendOccEnv env (nameOccName name) name + , lre_in_scope = extendNameSet ns name } + +extendLocalRdrEnvList :: LocalRdrEnv -> [Name] -> LocalRdrEnv +extendLocalRdrEnvList lre@(LRE { lre_env = env, lre_in_scope = ns }) names + = WARN( any isExternalName names, ppr names ) + lre { lre_env = extendOccEnvList env [(nameOccName n, n) | n <- names] + , lre_in_scope = extendNameSetList ns names } + +lookupLocalRdrEnv :: LocalRdrEnv -> RdrName -> Maybe Name +lookupLocalRdrEnv (LRE { lre_env = env, lre_in_scope = ns }) rdr + | Unqual occ <- rdr + = lookupOccEnv env occ + + -- See Note [Local bindings with Exact Names] + | Exact name <- rdr + , name `elemNameSet` ns + = Just name + + | otherwise + = Nothing + +lookupLocalRdrOcc :: LocalRdrEnv -> OccName -> Maybe Name +lookupLocalRdrOcc (LRE { lre_env = env }) occ = lookupOccEnv env occ + +elemLocalRdrEnv :: RdrName -> LocalRdrEnv -> Bool +elemLocalRdrEnv rdr_name (LRE { lre_env = env, lre_in_scope = ns }) + = case rdr_name of + Unqual occ -> occ `elemOccEnv` env + Exact name -> name `elemNameSet` ns -- See Note [Local bindings with Exact Names] + Qual {} -> False + Orig {} -> False + +localRdrEnvElts :: LocalRdrEnv -> [Name] +localRdrEnvElts (LRE { lre_env = env }) = occEnvElts env + +inLocalRdrEnvScope :: Name -> LocalRdrEnv -> Bool +-- This is the point of the NameSet +inLocalRdrEnvScope name (LRE { lre_in_scope = ns }) = name `elemNameSet` ns + +delLocalRdrEnvList :: LocalRdrEnv -> [OccName] -> LocalRdrEnv +delLocalRdrEnvList lre@(LRE { lre_env = env }) occs + = lre { lre_env = delListFromOccEnv env occs } + +{- +Note [Local bindings with Exact Names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With Template Haskell we can make local bindings that have Exact Names. +Computing shadowing etc may use elemLocalRdrEnv (at least it certainly +does so in RnTpes.bindHsQTyVars), so for an Exact Name we must consult +the in-scope-name-set. + + +************************************************************************ +* * + GlobalRdrEnv +* * +************************************************************************ +-} + +-- | Global Reader Environment +type GlobalRdrEnv = OccEnv [GlobalRdrElt] +-- ^ Keyed by 'OccName'; when looking up a qualified name +-- we look up the 'OccName' part, and then check the 'Provenance' +-- to see if the appropriate qualification is valid. This +-- saves routinely doubling the size of the env by adding both +-- qualified and unqualified names to the domain. +-- +-- The list in the codomain is required because there may be name clashes +-- These only get reported on lookup, not on construction +-- +-- INVARIANT 1: All the members of the list have distinct +-- 'gre_name' fields; that is, no duplicate Names +-- +-- INVARIANT 2: Imported provenance => Name is an ExternalName +-- However LocalDefs can have an InternalName. This +-- happens only when type-checking a [d| ... |] Template +-- Haskell quotation; see this note in RnNames +-- Note [Top-level Names in Template Haskell decl quotes] +-- +-- INVARIANT 3: If the GlobalRdrEnv maps [occ -> gre], then +-- greOccName gre = occ +-- +-- NB: greOccName gre is usually the same as +-- nameOccName (gre_name gre), but not always in the +-- case of record seectors; see greOccName + +-- | Global Reader Element +-- +-- An element of the 'GlobalRdrEnv' +data GlobalRdrElt + = GRE { gre_name :: Name + , gre_par :: Parent + , gre_lcl :: Bool -- ^ True <=> the thing was defined locally + , gre_imp :: [ImportSpec] -- ^ In scope through these imports + } deriving (Data, Eq) + -- INVARIANT: either gre_lcl = True or gre_imp is non-empty + -- See Note [GlobalRdrElt provenance] + +-- | The children of a Name are the things that are abbreviated by the ".." +-- notation in export lists. See Note [Parents] +data Parent = NoParent + | ParentIs { par_is :: Name } + | FldParent { par_is :: Name, par_lbl :: Maybe FieldLabelString } + -- ^ See Note [Parents for record fields] + deriving (Eq, Data) + +instance Outputable Parent where + ppr NoParent = empty + ppr (ParentIs n) = text "parent:" <> ppr n + ppr (FldParent n f) = text "fldparent:" + <> ppr n <> colon <> ppr f + +plusParent :: Parent -> Parent -> Parent +-- See Note [Combining parents] +plusParent p1@(ParentIs _) p2 = hasParent p1 p2 +plusParent p1@(FldParent _ _) p2 = hasParent p1 p2 +plusParent p1 p2@(ParentIs _) = hasParent p2 p1 +plusParent p1 p2@(FldParent _ _) = hasParent p2 p1 +plusParent _ _ = NoParent + +hasParent :: Parent -> Parent -> Parent +#if defined(DEBUG) +hasParent p NoParent = p +hasParent p p' + | p /= p' = pprPanic "hasParent" (ppr p <+> ppr p') -- Parents should agree +#endif +hasParent p _ = p + + +{- Note [GlobalRdrElt provenance] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The gre_lcl and gre_imp fields of a GlobalRdrElt describe its "provenance", +i.e. how the Name came to be in scope. It can be in scope two ways: + - gre_lcl = True: it is bound in this module + - gre_imp: a list of all the imports that brought it into scope + +It's an INVARIANT that you have one or the other; that is, either +gre_lcl is True, or gre_imp is non-empty. + +It is just possible to have *both* if there is a module loop: a Name +is defined locally in A, and also brought into scope by importing a +module that SOURCE-imported A. Exapmle (#7672): + + A.hs-boot module A where + data T + + B.hs module B(Decl.T) where + import {-# SOURCE #-} qualified A as Decl + + A.hs module A where + import qualified B + data T = Z | S B.T + +In A.hs, 'T' is locally bound, *and* imported as B.T. + +Note [Parents] +~~~~~~~~~~~~~~~~~ + Parent Children +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + data T Data constructors + Record-field ids + + data family T Data constructors and record-field ids + of all visible data instances of T + + class C Class operations + Associated type constructors + +~~~~~~~~~~~~~~~~~~~~~~~~~ + Constructor Meaning + ~~~~~~~~~~~~~~~~~~~~~~~~ + NoParent Can not be bundled with a type constructor. + ParentIs n Can be bundled with the type constructor corresponding to + n. + FldParent See Note [Parents for record fields] + + + + +Note [Parents for record fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For record fields, in addition to the Name of the type constructor +(stored in par_is), we use FldParent to store the field label. This +extra information is used for identifying overloaded record fields +during renaming. + +In a definition arising from a normal module (without +-XDuplicateRecordFields), par_lbl will be Nothing, meaning that the +field's label is the same as the OccName of the selector's Name. The +GlobalRdrEnv will contain an entry like this: + + "x" |-> GRE x (FldParent T Nothing) LocalDef + +When -XDuplicateRecordFields is enabled for the module that contains +T, the selector's Name will be mangled (see comments in FieldLabel). +Thus we store the actual field label in par_lbl, and the GlobalRdrEnv +entry looks like this: + + "x" |-> GRE $sel:x:MkT (FldParent T (Just "x")) LocalDef + +Note that the OccName used when adding a GRE to the environment +(greOccName) now depends on the parent field: for FldParent it is the +field label, if present, rather than the selector name. + +~~ + +Record pattern synonym selectors are treated differently. Their parent +information is `NoParent` in the module in which they are defined. This is because +a pattern synonym `P` has no parent constructor either. + +However, if `f` is bundled with a type constructor `T` then whenever `f` is +imported the parent will use the `Parent` constructor so the parent of `f` is +now `T`. + + +Note [Combining parents] +~~~~~~~~~~~~~~~~~~~~~~~~ +With an associated type we might have + module M where + class C a where + data T a + op :: T a -> a + instance C Int where + data T Int = TInt + instance C Bool where + data T Bool = TBool + +Then: C is the parent of T + T is the parent of TInt and TBool +So: in an export list + C(..) is short for C( op, T ) + T(..) is short for T( TInt, TBool ) + +Module M exports everything, so its exports will be + AvailTC C [C,T,op] + AvailTC T [T,TInt,TBool] +On import we convert to GlobalRdrElt and then combine +those. For T that will mean we have + one GRE with Parent C + one GRE with NoParent +That's why plusParent picks the "best" case. +-} + +-- | make a 'GlobalRdrEnv' where all the elements point to the same +-- Provenance (useful for "hiding" imports, or imports with no details). +gresFromAvails :: Maybe ImportSpec -> [AvailInfo] -> [GlobalRdrElt] +-- prov = Nothing => locally bound +-- Just spec => imported as described by spec +gresFromAvails prov avails + = concatMap (gresFromAvail (const prov)) avails + +localGREsFromAvail :: AvailInfo -> [GlobalRdrElt] +-- Turn an Avail into a list of LocalDef GlobalRdrElts +localGREsFromAvail = gresFromAvail (const Nothing) + +gresFromAvail :: (Name -> Maybe ImportSpec) -> AvailInfo -> [GlobalRdrElt] +gresFromAvail prov_fn avail + = map mk_gre (availNonFldNames avail) ++ map mk_fld_gre (availFlds avail) + where + mk_gre n + = case prov_fn n of -- Nothing => bound locally + -- Just is => imported from 'is' + Nothing -> GRE { gre_name = n, gre_par = mkParent n avail + , gre_lcl = True, gre_imp = [] } + Just is -> GRE { gre_name = n, gre_par = mkParent n avail + , gre_lcl = False, gre_imp = [is] } + + mk_fld_gre (FieldLabel { flLabel = lbl, flIsOverloaded = is_overloaded + , flSelector = n }) + = case prov_fn n of -- Nothing => bound locally + -- Just is => imported from 'is' + Nothing -> GRE { gre_name = n, gre_par = FldParent (availName avail) mb_lbl + , gre_lcl = True, gre_imp = [] } + Just is -> GRE { gre_name = n, gre_par = FldParent (availName avail) mb_lbl + , gre_lcl = False, gre_imp = [is] } + where + mb_lbl | is_overloaded = Just lbl + | otherwise = Nothing + + +greQualModName :: GlobalRdrElt -> ModuleName +-- Get a suitable module qualifier for the GRE +-- (used in mkPrintUnqualified) +-- Prerecondition: the gre_name is always External +greQualModName gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss }) + | lcl, Just mod <- nameModule_maybe name = moduleName mod + | (is:_) <- iss = is_as (is_decl is) + | otherwise = pprPanic "greQualModName" (ppr gre) + +greRdrNames :: GlobalRdrElt -> [RdrName] +greRdrNames gre@GRE{ gre_lcl = lcl, gre_imp = iss } + = (if lcl then [unqual] else []) ++ concatMap do_spec (map is_decl iss) + where + occ = greOccName gre + unqual = Unqual occ + do_spec decl_spec + | is_qual decl_spec = [qual] + | otherwise = [unqual,qual] + where qual = Qual (is_as decl_spec) occ + +-- the SrcSpan that pprNameProvenance prints out depends on whether +-- the Name is defined locally or not: for a local definition the +-- definition site is used, otherwise the location of the import +-- declaration. We want to sort the export locations in +-- exportClashErr by this SrcSpan, we need to extract it: +greSrcSpan :: GlobalRdrElt -> SrcSpan +greSrcSpan gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss } ) + | lcl = nameSrcSpan name + | (is:_) <- iss = is_dloc (is_decl is) + | otherwise = pprPanic "greSrcSpan" (ppr gre) + +mkParent :: Name -> AvailInfo -> Parent +mkParent _ (Avail _) = NoParent +mkParent n (AvailTC m _ _) | n == m = NoParent + | otherwise = ParentIs m + +greParent_maybe :: GlobalRdrElt -> Maybe Name +greParent_maybe gre = case gre_par gre of + NoParent -> Nothing + ParentIs n -> Just n + FldParent n _ -> Just n + +-- | Takes a list of distinct GREs and folds them +-- into AvailInfos. This is more efficient than mapping each individual +-- GRE to an AvailInfo and the folding using `plusAvail` but needs the +-- uniqueness assumption. +gresToAvailInfo :: [GlobalRdrElt] -> [AvailInfo] +gresToAvailInfo gres + = nameEnvElts avail_env + where + avail_env :: NameEnv AvailInfo -- Keyed by the parent + (avail_env, _) = foldl' add (emptyNameEnv, emptyNameSet) gres + + add :: (NameEnv AvailInfo, NameSet) + -> GlobalRdrElt + -> (NameEnv AvailInfo, NameSet) + add (env, done) gre + | name `elemNameSet` done + = (env, done) -- Don't insert twice into the AvailInfo + | otherwise + = ( extendNameEnv_Acc comb availFromGRE env key gre + , done `extendNameSet` name ) + where + name = gre_name gre + key = case greParent_maybe gre of + Just parent -> parent + Nothing -> gre_name gre + + -- We want to insert the child `k` into a list of children but + -- need to maintain the invariant that the parent is first. + -- + -- We also use the invariant that `k` is not already in `ns`. + insertChildIntoChildren :: Name -> [Name] -> Name -> [Name] + insertChildIntoChildren _ [] k = [k] + insertChildIntoChildren p (n:ns) k + | p == k = k:n:ns + | otherwise = n:k:ns + + comb :: GlobalRdrElt -> AvailInfo -> AvailInfo + comb _ (Avail n) = Avail n -- Duplicated name, should not happen + comb gre (AvailTC m ns fls) + = case gre_par gre of + NoParent -> AvailTC m (name:ns) fls -- Not sure this ever happens + ParentIs {} -> AvailTC m (insertChildIntoChildren m ns name) fls + FldParent _ mb_lbl -> AvailTC m ns (mkFieldLabel name mb_lbl : fls) + +availFromGRE :: GlobalRdrElt -> AvailInfo +availFromGRE (GRE { gre_name = me, gre_par = parent }) + = case parent of + ParentIs p -> AvailTC p [me] [] + NoParent | isTyConName me -> AvailTC me [me] [] + | otherwise -> avail me + FldParent p mb_lbl -> AvailTC p [] [mkFieldLabel me mb_lbl] + +mkFieldLabel :: Name -> Maybe FastString -> FieldLabel +mkFieldLabel me mb_lbl = + case mb_lbl of + Nothing -> FieldLabel { flLabel = occNameFS (nameOccName me) + , flIsOverloaded = False + , flSelector = me } + Just lbl -> FieldLabel { flLabel = lbl + , flIsOverloaded = True + , flSelector = me } + +emptyGlobalRdrEnv :: GlobalRdrEnv +emptyGlobalRdrEnv = emptyOccEnv + +globalRdrEnvElts :: GlobalRdrEnv -> [GlobalRdrElt] +globalRdrEnvElts env = foldOccEnv (++) [] env + +instance Outputable GlobalRdrElt where + ppr gre = hang (ppr (gre_name gre) <+> ppr (gre_par gre)) + 2 (pprNameProvenance gre) + +pprGlobalRdrEnv :: Bool -> GlobalRdrEnv -> SDoc +pprGlobalRdrEnv locals_only env + = vcat [ text "GlobalRdrEnv" <+> ppWhen locals_only (ptext (sLit "(locals only)")) + <+> lbrace + , nest 2 (vcat [ pp (remove_locals gre_list) | gre_list <- occEnvElts env ] + <+> rbrace) ] + where + remove_locals gres | locals_only = filter isLocalGRE gres + | otherwise = gres + pp [] = empty + pp gres = hang (ppr occ + <+> parens (text "unique" <+> ppr (getUnique occ)) + <> colon) + 2 (vcat (map ppr gres)) + where + occ = nameOccName (gre_name (head gres)) + +lookupGlobalRdrEnv :: GlobalRdrEnv -> OccName -> [GlobalRdrElt] +lookupGlobalRdrEnv env occ_name = case lookupOccEnv env occ_name of + Nothing -> [] + Just gres -> gres + +greOccName :: GlobalRdrElt -> OccName +greOccName (GRE{gre_par = FldParent{par_lbl = Just lbl}}) = mkVarOccFS lbl +greOccName gre = nameOccName (gre_name gre) + +lookupGRE_RdrName :: RdrName -> GlobalRdrEnv -> [GlobalRdrElt] +lookupGRE_RdrName rdr_name env + = case lookupOccEnv env (rdrNameOcc rdr_name) of + Nothing -> [] + Just gres -> pickGREs rdr_name gres + +lookupGRE_Name :: GlobalRdrEnv -> Name -> Maybe GlobalRdrElt +-- ^ Look for precisely this 'Name' in the environment. This tests +-- whether it is in scope, ignoring anything else that might be in +-- scope with the same 'OccName'. +lookupGRE_Name env name + = lookupGRE_Name_OccName env name (nameOccName name) + +lookupGRE_FieldLabel :: GlobalRdrEnv -> FieldLabel -> Maybe GlobalRdrElt +-- ^ Look for a particular record field selector in the environment, where the +-- selector name and field label may be different: the GlobalRdrEnv is keyed on +-- the label. See Note [Parents for record fields] for why this happens. +lookupGRE_FieldLabel env fl + = lookupGRE_Name_OccName env (flSelector fl) (mkVarOccFS (flLabel fl)) + +lookupGRE_Name_OccName :: GlobalRdrEnv -> Name -> OccName -> Maybe GlobalRdrElt +-- ^ Look for precisely this 'Name' in the environment, but with an 'OccName' +-- that might differ from that of the 'Name'. See 'lookupGRE_FieldLabel' and +-- Note [Parents for record fields]. +lookupGRE_Name_OccName env name occ + = case [ gre | gre <- lookupGlobalRdrEnv env occ + , gre_name gre == name ] of + [] -> Nothing + [gre] -> Just gre + gres -> pprPanic "lookupGRE_Name_OccName" + (ppr name $$ ppr occ $$ ppr gres) + -- See INVARIANT 1 on GlobalRdrEnv + + +getGRE_NameQualifier_maybes :: GlobalRdrEnv -> Name -> [Maybe [ModuleName]] +-- Returns all the qualifiers by which 'x' is in scope +-- Nothing means "the unqualified version is in scope" +-- [] means the thing is not in scope at all +getGRE_NameQualifier_maybes env name + = case lookupGRE_Name env name of + Just gre -> [qualifier_maybe gre] + Nothing -> [] + where + qualifier_maybe (GRE { gre_lcl = lcl, gre_imp = iss }) + | lcl = Nothing + | otherwise = Just $ map (is_as . is_decl) iss + +isLocalGRE :: GlobalRdrElt -> Bool +isLocalGRE (GRE {gre_lcl = lcl }) = lcl + +isRecFldGRE :: GlobalRdrElt -> Bool +isRecFldGRE (GRE {gre_par = FldParent{}}) = True +isRecFldGRE _ = False + +-- Returns the field label of this GRE, if it has one +greLabel :: GlobalRdrElt -> Maybe FieldLabelString +greLabel (GRE{gre_par = FldParent{par_lbl = Just lbl}}) = Just lbl +greLabel (GRE{gre_name = n, gre_par = FldParent{}}) = Just (occNameFS (nameOccName n)) +greLabel _ = Nothing + +unQualOK :: GlobalRdrElt -> Bool +-- ^ Test if an unqualified version of this thing would be in scope +unQualOK (GRE {gre_lcl = lcl, gre_imp = iss }) + | lcl = True + | otherwise = any unQualSpecOK iss + +{- Note [GRE filtering] +~~~~~~~~~~~~~~~~~~~~~~~ +(pickGREs rdr gres) takes a list of GREs which have the same OccName +as 'rdr', say "x". It does two things: + +(a) filters the GREs to a subset that are in scope + * Qualified, as 'M.x' if want_qual is Qual M _ + * Unqualified, as 'x' if want_unqual is Unqual _ + +(b) for that subset, filter the provenance field (gre_lcl and gre_imp) + to ones that brought it into scope qualified or unqualified resp. + +Example: + module A ( f ) where + import qualified Foo( f ) + import Baz( f ) + f = undefined + +Let's suppose that Foo.f and Baz.f are the same entity really, but the local +'f' is different, so there will be two GREs matching "f": + gre1: gre_lcl = True, gre_imp = [] + gre2: gre_lcl = False, gre_imp = [ imported from Foo, imported from Bar ] + +The use of "f" in the export list is ambiguous because it's in scope +from the local def and the import Baz(f); but *not* the import qualified Foo. +pickGREs returns two GRE + gre1: gre_lcl = True, gre_imp = [] + gre2: gre_lcl = False, gre_imp = [ imported from Bar ] + +Now the "ambiguous occurrence" message can correctly report how the +ambiguity arises. +-} + +pickGREs :: RdrName -> [GlobalRdrElt] -> [GlobalRdrElt] +-- ^ Takes a list of GREs which have the right OccName 'x' +-- Pick those GREs that are in scope +-- * Qualified, as 'M.x' if want_qual is Qual M _ +-- * Unqualified, as 'x' if want_unqual is Unqual _ +-- +-- Return each such GRE, with its ImportSpecs filtered, to reflect +-- how it is in scope qualified or unqualified respectively. +-- See Note [GRE filtering] +pickGREs (Unqual {}) gres = mapMaybe pickUnqualGRE gres +pickGREs (Qual mod _) gres = mapMaybe (pickQualGRE mod) gres +pickGREs _ _ = [] -- I don't think this actually happens + +pickUnqualGRE :: GlobalRdrElt -> Maybe GlobalRdrElt +pickUnqualGRE gre@(GRE { gre_lcl = lcl, gre_imp = iss }) + | not lcl, null iss' = Nothing + | otherwise = Just (gre { gre_imp = iss' }) + where + iss' = filter unQualSpecOK iss + +pickQualGRE :: ModuleName -> GlobalRdrElt -> Maybe GlobalRdrElt +pickQualGRE mod gre@(GRE { gre_name = n, gre_lcl = lcl, gre_imp = iss }) + | not lcl', null iss' = Nothing + | otherwise = Just (gre { gre_lcl = lcl', gre_imp = iss' }) + where + iss' = filter (qualSpecOK mod) iss + lcl' = lcl && name_is_from mod n + + name_is_from :: ModuleName -> Name -> Bool + name_is_from mod name = case nameModule_maybe name of + Just n_mod -> moduleName n_mod == mod + Nothing -> False + +pickGREsModExp :: ModuleName -> [GlobalRdrElt] -> [(GlobalRdrElt,GlobalRdrElt)] +-- ^ Pick GREs that are in scope *both* qualified *and* unqualified +-- Return each GRE that is, as a pair +-- (qual_gre, unqual_gre) +-- These two GREs are the original GRE with imports filtered to express how +-- it is in scope qualified an unqualified respectively +-- +-- Used only for the 'module M' item in export list; +-- see RnNames.exports_from_avail +pickGREsModExp mod gres = mapMaybe (pickBothGRE mod) gres + +pickBothGRE :: ModuleName -> GlobalRdrElt -> Maybe (GlobalRdrElt, GlobalRdrElt) +pickBothGRE mod gre@(GRE { gre_name = n }) + | isBuiltInSyntax n = Nothing + | Just gre1 <- pickQualGRE mod gre + , Just gre2 <- pickUnqualGRE gre = Just (gre1, gre2) + | otherwise = Nothing + where + -- isBuiltInSyntax filter out names for built-in syntax They + -- just clutter up the environment (esp tuples), and the + -- parser will generate Exact RdrNames for them, so the + -- cluttered envt is no use. Really, it's only useful for + -- GHC.Base and GHC.Tuple. + +-- Building GlobalRdrEnvs + +plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv +plusGlobalRdrEnv env1 env2 = plusOccEnv_C (foldr insertGRE) env1 env2 + +mkGlobalRdrEnv :: [GlobalRdrElt] -> GlobalRdrEnv +mkGlobalRdrEnv gres + = foldr add emptyGlobalRdrEnv gres + where + add gre env = extendOccEnv_Acc insertGRE singleton env + (greOccName gre) + gre + +insertGRE :: GlobalRdrElt -> [GlobalRdrElt] -> [GlobalRdrElt] +insertGRE new_g [] = [new_g] +insertGRE new_g (old_g : old_gs) + | gre_name new_g == gre_name old_g + = new_g `plusGRE` old_g : old_gs + | otherwise + = old_g : insertGRE new_g old_gs + +plusGRE :: GlobalRdrElt -> GlobalRdrElt -> GlobalRdrElt +-- Used when the gre_name fields match +plusGRE g1 g2 + = GRE { gre_name = gre_name g1 + , gre_lcl = gre_lcl g1 || gre_lcl g2 + , gre_imp = gre_imp g1 ++ gre_imp g2 + , gre_par = gre_par g1 `plusParent` gre_par g2 } + +transformGREs :: (GlobalRdrElt -> GlobalRdrElt) + -> [OccName] + -> GlobalRdrEnv -> GlobalRdrEnv +-- ^ Apply a transformation function to the GREs for these OccNames +transformGREs trans_gre occs rdr_env + = foldr trans rdr_env occs + where + trans occ env + = case lookupOccEnv env occ of + Just gres -> extendOccEnv env occ (map trans_gre gres) + Nothing -> env + +extendGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrElt -> GlobalRdrEnv +extendGlobalRdrEnv env gre + = extendOccEnv_Acc insertGRE singleton env + (greOccName gre) gre + +shadowNames :: GlobalRdrEnv -> [Name] -> GlobalRdrEnv +shadowNames = foldl' shadowName + +{- Note [GlobalRdrEnv shadowing] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Before adding new names to the GlobalRdrEnv we nuke some existing entries; +this is "shadowing". The actual work is done by RdrEnv.shadowName. +Suppose + env' = shadowName env M.f + +Then: + * Looking up (Unqual f) in env' should succeed, returning M.f, + even if env contains existing unqualified bindings for f. + They are shadowed + + * Looking up (Qual M.f) in env' should succeed, returning M.f + + * Looking up (Qual X.f) in env', where X /= M, should be the same as + looking up (Qual X.f) in env. + That is, shadowName does /not/ delete earlier qualified bindings + +There are two reasons for shadowing: + +* The GHCi REPL + + - Ids bought into scope on the command line (eg let x = True) have + External Names, like Ghci4.x. We want a new binding for 'x' (say) + to override the existing binding for 'x'. Example: + + ghci> :load M -- Brings `x` and `M.x` into scope + ghci> x + ghci> "Hello" + ghci> M.x + ghci> "hello" + ghci> let x = True -- Shadows `x` + ghci> x -- The locally bound `x` + -- NOT an ambiguous reference + ghci> True + ghci> M.x -- M.x is still in scope! + ghci> "Hello" + So when we add `x = True` we must not delete the `M.x` from the + `GlobalRdrEnv`; rather we just want to make it "qualified only"; + hence the `mk_fake-imp_spec` in `shadowName`. See also Note + [Interactively-bound Ids in GHCi] in HscTypes + + - Data types also have External Names, like Ghci4.T; but we still want + 'T' to mean the newly-declared 'T', not an old one. + +* Nested Template Haskell declaration brackets + See Note [Top-level Names in Template Haskell decl quotes] in RnNames + + Consider a TH decl quote: + module M where + f x = h [d| f = ...f...M.f... |] + We must shadow the outer unqualified binding of 'f', else we'll get + a complaint when extending the GlobalRdrEnv, saying that there are + two bindings for 'f'. There are several tricky points: + + - This shadowing applies even if the binding for 'f' is in a + where-clause, and hence is in the *local* RdrEnv not the *global* + RdrEnv. This is done in lcl_env_TH in extendGlobalRdrEnvRn. + + - The External Name M.f from the enclosing module must certainly + still be available. So we don't nuke it entirely; we just make + it seem like qualified import. + + - We only shadow *External* names (which come from the main module), + or from earlier GHCi commands. Do not shadow *Internal* names + because in the bracket + [d| class C a where f :: a + f = 4 |] + rnSrcDecls will first call extendGlobalRdrEnvRn with C[f] from the + class decl, and *separately* extend the envt with the value binding. + At that stage, the class op 'f' will have an Internal name. +-} + +shadowName :: GlobalRdrEnv -> Name -> GlobalRdrEnv +-- Remove certain old GREs that share the same OccName as this new Name. +-- See Note [GlobalRdrEnv shadowing] for details +shadowName env name + = alterOccEnv (fmap alter_fn) env (nameOccName name) + where + alter_fn :: [GlobalRdrElt] -> [GlobalRdrElt] + alter_fn gres = mapMaybe (shadow_with name) gres + + shadow_with :: Name -> GlobalRdrElt -> Maybe GlobalRdrElt + shadow_with new_name + old_gre@(GRE { gre_name = old_name, gre_lcl = lcl, gre_imp = iss }) + = case nameModule_maybe old_name of + Nothing -> Just old_gre -- Old name is Internal; do not shadow + Just old_mod + | Just new_mod <- nameModule_maybe new_name + , new_mod == old_mod -- Old name same as new name; shadow completely + -> Nothing + + | null iss' -- Nothing remains + -> Nothing + + | otherwise + -> Just (old_gre { gre_lcl = False, gre_imp = iss' }) + + where + iss' = lcl_imp ++ mapMaybe (shadow_is new_name) iss + lcl_imp | lcl = [mk_fake_imp_spec old_name old_mod] + | otherwise = [] + + mk_fake_imp_spec old_name old_mod -- Urgh! + = ImpSpec id_spec ImpAll + where + old_mod_name = moduleName old_mod + id_spec = ImpDeclSpec { is_mod = old_mod_name + , is_as = old_mod_name + , is_qual = True + , is_dloc = nameSrcSpan old_name } + + shadow_is :: Name -> ImportSpec -> Maybe ImportSpec + shadow_is new_name is@(ImpSpec { is_decl = id_spec }) + | Just new_mod <- nameModule_maybe new_name + , is_as id_spec == moduleName new_mod + = Nothing -- Shadow both qualified and unqualified + | otherwise -- Shadow unqualified only + = Just (is { is_decl = id_spec { is_qual = True } }) + + +{- +************************************************************************ +* * + ImportSpec +* * +************************************************************************ +-} + +-- | Import Specification +-- +-- The 'ImportSpec' of something says how it came to be imported +-- It's quite elaborate so that we can give accurate unused-name warnings. +data ImportSpec = ImpSpec { is_decl :: ImpDeclSpec, + is_item :: ImpItemSpec } + deriving( Eq, Ord, Data ) + +-- | Import Declaration Specification +-- +-- Describes a particular import declaration and is +-- shared among all the 'Provenance's for that decl +data ImpDeclSpec + = ImpDeclSpec { + is_mod :: ModuleName, -- ^ Module imported, e.g. @import Muggle@ + -- Note the @Muggle@ may well not be + -- the defining module for this thing! + + -- TODO: either should be Module, or there + -- should be a Maybe UnitId here too. + is_as :: ModuleName, -- ^ Import alias, e.g. from @as M@ (or @Muggle@ if there is no @as@ clause) + is_qual :: Bool, -- ^ Was this import qualified? + is_dloc :: SrcSpan -- ^ The location of the entire import declaration + } deriving Data + +-- | Import Item Specification +-- +-- Describes import info a particular Name +data ImpItemSpec + = ImpAll -- ^ The import had no import list, + -- or had a hiding list + + | ImpSome { + is_explicit :: Bool, + is_iloc :: SrcSpan -- Location of the import item + } -- ^ The import had an import list. + -- The 'is_explicit' field is @True@ iff the thing was named + -- /explicitly/ in the import specs rather + -- than being imported as part of a "..." group. Consider: + -- + -- > import C( T(..) ) + -- + -- Here the constructors of @T@ are not named explicitly; + -- only @T@ is named explicitly. + deriving Data + +instance Eq ImpDeclSpec where + p1 == p2 = case p1 `compare` p2 of EQ -> True; _ -> False + +instance Ord ImpDeclSpec where + compare is1 is2 = (is_mod is1 `compare` is_mod is2) `thenCmp` + (is_dloc is1 `compare` is_dloc is2) + +instance Eq ImpItemSpec where + p1 == p2 = case p1 `compare` p2 of EQ -> True; _ -> False + +instance Ord ImpItemSpec where + compare is1 is2 = + case (is1, is2) of + (ImpAll, ImpAll) -> EQ + (ImpAll, _) -> GT + (_, ImpAll) -> LT + (ImpSome _ l1, ImpSome _ l2) -> l1 `compare` l2 + + +bestImport :: [ImportSpec] -> ImportSpec +-- See Note [Choosing the best import declaration] +bestImport iss + = case sortBy best iss of + (is:_) -> is + [] -> pprPanic "bestImport" (ppr iss) + where + best :: ImportSpec -> ImportSpec -> Ordering + -- Less means better + -- Unqualified always wins over qualified; then + -- import-all wins over import-some; then + -- earlier declaration wins over later + best (ImpSpec { is_item = item1, is_decl = d1 }) + (ImpSpec { is_item = item2, is_decl = d2 }) + = (is_qual d1 `compare` is_qual d2) `thenCmp` + (best_item item1 item2) `thenCmp` + (is_dloc d1 `compare` is_dloc d2) + + best_item :: ImpItemSpec -> ImpItemSpec -> Ordering + best_item ImpAll ImpAll = EQ + best_item ImpAll (ImpSome {}) = LT + best_item (ImpSome {}) ImpAll = GT + best_item (ImpSome { is_explicit = e1 }) + (ImpSome { is_explicit = e2 }) = e1 `compare` e2 + -- False < True, so if e1 is explicit and e2 is not, we get GT + +{- Note [Choosing the best import declaration] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When reporting unused import declarations we use the following rules. + (see [wiki:commentary/compiler/unused-imports]) + +Say that an import-item is either + * an entire import-all decl (eg import Foo), or + * a particular item in an import list (eg import Foo( ..., x, ...)). +The general idea is that for each /occurrence/ of an imported name, we will +attribute that use to one import-item. Once we have processed all the +occurrences, any import items with no uses attributed to them are unused, +and are warned about. More precisely: + +1. For every RdrName in the program text, find its GlobalRdrElt. + +2. Then, from the [ImportSpec] (gre_imp) of that GRE, choose one + the "chosen import-item", and mark it "used". This is done + by 'bestImport' + +3. After processing all the RdrNames, bleat about any + import-items that are unused. + This is done in RnNames.warnUnusedImportDecls. + +The function 'bestImport' returns the dominant import among the +ImportSpecs it is given, implementing Step 2. We say import-item A +dominates import-item B if we choose A over B. In general, we try to +choose the import that is most likely to render other imports +unnecessary. Here is the dominance relationship we choose: + + a) import Foo dominates import qualified Foo. + + b) import Foo dominates import Foo(x). + + c) Otherwise choose the textually first one. + +Rationale for (a). Consider + import qualified M -- Import #1 + import M( x ) -- Import #2 + foo = M.x + x + +The unqualified 'x' can only come from import #2. The qualified 'M.x' +could come from either, but bestImport picks import #2, because it is +more likely to be useful in other imports, as indeed it is in this +case (see #5211 for a concrete example). + +But the rules are not perfect; consider + import qualified M -- Import #1 + import M( x ) -- Import #2 + foo = M.x + M.y + +The M.x will use import #2, but M.y can only use import #1. +-} + + +unQualSpecOK :: ImportSpec -> Bool +-- ^ Is in scope unqualified? +unQualSpecOK is = not (is_qual (is_decl is)) + +qualSpecOK :: ModuleName -> ImportSpec -> Bool +-- ^ Is in scope qualified with the given module? +qualSpecOK mod is = mod == is_as (is_decl is) + +importSpecLoc :: ImportSpec -> SrcSpan +importSpecLoc (ImpSpec decl ImpAll) = is_dloc decl +importSpecLoc (ImpSpec _ item) = is_iloc item + +importSpecModule :: ImportSpec -> ModuleName +importSpecModule is = is_mod (is_decl is) + +isExplicitItem :: ImpItemSpec -> Bool +isExplicitItem ImpAll = False +isExplicitItem (ImpSome {is_explicit = exp}) = exp + +pprNameProvenance :: GlobalRdrElt -> SDoc +-- ^ Print out one place where the name was define/imported +-- (With -dppr-debug, print them all) +pprNameProvenance (GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss }) + = ifPprDebug (vcat pp_provs) + (head pp_provs) + where + pp_provs = pp_lcl ++ map pp_is iss + pp_lcl = if lcl then [text "defined at" <+> ppr (nameSrcLoc name)] + else [] + pp_is is = sep [ppr is, ppr_defn_site is name] + +-- If we know the exact definition point (which we may do with GHCi) +-- then show that too. But not if it's just "imported from X". +ppr_defn_site :: ImportSpec -> Name -> SDoc +ppr_defn_site imp_spec name + | same_module && not (isGoodSrcSpan loc) + = empty -- Nothing interesting to say + | otherwise + = parens $ hang (text "and originally defined" <+> pp_mod) + 2 (pprLoc loc) + where + loc = nameSrcSpan name + defining_mod = ASSERT2( isExternalName name, ppr name ) nameModule name + same_module = importSpecModule imp_spec == moduleName defining_mod + pp_mod | same_module = empty + | otherwise = text "in" <+> quotes (ppr defining_mod) + + +instance Outputable ImportSpec where + ppr imp_spec + = text "imported" <+> qual + <+> text "from" <+> quotes (ppr (importSpecModule imp_spec)) + <+> pprLoc (importSpecLoc imp_spec) + where + qual | is_qual (is_decl imp_spec) = text "qualified" + | otherwise = empty + +pprLoc :: SrcSpan -> SDoc +pprLoc (RealSrcSpan s) = text "at" <+> ppr s +pprLoc (UnhelpfulSpan {}) = empty + +-- | Display info about the treatment of '*' under NoStarIsType. +-- +-- With StarIsType, three properties of '*' hold: +-- +-- (a) it is not an infix operator +-- (b) it is always in scope +-- (c) it is a synonym for Data.Kind.Type +-- +-- However, the user might not know that he's working on a module with +-- NoStarIsType and write code that still assumes (a), (b), and (c), which +-- actually do not hold in that module. +-- +-- Violation of (a) shows up in the parser. For instance, in the following +-- examples, we have '*' not applied to enough arguments: +-- +-- data A :: * +-- data F :: * -> * +-- +-- Violation of (b) or (c) show up in the renamer and the typechecker +-- respectively. For instance: +-- +-- type K = Either * Bool +-- +-- This will parse differently depending on whether StarIsType is enabled, +-- but it will parse nonetheless. With NoStarIsType it is parsed as a type +-- operator, thus we have ((*) Either Bool). Now there are two cases to +-- consider: +-- +-- 1. There is no definition of (*) in scope. In this case the renamer will +-- fail to look it up. This is a violation of assumption (b). +-- +-- 2. There is a definition of the (*) type operator in scope (for example +-- coming from GHC.TypeNats). In this case the user will get a kind +-- mismatch error. This is a violation of assumption (c). +-- +-- The user might unknowingly be working on a module with NoStarIsType +-- or use '*' as 'Data.Kind.Type' out of habit. So it is important to give a +-- hint whenever an assumption about '*' is violated. Unfortunately, it is +-- somewhat difficult to deal with (c), so we limit ourselves to (a) and (b). +-- +-- 'starInfo' generates an appropriate hint to the user depending on the +-- extensions enabled in the module and the name that triggered the error. +-- That is, if we have NoStarIsType and the error is related to '*' or its +-- Unicode variant, the resulting SDoc will contain a helpful suggestion. +-- Otherwise it is empty. +-- +starInfo :: Bool -> RdrName -> SDoc +starInfo star_is_type rdr_name = + -- One might ask: if can use sdocWithDynFlags here, why bother to take + -- star_is_type as input? Why not refactor? + -- + -- The reason is that sdocWithDynFlags would provide DynFlags that are active + -- in the module that tries to load the problematic definition, not + -- in the module that is being loaded. + -- + -- So if we have 'data T :: *' in a module with NoStarIsType, then the hint + -- must be displayed even if we load this definition from a module (or GHCi) + -- with StarIsType enabled! + -- + if isUnqualStar && not star_is_type + then text "With NoStarIsType, " <> + quotes (ppr rdr_name) <> + text " is treated as a regular type operator. " + $$ + text "Did you mean to use " <> quotes (text "Type") <> + text " from Data.Kind instead?" + else empty + where + -- Does rdr_name look like the user might have meant the '*' kind by it? + -- We focus on unqualified stars specifically, because qualified stars are + -- treated as type operators even under StarIsType. + isUnqualStar + | Unqual occName <- rdr_name + = let fs = occNameFS occName + in fs == fsLit "*" || fs == fsLit "★" + | otherwise = False diff --git a/compiler/basicTypes/SrcLoc.hs b/compiler/basicTypes/SrcLoc.hs new file mode 100644 --- /dev/null +++ b/compiler/basicTypes/SrcLoc.hs @@ -0,0 +1,696 @@ +-- (c) The University of Glasgow, 1992-2006 + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE PatternSynonyms #-} + + +-- | This module contains types that relate to the positions of things +-- in source files, and allow tagging of those things with locations +module SrcLoc ( + -- * SrcLoc + RealSrcLoc, -- Abstract + SrcLoc(..), + + -- ** Constructing SrcLoc + mkSrcLoc, mkRealSrcLoc, mkGeneralSrcLoc, + + noSrcLoc, -- "I'm sorry, I haven't a clue" + generatedSrcLoc, -- Code generated within the compiler + interactiveSrcLoc, -- Code from an interactive session + + advanceSrcLoc, + + -- ** Unsafely deconstructing SrcLoc + -- These are dubious exports, because they crash on some inputs + srcLocFile, -- return the file name part + srcLocLine, -- return the line part + srcLocCol, -- return the column part + + -- * SrcSpan + RealSrcSpan, -- Abstract + SrcSpan(..), + + -- ** Constructing SrcSpan + mkGeneralSrcSpan, mkSrcSpan, mkRealSrcSpan, + noSrcSpan, + wiredInSrcSpan, -- Something wired into the compiler + interactiveSrcSpan, + srcLocSpan, realSrcLocSpan, + combineSrcSpans, + srcSpanFirstCharacter, + + -- ** Deconstructing SrcSpan + srcSpanStart, srcSpanEnd, + realSrcSpanStart, realSrcSpanEnd, + srcSpanFileName_maybe, + pprUserRealSpan, + + -- ** Unsafely deconstructing SrcSpan + -- These are dubious exports, because they crash on some inputs + srcSpanFile, + srcSpanStartLine, srcSpanEndLine, + srcSpanStartCol, srcSpanEndCol, + + -- ** Predicates on SrcSpan + isGoodSrcSpan, isOneLineSpan, + containsSpan, + + -- * Located + Located, + RealLocated, + GenLocated(..), + + -- ** Constructing Located + noLoc, + mkGeneralLocated, + + -- ** Deconstructing Located + getLoc, unLoc, + unRealSrcSpan, getRealSrcSpan, + + -- ** Modifying Located + mapLoc, + + -- ** Combining and comparing Located values + eqLocated, cmpLocated, combineLocs, addCLoc, + leftmost_smallest, leftmost_largest, rightmost, + spans, isSubspanOf, sortLocated, + + -- ** HasSrcSpan + HasSrcSpan(..), SrcSpanLess, dL, cL, + pattern LL, onHasSrcSpan, liftL + ) where + +import GhcPrelude + +import Util +import Json +import Outputable +import FastString + +import Control.DeepSeq +import Data.Bits +import Data.Data +import Data.List +import Data.Ord + +{- +************************************************************************ +* * +\subsection[SrcLoc-SrcLocations]{Source-location information} +* * +************************************************************************ + +We keep information about the {\em definition} point for each entity; +this is the obvious stuff: +-} + +-- | Real Source Location +-- +-- Represents a single point within a file +data RealSrcLoc + = SrcLoc FastString -- A precise location (file name) + {-# UNPACK #-} !Int -- line number, begins at 1 + {-# UNPACK #-} !Int -- column number, begins at 1 + deriving (Eq, Ord) + +-- | Source Location +data SrcLoc + = RealSrcLoc {-# UNPACK #-}!RealSrcLoc + | UnhelpfulLoc FastString -- Just a general indication + deriving (Eq, Ord, Show) + +{- +************************************************************************ +* * +\subsection[SrcLoc-access-fns]{Access functions} +* * +************************************************************************ +-} + +mkSrcLoc :: FastString -> Int -> Int -> SrcLoc +mkSrcLoc x line col = RealSrcLoc (mkRealSrcLoc x line col) + +mkRealSrcLoc :: FastString -> Int -> Int -> RealSrcLoc +mkRealSrcLoc x line col = SrcLoc x line col + +-- | Built-in "bad" 'SrcLoc' values for particular locations +noSrcLoc, generatedSrcLoc, interactiveSrcLoc :: SrcLoc +noSrcLoc = UnhelpfulLoc (fsLit "") +generatedSrcLoc = UnhelpfulLoc (fsLit "") +interactiveSrcLoc = UnhelpfulLoc (fsLit "") + +-- | Creates a "bad" 'SrcLoc' that has no detailed information about its location +mkGeneralSrcLoc :: FastString -> SrcLoc +mkGeneralSrcLoc = UnhelpfulLoc + +-- | Gives the filename of the 'RealSrcLoc' +srcLocFile :: RealSrcLoc -> FastString +srcLocFile (SrcLoc fname _ _) = fname + +-- | Raises an error when used on a "bad" 'SrcLoc' +srcLocLine :: RealSrcLoc -> Int +srcLocLine (SrcLoc _ l _) = l + +-- | Raises an error when used on a "bad" 'SrcLoc' +srcLocCol :: RealSrcLoc -> Int +srcLocCol (SrcLoc _ _ c) = c + +-- | Move the 'SrcLoc' down by one line if the character is a newline, +-- to the next 8-char tabstop if it is a tab, and across by one +-- character in any other case +advanceSrcLoc :: RealSrcLoc -> Char -> RealSrcLoc +advanceSrcLoc (SrcLoc f l _) '\n' = SrcLoc f (l + 1) 1 +advanceSrcLoc (SrcLoc f l c) '\t' = SrcLoc f l (((((c - 1) `shiftR` 3) + 1) + `shiftL` 3) + 1) +advanceSrcLoc (SrcLoc f l c) _ = SrcLoc f l (c + 1) + +{- +************************************************************************ +* * +\subsection[SrcLoc-instances]{Instance declarations for various names} +* * +************************************************************************ +-} + +sortLocated :: HasSrcSpan a => [a] -> [a] +sortLocated things = sortBy (comparing getLoc) things + +instance Outputable RealSrcLoc where + ppr (SrcLoc src_path src_line src_col) + = hcat [ pprFastFilePath src_path <> colon + , int src_line <> colon + , int src_col ] + +-- I don't know why there is this style-based difference +-- if userStyle sty || debugStyle sty then +-- hcat [ pprFastFilePath src_path, char ':', +-- int src_line, +-- char ':', int src_col +-- ] +-- else +-- hcat [text "{-# LINE ", int src_line, space, +-- char '\"', pprFastFilePath src_path, text " #-}"] + +instance Outputable SrcLoc where + ppr (RealSrcLoc l) = ppr l + ppr (UnhelpfulLoc s) = ftext s + +instance Data RealSrcSpan where + -- don't traverse? + toConstr _ = abstractConstr "RealSrcSpan" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "RealSrcSpan" + +instance Data SrcSpan where + -- don't traverse? + toConstr _ = abstractConstr "SrcSpan" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "SrcSpan" + +{- +************************************************************************ +* * +\subsection[SrcSpan]{Source Spans} +* * +************************************************************************ +-} + +{- | +A 'RealSrcSpan' delimits a portion of a text file. It could be represented +by a pair of (line,column) coordinates, but in fact we optimise +slightly by using more compact representations for single-line and +zero-length spans, both of which are quite common. + +The end position is defined to be the column /after/ the end of the +span. That is, a span of (1,1)-(1,2) is one character long, and a +span of (1,1)-(1,1) is zero characters long. +-} + +-- | Real Source Span +data RealSrcSpan + = RealSrcSpan' + { srcSpanFile :: !FastString, + srcSpanSLine :: {-# UNPACK #-} !Int, + srcSpanSCol :: {-# UNPACK #-} !Int, + srcSpanELine :: {-# UNPACK #-} !Int, + srcSpanECol :: {-# UNPACK #-} !Int + } + deriving Eq + +-- | Source Span +-- +-- A 'SrcSpan' identifies either a specific portion of a text file +-- or a human-readable description of a location. +data SrcSpan = + RealSrcSpan !RealSrcSpan + | UnhelpfulSpan !FastString -- Just a general indication + -- also used to indicate an empty span + + deriving (Eq, Ord, Show) -- Show is used by Lexer.x, because we + -- derive Show for Token + +instance ToJson SrcSpan where + json (UnhelpfulSpan {} ) = JSNull --JSObject [( "type", "unhelpful")] + json (RealSrcSpan rss) = json rss + +instance ToJson RealSrcSpan where + json (RealSrcSpan'{..}) = JSObject [ ("file", JSString (unpackFS srcSpanFile)) + , ("startLine", JSInt srcSpanSLine) + , ("startCol", JSInt srcSpanSCol) + , ("endLine", JSInt srcSpanELine) + , ("endCol", JSInt srcSpanECol) + ] + +instance NFData SrcSpan where + rnf x = x `seq` () + +-- | Built-in "bad" 'SrcSpan's for common sources of location uncertainty +noSrcSpan, wiredInSrcSpan, interactiveSrcSpan :: SrcSpan +noSrcSpan = UnhelpfulSpan (fsLit "") +wiredInSrcSpan = UnhelpfulSpan (fsLit "") +interactiveSrcSpan = UnhelpfulSpan (fsLit "") + +-- | Create a "bad" 'SrcSpan' that has not location information +mkGeneralSrcSpan :: FastString -> SrcSpan +mkGeneralSrcSpan = UnhelpfulSpan + +-- | Create a 'SrcSpan' corresponding to a single point +srcLocSpan :: SrcLoc -> SrcSpan +srcLocSpan (UnhelpfulLoc str) = UnhelpfulSpan str +srcLocSpan (RealSrcLoc l) = RealSrcSpan (realSrcLocSpan l) + +realSrcLocSpan :: RealSrcLoc -> RealSrcSpan +realSrcLocSpan (SrcLoc file line col) = RealSrcSpan' file line col line col + +-- | Create a 'SrcSpan' between two points in a file +mkRealSrcSpan :: RealSrcLoc -> RealSrcLoc -> RealSrcSpan +mkRealSrcSpan loc1 loc2 = RealSrcSpan' file line1 col1 line2 col2 + where + line1 = srcLocLine loc1 + line2 = srcLocLine loc2 + col1 = srcLocCol loc1 + col2 = srcLocCol loc2 + file = srcLocFile loc1 + +-- | 'True' if the span is known to straddle only one line. +isOneLineRealSpan :: RealSrcSpan -> Bool +isOneLineRealSpan (RealSrcSpan' _ line1 _ line2 _) + = line1 == line2 + +-- | 'True' if the span is a single point +isPointRealSpan :: RealSrcSpan -> Bool +isPointRealSpan (RealSrcSpan' _ line1 col1 line2 col2) + = line1 == line2 && col1 == col2 + +-- | Create a 'SrcSpan' between two points in a file +mkSrcSpan :: SrcLoc -> SrcLoc -> SrcSpan +mkSrcSpan (UnhelpfulLoc str) _ = UnhelpfulSpan str +mkSrcSpan _ (UnhelpfulLoc str) = UnhelpfulSpan str +mkSrcSpan (RealSrcLoc loc1) (RealSrcLoc loc2) + = RealSrcSpan (mkRealSrcSpan loc1 loc2) + +-- | Combines two 'SrcSpan' into one that spans at least all the characters +-- within both spans. Returns UnhelpfulSpan if the files differ. +combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan +combineSrcSpans (UnhelpfulSpan _) r = r -- this seems more useful +combineSrcSpans l (UnhelpfulSpan _) = l +combineSrcSpans (RealSrcSpan span1) (RealSrcSpan span2) + | srcSpanFile span1 == srcSpanFile span2 + = RealSrcSpan (combineRealSrcSpans span1 span2) + | otherwise = UnhelpfulSpan (fsLit "") + +-- | Combines two 'SrcSpan' into one that spans at least all the characters +-- within both spans. Assumes the "file" part is the same in both inputs +combineRealSrcSpans :: RealSrcSpan -> RealSrcSpan -> RealSrcSpan +combineRealSrcSpans span1 span2 + = RealSrcSpan' file line_start col_start line_end col_end + where + (line_start, col_start) = min (srcSpanStartLine span1, srcSpanStartCol span1) + (srcSpanStartLine span2, srcSpanStartCol span2) + (line_end, col_end) = max (srcSpanEndLine span1, srcSpanEndCol span1) + (srcSpanEndLine span2, srcSpanEndCol span2) + file = srcSpanFile span1 + +-- | Convert a SrcSpan into one that represents only its first character +srcSpanFirstCharacter :: SrcSpan -> SrcSpan +srcSpanFirstCharacter l@(UnhelpfulSpan {}) = l +srcSpanFirstCharacter (RealSrcSpan span) = RealSrcSpan $ mkRealSrcSpan loc1 loc2 + where + loc1@(SrcLoc f l c) = realSrcSpanStart span + loc2 = SrcLoc f l (c+1) + +{- +************************************************************************ +* * +\subsection[SrcSpan-predicates]{Predicates} +* * +************************************************************************ +-} + +-- | Test if a 'SrcSpan' is "good", i.e. has precise location information +isGoodSrcSpan :: SrcSpan -> Bool +isGoodSrcSpan (RealSrcSpan _) = True +isGoodSrcSpan (UnhelpfulSpan _) = False + +isOneLineSpan :: SrcSpan -> Bool +-- ^ True if the span is known to straddle only one line. +-- For "bad" 'SrcSpan', it returns False +isOneLineSpan (RealSrcSpan s) = srcSpanStartLine s == srcSpanEndLine s +isOneLineSpan (UnhelpfulSpan _) = False + +-- | Tests whether the first span "contains" the other span, meaning +-- that it covers at least as much source code. True where spans are equal. +containsSpan :: RealSrcSpan -> RealSrcSpan -> Bool +containsSpan s1 s2 + = (srcSpanStartLine s1, srcSpanStartCol s1) + <= (srcSpanStartLine s2, srcSpanStartCol s2) + && (srcSpanEndLine s1, srcSpanEndCol s1) + >= (srcSpanEndLine s2, srcSpanEndCol s2) + && (srcSpanFile s1 == srcSpanFile s2) + -- We check file equality last because it is (presumably?) least + -- likely to fail. +{- +%************************************************************************ +%* * +\subsection[SrcSpan-unsafe-access-fns]{Unsafe access functions} +* * +************************************************************************ +-} + +srcSpanStartLine :: RealSrcSpan -> Int +srcSpanEndLine :: RealSrcSpan -> Int +srcSpanStartCol :: RealSrcSpan -> Int +srcSpanEndCol :: RealSrcSpan -> Int + +srcSpanStartLine RealSrcSpan'{ srcSpanSLine=l } = l +srcSpanEndLine RealSrcSpan'{ srcSpanELine=l } = l +srcSpanStartCol RealSrcSpan'{ srcSpanSCol=l } = l +srcSpanEndCol RealSrcSpan'{ srcSpanECol=c } = c + +{- +************************************************************************ +* * +\subsection[SrcSpan-access-fns]{Access functions} +* * +************************************************************************ +-} + +-- | Returns the location at the start of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable +srcSpanStart :: SrcSpan -> SrcLoc +srcSpanStart (UnhelpfulSpan str) = UnhelpfulLoc str +srcSpanStart (RealSrcSpan s) = RealSrcLoc (realSrcSpanStart s) + +-- | Returns the location at the end of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable +srcSpanEnd :: SrcSpan -> SrcLoc +srcSpanEnd (UnhelpfulSpan str) = UnhelpfulLoc str +srcSpanEnd (RealSrcSpan s) = RealSrcLoc (realSrcSpanEnd s) + +realSrcSpanStart :: RealSrcSpan -> RealSrcLoc +realSrcSpanStart s = mkRealSrcLoc (srcSpanFile s) + (srcSpanStartLine s) + (srcSpanStartCol s) + +realSrcSpanEnd :: RealSrcSpan -> RealSrcLoc +realSrcSpanEnd s = mkRealSrcLoc (srcSpanFile s) + (srcSpanEndLine s) + (srcSpanEndCol s) + +-- | Obtains the filename for a 'SrcSpan' if it is "good" +srcSpanFileName_maybe :: SrcSpan -> Maybe FastString +srcSpanFileName_maybe (RealSrcSpan s) = Just (srcSpanFile s) +srcSpanFileName_maybe (UnhelpfulSpan _) = Nothing + +{- +************************************************************************ +* * +\subsection[SrcSpan-instances]{Instances} +* * +************************************************************************ +-} + +-- We want to order RealSrcSpans first by the start point, then by the +-- end point. +instance Ord RealSrcSpan where + a `compare` b = + (realSrcSpanStart a `compare` realSrcSpanStart b) `thenCmp` + (realSrcSpanEnd a `compare` realSrcSpanEnd b) + +instance Show RealSrcLoc where + show (SrcLoc filename row col) + = "SrcLoc " ++ show filename ++ " " ++ show row ++ " " ++ show col + +-- Show is used by Lexer.x, because we derive Show for Token +instance Show RealSrcSpan where + show span@(RealSrcSpan' file sl sc el ec) + | isPointRealSpan span + = "SrcSpanPoint " ++ show file ++ " " ++ intercalate " " (map show [sl,sc]) + + | isOneLineRealSpan span + = "SrcSpanOneLine " ++ show file ++ " " + ++ intercalate " " (map show [sl,sc,ec]) + + | otherwise + = "SrcSpanMultiLine " ++ show file ++ " " + ++ intercalate " " (map show [sl,sc,el,ec]) + + +instance Outputable RealSrcSpan where + ppr span = pprUserRealSpan True span + +-- I don't know why there is this style-based difference +-- = getPprStyle $ \ sty -> +-- if userStyle sty || debugStyle sty then +-- text (showUserRealSpan True span) +-- else +-- hcat [text "{-# LINE ", int (srcSpanStartLine span), space, +-- char '\"', pprFastFilePath $ srcSpanFile span, text " #-}"] + +instance Outputable SrcSpan where + ppr span = pprUserSpan True span + +-- I don't know why there is this style-based difference +-- = getPprStyle $ \ sty -> +-- if userStyle sty || debugStyle sty then +-- pprUserSpan True span +-- else +-- case span of +-- UnhelpfulSpan _ -> panic "Outputable UnhelpfulSpan" +-- RealSrcSpan s -> ppr s + +pprUserSpan :: Bool -> SrcSpan -> SDoc +pprUserSpan _ (UnhelpfulSpan s) = ftext s +pprUserSpan show_path (RealSrcSpan s) = pprUserRealSpan show_path s + +pprUserRealSpan :: Bool -> RealSrcSpan -> SDoc +pprUserRealSpan show_path span@(RealSrcSpan' src_path line col _ _) + | isPointRealSpan span + = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon) + , int line <> colon + , int col ] + +pprUserRealSpan show_path span@(RealSrcSpan' src_path line scol _ ecol) + | isOneLineRealSpan span + = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon) + , int line <> colon + , int scol + , ppUnless (ecol - scol <= 1) (char '-' <> int (ecol - 1)) ] + -- For single-character or point spans, we just + -- output the starting column number + +pprUserRealSpan show_path (RealSrcSpan' src_path sline scol eline ecol) + = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon) + , parens (int sline <> comma <> int scol) + , char '-' + , parens (int eline <> comma <> int ecol') ] + where + ecol' = if ecol == 0 then ecol else ecol - 1 + +{- +************************************************************************ +* * +\subsection[Located]{Attaching SrcSpans to things} +* * +************************************************************************ +-} + +-- | We attach SrcSpans to lots of things, so let's have a datatype for it. +data GenLocated l e = L l e + deriving (Eq, Ord, Data, Functor, Foldable, Traversable) + +type Located = GenLocated SrcSpan +type RealLocated = GenLocated RealSrcSpan + +mapLoc :: (a -> b) -> GenLocated l a -> GenLocated l b +mapLoc = fmap + +unLoc :: HasSrcSpan a => a -> SrcSpanLess a +unLoc (dL->L _ e) = e + +getLoc :: HasSrcSpan a => a -> SrcSpan +getLoc (dL->L l _) = l + +noLoc :: HasSrcSpan a => SrcSpanLess a -> a +noLoc e = cL noSrcSpan e + +mkGeneralLocated :: HasSrcSpan e => String -> SrcSpanLess e -> e +mkGeneralLocated s e = cL (mkGeneralSrcSpan (fsLit s)) e + +combineLocs :: (HasSrcSpan a , HasSrcSpan b) => a -> b -> SrcSpan +combineLocs a b = combineSrcSpans (getLoc a) (getLoc b) + +-- | Combine locations from two 'Located' things and add them to a third thing +addCLoc :: (HasSrcSpan a , HasSrcSpan b , HasSrcSpan c) => + a -> b -> SrcSpanLess c -> c +addCLoc a b c = cL (combineSrcSpans (getLoc a) (getLoc b)) c + +-- not clear whether to add a general Eq instance, but this is useful sometimes: + +-- | Tests whether the two located things are equal +eqLocated :: (HasSrcSpan a , Eq (SrcSpanLess a)) => a -> a -> Bool +eqLocated a b = unLoc a == unLoc b + +-- not clear whether to add a general Ord instance, but this is useful sometimes: + +-- | Tests the ordering of the two located things +cmpLocated :: (HasSrcSpan a , Ord (SrcSpanLess a)) => a -> a -> Ordering +cmpLocated a b = unLoc a `compare` unLoc b + +instance (Outputable l, Outputable e) => Outputable (GenLocated l e) where + ppr (L l e) = -- TODO: We can't do this since Located was refactored into + -- GenLocated: + -- Print spans without the file name etc + -- ifPprDebug (braces (pprUserSpan False l)) + whenPprDebug (braces (ppr l)) + $$ ppr e + +{- +************************************************************************ +* * +\subsection{Ordering SrcSpans for InteractiveUI} +* * +************************************************************************ +-} + +-- | Alternative strategies for ordering 'SrcSpan's +leftmost_smallest, leftmost_largest, rightmost :: SrcSpan -> SrcSpan -> Ordering +rightmost = flip compare +leftmost_smallest = compare +leftmost_largest a b = (srcSpanStart a `compare` srcSpanStart b) + `thenCmp` + (srcSpanEnd b `compare` srcSpanEnd a) + +-- | Determines whether a span encloses a given line and column index +spans :: SrcSpan -> (Int, Int) -> Bool +spans (UnhelpfulSpan _) _ = panic "spans UnhelpfulSpan" +spans (RealSrcSpan span) (l,c) = realSrcSpanStart span <= loc && loc <= realSrcSpanEnd span + where loc = mkRealSrcLoc (srcSpanFile span) l c + +-- | Determines whether a span is enclosed by another one +isSubspanOf :: SrcSpan -- ^ The span that may be enclosed by the other + -> SrcSpan -- ^ The span it may be enclosed by + -> Bool +isSubspanOf src parent + | srcSpanFileName_maybe parent /= srcSpanFileName_maybe src = False + | otherwise = srcSpanStart parent <= srcSpanStart src && + srcSpanEnd parent >= srcSpanEnd src + + +{- +************************************************************************ +* * +\subsection{HasSrcSpan Typeclass to Set/Get Source Location Spans} +* * +************************************************************************ +-} + +{- +Note [HasSrcSpan Typeclass] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +To be able to uniformly set/get source location spans (of `SrcSpan`) in +syntactic entities (`HsSyn`), we use the typeclass `HasSrcSpan`. +More details can be found at the following wiki page + ImplementingTreesThatGrow/HandlingSourceLocations + +For most syntactic entities, the source location spans are stored in +a syntactic entity by a wapper constuctor (introduced by TTG's +new constructor extension), e.g., by `NewPat (WrapperPat sp pat)` +for a source location span `sp` and a pattern `pat`. +-} + +-- | Determines the type of undecorated syntactic entities +-- For most syntactic entities `E`, where source location spans are +-- introduced by a wrapper construtor of the same syntactic entity, +-- we have `SrcSpanLess E = E`. +-- However, some syntactic entities have a different type compared to +-- a syntactic entity `e :: E` may have the type `Located E` when +-- decorated by wrapping it with `L sp e` for a source span `sp`. +type family SrcSpanLess a + +-- | A typeclass to set/get SrcSpans +class HasSrcSpan a where + -- | Composes a `SrcSpan` decoration with an undecorated syntactic + -- entity to form its decorated variant + composeSrcSpan :: Located (SrcSpanLess a) -> a + + -- | Decomposes a decorated syntactic entity into its `SrcSpan` + -- decoration and its undecorated variant + decomposeSrcSpan :: a -> Located (SrcSpanLess a) + {- laws: + composeSrcSpan . decomposeSrcSpan = id + decomposeSrcSpan . composeSrcSpan = id + + in other words, `HasSrcSpan` defines an iso relation between + a `SrcSpan`-decorated syntactic entity and its undecorated variant + (together with the `SrcSpan`). + -} + +type instance SrcSpanLess (GenLocated l e) = e +instance HasSrcSpan (Located a) where + composeSrcSpan = id + decomposeSrcSpan = id + + +-- | An abbreviated form of decomposeSrcSpan, +-- mainly to be used in ViewPatterns +dL :: HasSrcSpan a => a -> Located (SrcSpanLess a) +dL = decomposeSrcSpan + +-- | An abbreviated form of composeSrcSpan, +-- mainly to replace the hardcoded `L` +cL :: HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a +cL sp e = composeSrcSpan (L sp e) + +-- | A Pattern Synonym to Set/Get SrcSpans +pattern LL :: HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a +pattern LL sp e <- (dL->L sp e) + where + LL sp e = cL sp e + +-- | Lifts a function of undecorated entities to one of decorated ones +onHasSrcSpan :: (HasSrcSpan a , HasSrcSpan b) => + (SrcSpanLess a -> SrcSpanLess b) -> a -> b +onHasSrcSpan f (dL->L l e) = cL l (f e) + +liftL :: (HasSrcSpan a, HasSrcSpan b, Monad m) => + (SrcSpanLess a -> m (SrcSpanLess b)) -> a -> m b +liftL f (dL->L loc a) = do + a' <- f a + return $ cL loc a' + + +getRealSrcSpan :: RealLocated a -> RealSrcSpan +getRealSrcSpan (L l _) = l + +unRealSrcSpan :: RealLocated a -> a +unRealSrcSpan (L _ e) = e diff --git a/compiler/basicTypes/UniqSupply.hs b/compiler/basicTypes/UniqSupply.hs new file mode 100644 --- /dev/null +++ b/compiler/basicTypes/UniqSupply.hs @@ -0,0 +1,240 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE CPP, UnboxedTuples #-} + +module UniqSupply ( + -- * Main data type + UniqSupply, -- Abstractly + + -- ** Operations on supplies + uniqFromSupply, uniqsFromSupply, -- basic ops + takeUniqFromSupply, + + mkSplitUniqSupply, + splitUniqSupply, listSplitUniqSupply, + splitUniqSupply3, splitUniqSupply4, + + -- * Unique supply monad and its abstraction + UniqSM, MonadUnique(..), liftUs, + + -- ** Operations on the monad + initUs, initUs_, + lazyThenUs, lazyMapUs, + getUniqueSupplyM3, + + -- * Set supply strategy + initUniqSupply + ) where + +import GhcPrelude + +import Unique +import Panic (panic) + +import GHC.IO + +import MonadUtils +import Control.Monad +import Data.Bits +import Data.Char +import Control.Monad.Fail as Fail + +#include "Unique.h" + +{- +************************************************************************ +* * +\subsection{Splittable Unique supply: @UniqSupply@} +* * +************************************************************************ +-} + +-- | Unique Supply +-- +-- A value of type 'UniqSupply' is unique, and it can +-- supply /one/ distinct 'Unique'. Also, from the supply, one can +-- also manufacture an arbitrary number of further 'UniqueSupply' values, +-- which will be distinct from the first and from all others. +data UniqSupply + = MkSplitUniqSupply {-# UNPACK #-} !Int -- make the Unique with this + UniqSupply UniqSupply + -- when split => these two supplies + +mkSplitUniqSupply :: Char -> IO UniqSupply +-- ^ Create a unique supply out of thin air. The character given must +-- be distinct from those of all calls to this function in the compiler +-- for the values generated to be truly unique. + +splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply) +-- ^ Build two 'UniqSupply' from a single one, each of which +-- can supply its own 'Unique'. +listSplitUniqSupply :: UniqSupply -> [UniqSupply] +-- ^ Create an infinite list of 'UniqSupply' from a single one +uniqFromSupply :: UniqSupply -> Unique +-- ^ Obtain the 'Unique' from this particular 'UniqSupply' +uniqsFromSupply :: UniqSupply -> [Unique] -- Infinite +-- ^ Obtain an infinite list of 'Unique' that can be generated by constant splitting of the supply +takeUniqFromSupply :: UniqSupply -> (Unique, UniqSupply) +-- ^ Obtain the 'Unique' from this particular 'UniqSupply', and a new supply + +mkSplitUniqSupply c + = case ord c `shiftL` uNIQUE_BITS of + mask -> let + -- here comes THE MAGIC: + + -- This is one of the most hammered bits in the whole compiler + mk_supply + -- NB: Use unsafeInterleaveIO for thread-safety. + = unsafeInterleaveIO ( + genSym >>= \ u -> + mk_supply >>= \ s1 -> + mk_supply >>= \ s2 -> + return (MkSplitUniqSupply (mask .|. u) s1 s2) + ) + in + mk_supply + +foreign import ccall unsafe "genSym" genSym :: IO Int +foreign import ccall unsafe "initGenSym" initUniqSupply :: Int -> Int -> IO () + +splitUniqSupply (MkSplitUniqSupply _ s1 s2) = (s1, s2) +listSplitUniqSupply (MkSplitUniqSupply _ s1 s2) = s1 : listSplitUniqSupply s2 + +uniqFromSupply (MkSplitUniqSupply n _ _) = mkUniqueGrimily n +uniqsFromSupply (MkSplitUniqSupply n _ s2) = mkUniqueGrimily n : uniqsFromSupply s2 +takeUniqFromSupply (MkSplitUniqSupply n s1 _) = (mkUniqueGrimily n, s1) + +-- | Build three 'UniqSupply' from a single one, +-- each of which can supply its own unique +splitUniqSupply3 :: UniqSupply -> (UniqSupply, UniqSupply, UniqSupply) +splitUniqSupply3 us = (us1, us2, us3) + where + (us1, us') = splitUniqSupply us + (us2, us3) = splitUniqSupply us' + +-- | Build four 'UniqSupply' from a single one, +-- each of which can supply its own unique +splitUniqSupply4 :: UniqSupply -> (UniqSupply, UniqSupply, UniqSupply, UniqSupply) +splitUniqSupply4 us = (us1, us2, us3, us4) + where + (us1, us2, us') = splitUniqSupply3 us + (us3, us4) = splitUniqSupply us' + +{- +************************************************************************ +* * +\subsubsection[UniqSupply-monad]{@UniqSupply@ monad: @UniqSM@} +* * +************************************************************************ +-} + +-- | A monad which just gives the ability to obtain 'Unique's +newtype UniqSM result = USM { unUSM :: UniqSupply -> (# result, UniqSupply #) } + +instance Monad UniqSM where + (>>=) = thenUs + (>>) = (*>) + +instance Functor UniqSM where + fmap f (USM x) = USM (\us -> case x us of + (# r, us' #) -> (# f r, us' #)) + +instance Applicative UniqSM where + pure = returnUs + (USM f) <*> (USM x) = USM $ \us -> case f us of + (# ff, us' #) -> case x us' of + (# xx, us'' #) -> (# ff xx, us'' #) + (*>) = thenUs_ + +-- TODO: try to get rid of this instance +instance Fail.MonadFail UniqSM where + fail = panic + +-- | Run the 'UniqSM' action, returning the final 'UniqSupply' +initUs :: UniqSupply -> UniqSM a -> (a, UniqSupply) +initUs init_us m = case unUSM m init_us of { (# r, us #) -> (r,us) } + +-- | Run the 'UniqSM' action, discarding the final 'UniqSupply' +initUs_ :: UniqSupply -> UniqSM a -> a +initUs_ init_us m = case unUSM m init_us of { (# r, _ #) -> r } + +{-# INLINE thenUs #-} +{-# INLINE lazyThenUs #-} +{-# INLINE returnUs #-} +{-# INLINE splitUniqSupply #-} + +-- @thenUs@ is where we split the @UniqSupply@. + +liftUSM :: UniqSM a -> UniqSupply -> (a, UniqSupply) +liftUSM (USM m) us = case m us of (# a, us' #) -> (a, us') + +instance MonadFix UniqSM where + mfix m = USM (\us -> let (r,us') = liftUSM (m r) us in (# r,us' #)) + +thenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b +thenUs (USM expr) cont + = USM (\us -> case (expr us) of + (# result, us' #) -> unUSM (cont result) us') + +lazyThenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b +lazyThenUs expr cont + = USM (\us -> let (result, us') = liftUSM expr us in unUSM (cont result) us') + +thenUs_ :: UniqSM a -> UniqSM b -> UniqSM b +thenUs_ (USM expr) (USM cont) + = USM (\us -> case (expr us) of { (# _, us' #) -> cont us' }) + +returnUs :: a -> UniqSM a +returnUs result = USM (\us -> (# result, us #)) + +getUs :: UniqSM UniqSupply +getUs = USM (\us -> case splitUniqSupply us of (us1,us2) -> (# us1, us2 #)) + +-- | A monad for generating unique identifiers +class Monad m => MonadUnique m where + -- | Get a new UniqueSupply + getUniqueSupplyM :: m UniqSupply + -- | Get a new unique identifier + getUniqueM :: m Unique + -- | Get an infinite list of new unique identifiers + getUniquesM :: m [Unique] + + -- This default definition of getUniqueM, while correct, is not as + -- efficient as it could be since it needlessly generates and throws away + -- an extra Unique. For your instances consider providing an explicit + -- definition for 'getUniqueM' which uses 'takeUniqFromSupply' directly. + getUniqueM = liftM uniqFromSupply getUniqueSupplyM + getUniquesM = liftM uniqsFromSupply getUniqueSupplyM + +instance MonadUnique UniqSM where + getUniqueSupplyM = getUs + getUniqueM = getUniqueUs + getUniquesM = getUniquesUs + +getUniqueSupplyM3 :: MonadUnique m => m (UniqSupply, UniqSupply, UniqSupply) +getUniqueSupplyM3 = liftM3 (,,) getUniqueSupplyM getUniqueSupplyM getUniqueSupplyM + +liftUs :: MonadUnique m => UniqSM a -> m a +liftUs m = getUniqueSupplyM >>= return . flip initUs_ m + +getUniqueUs :: UniqSM Unique +getUniqueUs = USM (\us -> case takeUniqFromSupply us of + (u,us') -> (# u, us' #)) + +getUniquesUs :: UniqSM [Unique] +getUniquesUs = USM (\us -> case splitUniqSupply us of + (us1,us2) -> (# uniqsFromSupply us1, us2 #)) + +-- {-# SPECIALIZE mapM :: (a -> UniqSM b) -> [a] -> UniqSM [b] #-} +-- {-# SPECIALIZE mapAndUnzipM :: (a -> UniqSM (b,c)) -> [a] -> UniqSM ([b],[c]) #-} +-- {-# SPECIALIZE mapAndUnzip3M :: (a -> UniqSM (b,c,d)) -> [a] -> UniqSM ([b],[c],[d]) #-} + +lazyMapUs :: (a -> UniqSM b) -> [a] -> UniqSM [b] +lazyMapUs _ [] = returnUs [] +lazyMapUs f (x:xs) + = f x `lazyThenUs` \ r -> + lazyMapUs f xs `lazyThenUs` \ rs -> + returnUs (r:rs) diff --git a/compiler/basicTypes/Unique.hs b/compiler/basicTypes/Unique.hs new file mode 100644 --- /dev/null +++ b/compiler/basicTypes/Unique.hs @@ -0,0 +1,442 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +@Uniques@ are used to distinguish entities in the compiler (@Ids@, +@Classes@, etc.) from each other. Thus, @Uniques@ are the basic +comparison key in the compiler. + +If there is any single operation that needs to be fast, it is @Unique@ + +comparison. Unsurprisingly, there is quite a bit of huff-and-puff +directed to that end. + +Some of the other hair in this code is to be able to use a +``splittable @UniqueSupply@'' if requested/possible (not standard +Haskell). +-} + +{-# LANGUAGE CPP, BangPatterns, MagicHash #-} + +module Unique ( + -- * Main data types + Unique, Uniquable(..), + uNIQUE_BITS, + + -- ** Constructors, destructors and operations on 'Unique's + hasKey, + + pprUniqueAlways, + + mkUniqueGrimily, -- Used in UniqSupply only! + getKey, -- Used in Var, UniqFM, Name only! + mkUnique, unpkUnique, -- Used in BinIface only + eqUnique, ltUnique, + + deriveUnique, -- Ditto + newTagUnique, -- Used in CgCase + initTyVarUnique, + initExitJoinUnique, + nonDetCmpUnique, + isValidKnownKeyUnique, -- Used in PrelInfo.knownKeyNamesOkay + + -- ** Making built-in uniques + + -- now all the built-in Uniques (and functions to make them) + -- [the Oh-So-Wonderful Haskell module system wins again...] + mkAlphaTyVarUnique, + mkPrimOpIdUnique, + mkPreludeMiscIdUnique, mkPreludeDataConUnique, + mkPreludeTyConUnique, mkPreludeClassUnique, + mkCoVarUnique, + + mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique, + mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique, + mkCostCentreUnique, + + mkBuiltinUnique, + mkPseudoUniqueD, + mkPseudoUniqueE, + mkPseudoUniqueH, + + -- ** Deriving uniques + -- *** From TyCon name uniques + tyConRepNameUnique, + -- *** From DataCon name uniques + dataConWorkerUnique, dataConTyRepNameUnique + ) where + +#include "HsVersions.h" +#include "Unique.h" + +import GhcPrelude + +import BasicTypes +import FastString +import Outputable +import Util + +-- just for implementing a fast [0,61) -> Char function +import GHC.Exts (indexCharOffAddr#, Char(..), Int(..)) + +import Data.Char ( chr, ord ) +import Data.Bits + +{- +************************************************************************ +* * +\subsection[Unique-type]{@Unique@ type and operations} +* * +************************************************************************ + +The @Chars@ are ``tag letters'' that identify the @UniqueSupply@. +Fast comparison is everything on @Uniques@: +-} + +-- | Unique identifier. +-- +-- The type of unique identifiers that are used in many places in GHC +-- for fast ordering and equality tests. You should generate these with +-- the functions from the 'UniqSupply' module +-- +-- These are sometimes also referred to as \"keys\" in comments in GHC. +newtype Unique = MkUnique Int + +{-# INLINE uNIQUE_BITS #-} +uNIQUE_BITS :: Int +uNIQUE_BITS = finiteBitSize (0 :: Int) - UNIQUE_TAG_BITS + +{- +Now come the functions which construct uniques from their pieces, and vice versa. +The stuff about unique *supplies* is handled further down this module. +-} + +unpkUnique :: Unique -> (Char, Int) -- The reverse + +mkUniqueGrimily :: Int -> Unique -- A trap-door for UniqSupply +getKey :: Unique -> Int -- for Var + +incrUnique :: Unique -> Unique +stepUnique :: Unique -> Int -> Unique +deriveUnique :: Unique -> Int -> Unique +newTagUnique :: Unique -> Char -> Unique + +mkUniqueGrimily = MkUnique + +{-# INLINE getKey #-} +getKey (MkUnique x) = x + +incrUnique (MkUnique i) = MkUnique (i + 1) +stepUnique (MkUnique i) n = MkUnique (i + n) + +-- deriveUnique uses an 'X' tag so that it won't clash with +-- any of the uniques produced any other way +-- SPJ says: this looks terribly smelly to me! +deriveUnique (MkUnique i) delta = mkUnique 'X' (i + delta) + +-- newTagUnique changes the "domain" of a unique to a different char +newTagUnique u c = mkUnique c i where (_,i) = unpkUnique u + +-- | How many bits are devoted to the unique index (as opposed to the class +-- character). +uniqueMask :: Int +uniqueMask = (1 `shiftL` uNIQUE_BITS) - 1 + +-- pop the Char in the top 8 bits of the Unique(Supply) + +-- No 64-bit bugs here, as long as we have at least 32 bits. --JSM + +-- and as long as the Char fits in 8 bits, which we assume anyway! + +mkUnique :: Char -> Int -> Unique -- Builds a unique from pieces +-- NOT EXPORTED, so that we can see all the Chars that +-- are used in this one module +mkUnique c i + = MkUnique (tag .|. bits) + where + tag = ord c `shiftL` uNIQUE_BITS + bits = i .&. uniqueMask + +unpkUnique (MkUnique u) + = let + -- as long as the Char may have its eighth bit set, we + -- really do need the logical right-shift here! + tag = chr (u `shiftR` uNIQUE_BITS) + i = u .&. uniqueMask + in + (tag, i) + +-- | The interface file symbol-table encoding assumes that known-key uniques fit +-- in 30-bits; verify this. +-- +-- See Note [Symbol table representation of names] in BinIface for details. +isValidKnownKeyUnique :: Unique -> Bool +isValidKnownKeyUnique u = + case unpkUnique u of + (c, x) -> ord c < 0xff && x <= (1 `shiftL` 22) + +{- +************************************************************************ +* * +\subsection[Uniquable-class]{The @Uniquable@ class} +* * +************************************************************************ +-} + +-- | Class of things that we can obtain a 'Unique' from +class Uniquable a where + getUnique :: a -> Unique + +hasKey :: Uniquable a => a -> Unique -> Bool +x `hasKey` k = getUnique x == k + +instance Uniquable FastString where + getUnique fs = mkUniqueGrimily (uniqueOfFS fs) + +instance Uniquable Int where + getUnique i = mkUniqueGrimily i + +{- +************************************************************************ +* * +\subsection[Unique-instances]{Instance declarations for @Unique@} +* * +************************************************************************ + +And the whole point (besides uniqueness) is fast equality. We don't +use `deriving' because we want {\em precise} control of ordering +(equality on @Uniques@ is v common). +-} + +-- Note [Unique Determinism] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The order of allocated @Uniques@ is not stable across rebuilds. +-- The main reason for that is that typechecking interface files pulls +-- @Uniques@ from @UniqSupply@ and the interface file for the module being +-- currently compiled can, but doesn't have to exist. +-- +-- It gets more complicated if you take into account that the interface +-- files are loaded lazily and that building multiple files at once has to +-- work for any subset of interface files present. When you add parallelism +-- this makes @Uniques@ hopelessly random. +-- +-- As such, to get deterministic builds, the order of the allocated +-- @Uniques@ should not affect the final result. +-- see also wiki/deterministic-builds +-- +-- Note [Unique Determinism and code generation] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The goal of the deterministic builds (wiki/deterministic-builds, #4012) +-- is to get ABI compatible binaries given the same inputs and environment. +-- The motivation behind that is that if the ABI doesn't change the +-- binaries can be safely reused. +-- Note that this is weaker than bit-for-bit identical binaries and getting +-- bit-for-bit identical binaries is not a goal for now. +-- This means that we don't care about nondeterminism that happens after +-- the interface files are created, in particular we don't care about +-- register allocation and code generation. +-- To track progress on bit-for-bit determinism see #12262. + +eqUnique :: Unique -> Unique -> Bool +eqUnique (MkUnique u1) (MkUnique u2) = u1 == u2 + +ltUnique :: Unique -> Unique -> Bool +ltUnique (MkUnique u1) (MkUnique u2) = u1 < u2 + +-- Provided here to make it explicit at the call-site that it can +-- introduce non-determinism. +-- See Note [Unique Determinism] +-- See Note [No Ord for Unique] +nonDetCmpUnique :: Unique -> Unique -> Ordering +nonDetCmpUnique (MkUnique u1) (MkUnique u2) + = if u1 == u2 then EQ else if u1 < u2 then LT else GT + +{- +Note [No Ord for Unique] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +As explained in Note [Unique Determinism] the relative order of Uniques +is nondeterministic. To prevent from accidental use the Ord Unique +instance has been removed. +This makes it easier to maintain deterministic builds, but comes with some +drawbacks. +The biggest drawback is that Maps keyed by Uniques can't directly be used. +The alternatives are: + + 1) Use UniqFM or UniqDFM, see Note [Deterministic UniqFM] to decide which + 2) Create a newtype wrapper based on Unique ordering where nondeterminism + is controlled. See Module.ModuleEnv + 3) Change the algorithm to use nonDetCmpUnique and document why it's still + deterministic + 4) Use TrieMap as done in CmmCommonBlockElim.groupByLabel +-} + +instance Eq Unique where + a == b = eqUnique a b + a /= b = not (eqUnique a b) + +instance Uniquable Unique where + getUnique u = u + +-- We do sometimes make strings with @Uniques@ in them: + +showUnique :: Unique -> String +showUnique uniq + = case unpkUnique uniq of + (tag, u) -> finish_show tag u (iToBase62 u) + +finish_show :: Char -> Int -> String -> String +finish_show 't' u _pp_u | u < 26 + = -- Special case to make v common tyvars, t1, t2, ... + -- come out as a, b, ... (shorter, easier to read) + [chr (ord 'a' + u)] +finish_show tag _ pp_u = tag : pp_u + +pprUniqueAlways :: Unique -> SDoc +-- The "always" means regardless of -dsuppress-uniques +-- It replaces the old pprUnique to remind callers that +-- they should consider whether they want to consult +-- Opt_SuppressUniques +pprUniqueAlways u + = text (showUnique u) + +instance Outputable Unique where + ppr = pprUniqueAlways + +instance Show Unique where + show uniq = showUnique uniq + +{- +************************************************************************ +* * +\subsection[Utils-base62]{Base-62 numbers} +* * +************************************************************************ + +A character-stingy way to read/write numbers (notably Uniques). +The ``62-its'' are \tr{[0-9a-zA-Z]}. We don't handle negative Ints. +Code stolen from Lennart. +-} + +iToBase62 :: Int -> String +iToBase62 n_ + = ASSERT(n_ >= 0) go n_ "" + where + go n cs | n < 62 + = let !c = chooseChar62 n in c : cs + | otherwise + = go q (c : cs) where (!q, r) = quotRem n 62 + !c = chooseChar62 r + + chooseChar62 :: Int -> Char + {-# INLINE chooseChar62 #-} + chooseChar62 (I# n) = C# (indexCharOffAddr# chars62 n) + chars62 = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"# + +{- +************************************************************************ +* * +\subsection[Uniques-prelude]{@Uniques@ for wired-in Prelude things} +* * +************************************************************************ + +Allocation of unique supply characters: + v,t,u : for renumbering value-, type- and usage- vars. + B: builtin + C-E: pseudo uniques (used in native-code generator) + X: uniques derived by deriveUnique + _: unifiable tyvars (above) + 0-9: prelude things below + (no numbers left any more..) + :: (prelude) parallel array data constructors + + other a-z: lower case chars for unique supplies. Used so far: + + d desugarer + f AbsC flattener + g SimplStg + k constraint tuple tycons + m constraint tuple datacons + n Native codegen + r Hsc name cache + s simplifier + z anonymous sums +-} + +mkAlphaTyVarUnique :: Int -> Unique +mkPreludeClassUnique :: Int -> Unique +mkPreludeTyConUnique :: Int -> Unique +mkPreludeDataConUnique :: Arity -> Unique +mkPrimOpIdUnique :: Int -> Unique +mkPreludeMiscIdUnique :: Int -> Unique +mkCoVarUnique :: Int -> Unique + +mkAlphaTyVarUnique i = mkUnique '1' i +mkCoVarUnique i = mkUnique 'g' i +mkPreludeClassUnique i = mkUnique '2' i + +-------------------------------------------------- +-- Wired-in type constructor keys occupy *two* slots: +-- * u: the TyCon itself +-- * u+1: the TyConRepName of the TyCon +mkPreludeTyConUnique i = mkUnique '3' (2*i) + +tyConRepNameUnique :: Unique -> Unique +tyConRepNameUnique u = incrUnique u + +-- Data constructor keys occupy *two* slots. The first is used for the +-- data constructor itself and its wrapper function (the function that +-- evaluates arguments as necessary and calls the worker). The second is +-- used for the worker function (the function that builds the constructor +-- representation). + +-------------------------------------------------- +-- Wired-in data constructor keys occupy *three* slots: +-- * u: the DataCon itself +-- * u+1: its worker Id +-- * u+2: the TyConRepName of the promoted TyCon +-- Prelude data constructors are too simple to need wrappers. + +mkPreludeDataConUnique i = mkUnique '6' (3*i) -- Must be alphabetic + +-------------------------------------------------- +dataConTyRepNameUnique, dataConWorkerUnique :: Unique -> Unique +dataConWorkerUnique u = incrUnique u +dataConTyRepNameUnique u = stepUnique u 2 + +-------------------------------------------------- +mkPrimOpIdUnique op = mkUnique '9' op +mkPreludeMiscIdUnique i = mkUnique '0' i + +-- The "tyvar uniques" print specially nicely: a, b, c, etc. +-- See pprUnique for details + +initTyVarUnique :: Unique +initTyVarUnique = mkUnique 't' 0 + +mkPseudoUniqueD, mkPseudoUniqueE, mkPseudoUniqueH, + mkBuiltinUnique :: Int -> Unique + +mkBuiltinUnique i = mkUnique 'B' i +mkPseudoUniqueD i = mkUnique 'D' i -- used in NCG for getUnique on RealRegs +mkPseudoUniqueE i = mkUnique 'E' i -- used in NCG spiller to create spill VirtualRegs +mkPseudoUniqueH i = mkUnique 'H' i -- used in NCG spiller to create spill VirtualRegs + +mkRegSingleUnique, mkRegPairUnique, mkRegSubUnique, mkRegClassUnique :: Int -> Unique +mkRegSingleUnique = mkUnique 'R' +mkRegSubUnique = mkUnique 'S' +mkRegPairUnique = mkUnique 'P' +mkRegClassUnique = mkUnique 'L' + +mkCostCentreUnique :: Int -> Unique +mkCostCentreUnique = mkUnique 'C' + +mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique :: FastString -> Unique +-- See Note [The Unique of an OccName] in OccName +mkVarOccUnique fs = mkUnique 'i' (uniqueOfFS fs) +mkDataOccUnique fs = mkUnique 'd' (uniqueOfFS fs) +mkTvOccUnique fs = mkUnique 'v' (uniqueOfFS fs) +mkTcOccUnique fs = mkUnique 'c' (uniqueOfFS fs) + +initExitJoinUnique :: Unique +initExitJoinUnique = mkUnique 's' 0 diff --git a/compiler/basicTypes/Var.hs b/compiler/basicTypes/Var.hs new file mode 100644 --- /dev/null +++ b/compiler/basicTypes/Var.hs @@ -0,0 +1,755 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section{@Vars@: Variables} +-} + +{-# LANGUAGE CPP, FlexibleContexts, MultiWayIf, FlexibleInstances, DeriveDataTypeable #-} + +-- | +-- #name_types# +-- GHC uses several kinds of name internally: +-- +-- * 'OccName.OccName': see "OccName#name_types" +-- +-- * 'RdrName.RdrName': see "RdrName#name_types" +-- +-- * 'Name.Name': see "Name#name_types" +-- +-- * 'Id.Id': see "Id#name_types" +-- +-- * 'Var.Var' is a synonym for the 'Id.Id' type but it may additionally +-- potentially contain type variables, which have a 'TyCoRep.Kind' +-- rather than a 'TyCoRep.Type' and only contain some extra +-- details during typechecking. +-- +-- These 'Var.Var' names may either be global or local, see "Var#globalvslocal" +-- +-- #globalvslocal# +-- Global 'Id's and 'Var's are those that are imported or correspond +-- to a data constructor, primitive operation, or record selectors. +-- Local 'Id's and 'Var's are those bound within an expression +-- (e.g. by a lambda) or at the top level of the module being compiled. + +module Var ( + -- * The main data type and synonyms + Var, CoVar, Id, NcId, DictId, DFunId, EvVar, EqVar, EvId, IpId, JoinId, + TyVar, TcTyVar, TypeVar, KindVar, TKVar, TyCoVar, + + -- * In and Out variants + InVar, InCoVar, InId, InTyVar, + OutVar, OutCoVar, OutId, OutTyVar, + + -- ** Taking 'Var's apart + varName, varUnique, varType, + + -- ** Modifying 'Var's + setVarName, setVarUnique, setVarType, updateVarType, + updateVarTypeM, + + -- ** Constructing, taking apart, modifying 'Id's + mkGlobalVar, mkLocalVar, mkExportedLocalVar, mkCoVar, + idInfo, idDetails, + lazySetIdInfo, setIdDetails, globaliseId, + setIdExported, setIdNotExported, + + -- ** Predicates + isId, isTyVar, isTcTyVar, + isLocalVar, isLocalId, isCoVar, isNonCoVarId, isTyCoVar, + isGlobalId, isExportedId, + mustHaveLocalBinding, + + -- * ArgFlags + ArgFlag(..), isVisibleArgFlag, isInvisibleArgFlag, sameVis, + AnonArgFlag(..), ForallVisFlag(..), argToForallVisFlag, + + -- * TyVar's + VarBndr(..), TyCoVarBinder, TyVarBinder, + binderVar, binderVars, binderArgFlag, binderType, + mkTyCoVarBinder, mkTyCoVarBinders, + mkTyVarBinder, mkTyVarBinders, + isTyVarBinder, + + -- ** Constructing TyVar's + mkTyVar, mkTcTyVar, + + -- ** Taking 'TyVar's apart + tyVarName, tyVarKind, tcTyVarDetails, setTcTyVarDetails, + + -- ** Modifying 'TyVar's + setTyVarName, setTyVarUnique, setTyVarKind, updateTyVarKind, + updateTyVarKindM, + + nonDetCmpVar + + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import {-# SOURCE #-} TyCoRep( Type, Kind, pprKind ) +import {-# SOURCE #-} TcType( TcTyVarDetails, pprTcTyVarDetails, vanillaSkolemTv ) +import {-# SOURCE #-} IdInfo( IdDetails, IdInfo, coVarDetails, isCoVarDetails, + vanillaIdInfo, pprIdDetails ) + +import Name hiding (varName) +import Unique ( Uniquable, Unique, getKey, getUnique + , mkUniqueGrimily, nonDetCmpUnique ) +import Util +import Binary +import DynFlags +import Outputable + +import Data.Data + +{- +************************************************************************ +* * + Synonyms +* * +************************************************************************ +-- These synonyms are here and not in Id because otherwise we need a very +-- large number of SOURCE imports of Id.hs :-( +-} + +-- | Identifier +type Id = Var -- A term-level identifier + -- predicate: isId + +-- | Coercion Variable +type CoVar = Id -- See Note [Evidence: EvIds and CoVars] + -- predicate: isCoVar + +-- | +type NcId = Id -- A term-level (value) variable that is + -- /not/ an (unlifted) coercion + -- predicate: isNonCoVarId + +-- | Type or kind Variable +type TyVar = Var -- Type *or* kind variable (historical) + +-- | Type or Kind Variable +type TKVar = Var -- Type *or* kind variable (historical) + +-- | Type variable that might be a metavariable +type TcTyVar = Var + +-- | Type Variable +type TypeVar = Var -- Definitely a type variable + +-- | Kind Variable +type KindVar = Var -- Definitely a kind variable + -- See Note [Kind and type variables] + +-- See Note [Evidence: EvIds and CoVars] +-- | Evidence Identifier +type EvId = Id -- Term-level evidence: DictId, IpId, or EqVar + +-- | Evidence Variable +type EvVar = EvId -- ...historical name for EvId + +-- | Dictionary Function Identifier +type DFunId = Id -- A dictionary function + +-- | Dictionary Identifier +type DictId = EvId -- A dictionary variable + +-- | Implicit parameter Identifier +type IpId = EvId -- A term-level implicit parameter + +-- | Equality Variable +type EqVar = EvId -- Boxed equality evidence +type JoinId = Id -- A join variable + +-- | Type or Coercion Variable +type TyCoVar = Id -- Type, *or* coercion variable + -- predicate: isTyCoVar + + +{- Many passes apply a substitution, and it's very handy to have type + synonyms to remind us whether or not the substitution has been applied -} + +type InVar = Var +type InTyVar = TyVar +type InCoVar = CoVar +type InId = Id +type OutVar = Var +type OutTyVar = TyVar +type OutCoVar = CoVar +type OutId = Id + + + +{- Note [Evidence: EvIds and CoVars] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* An EvId (evidence Id) is a term-level evidence variable + (dictionary, implicit parameter, or equality). Could be boxed or unboxed. + +* DictId, IpId, and EqVar are synonyms when we know what kind of + evidence we are talking about. For example, an EqVar has type (t1 ~ t2). + +* A CoVar is always an un-lifted coercion, of type (t1 ~# t2) or (t1 ~R# t2) + +Note [Kind and type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Before kind polymorphism, TyVar were used to mean type variables. Now +they are used to mean kind *or* type variables. KindVar is used when we +know for sure that it is a kind variable. In future, we might want to +go over the whole compiler code to use: + - TKVar to mean kind or type variables + - TypeVar to mean type variables only + - KindVar to mean kind variables + + +************************************************************************ +* * +\subsection{The main data type declarations} +* * +************************************************************************ + + +Every @Var@ has a @Unique@, to uniquify it and for fast comparison, a +@Type@, and an @IdInfo@ (non-essential info about it, e.g., +strictness). The essential info about different kinds of @Vars@ is +in its @VarDetails@. +-} + +-- | Variable +-- +-- Essentially a typed 'Name', that may also contain some additional information +-- about the 'Var' and its use sites. +data Var + = TyVar { -- Type and kind variables + -- see Note [Kind and type variables] + varName :: !Name, + realUnique :: {-# UNPACK #-} !Int, + -- ^ Key for fast comparison + -- Identical to the Unique in the name, + -- cached here for speed + varType :: Kind -- ^ The type or kind of the 'Var' in question + } + + | TcTyVar { -- Used only during type inference + -- Used for kind variables during + -- inference, as well + varName :: !Name, + realUnique :: {-# UNPACK #-} !Int, + varType :: Kind, + tc_tv_details :: TcTyVarDetails + } + + | Id { + varName :: !Name, + realUnique :: {-# UNPACK #-} !Int, + varType :: Type, + idScope :: IdScope, + id_details :: IdDetails, -- Stable, doesn't change + id_info :: IdInfo } -- Unstable, updated by simplifier + +-- | Identifier Scope +data IdScope -- See Note [GlobalId/LocalId] + = GlobalId + | LocalId ExportFlag + +data ExportFlag -- See Note [ExportFlag on binders] + = NotExported -- ^ Not exported: may be discarded as dead code. + | Exported -- ^ Exported: kept alive + +{- Note [ExportFlag on binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An ExportFlag of "Exported" on a top-level binder says "keep this +binding alive; do not drop it as dead code". This transitively +keeps alive all the other top-level bindings that this binding refers +to. This property is persisted all the way down the pipeline, so that +the binding will be compiled all the way to object code, and its +symbols will appear in the linker symbol table. + +However, note that this use of "exported" is quite different to the +export list on a Haskell module. Setting the ExportFlag on an Id does +/not/ mean that if you import the module (in Haskell source code) you +will see this Id. Of course, things that appear in the export list +of the source Haskell module do indeed have their ExportFlag set. +But many other things, such as dictionary functions, are kept alive +by having their ExportFlag set, even though they are not exported +in the source-code sense. + +We should probably use a different term for ExportFlag, like +KeepAlive. + +Note [GlobalId/LocalId] +~~~~~~~~~~~~~~~~~~~~~~~ +A GlobalId is + * always a constant (top-level) + * imported, or data constructor, or primop, or record selector + * has a Unique that is globally unique across the whole + GHC invocation (a single invocation may compile multiple modules) + * never treated as a candidate by the free-variable finder; + it's a constant! + +A LocalId is + * bound within an expression (lambda, case, local let(rec)) + * or defined at top level in the module being compiled + * always treated as a candidate by the free-variable finder + +After CoreTidy, top-level LocalIds are turned into GlobalIds +-} + +instance Outputable Var where + ppr var = sdocWithDynFlags $ \dflags -> + getPprStyle $ \ppr_style -> + if | debugStyle ppr_style && (not (gopt Opt_SuppressVarKinds dflags)) + -> parens (ppr (varName var) <+> ppr_debug var ppr_style <+> + dcolon <+> pprKind (tyVarKind var)) + | otherwise + -> ppr (varName var) <> ppr_debug var ppr_style + +ppr_debug :: Var -> PprStyle -> SDoc +ppr_debug (TyVar {}) sty + | debugStyle sty = brackets (text "tv") +ppr_debug (TcTyVar {tc_tv_details = d}) sty + | dumpStyle sty || debugStyle sty = brackets (pprTcTyVarDetails d) +ppr_debug (Id { idScope = s, id_details = d }) sty + | debugStyle sty = brackets (ppr_id_scope s <> pprIdDetails d) +ppr_debug _ _ = empty + +ppr_id_scope :: IdScope -> SDoc +ppr_id_scope GlobalId = text "gid" +ppr_id_scope (LocalId Exported) = text "lidx" +ppr_id_scope (LocalId NotExported) = text "lid" + +instance NamedThing Var where + getName = varName + +instance Uniquable Var where + getUnique = varUnique + +instance Eq Var where + a == b = realUnique a == realUnique b + +instance Ord Var where + a <= b = realUnique a <= realUnique b + a < b = realUnique a < realUnique b + a >= b = realUnique a >= realUnique b + a > b = realUnique a > realUnique b + a `compare` b = a `nonDetCmpVar` b + +-- | Compare Vars by their Uniques. +-- This is what Ord Var does, provided here to make it explicit at the +-- call-site that it can introduce non-determinism. +-- See Note [Unique Determinism] +nonDetCmpVar :: Var -> Var -> Ordering +nonDetCmpVar a b = varUnique a `nonDetCmpUnique` varUnique b + +instance Data Var where + -- don't traverse? + toConstr _ = abstractConstr "Var" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "Var" + +instance HasOccName Var where + occName = nameOccName . varName + +varUnique :: Var -> Unique +varUnique var = mkUniqueGrimily (realUnique var) + +setVarUnique :: Var -> Unique -> Var +setVarUnique var uniq + = var { realUnique = getKey uniq, + varName = setNameUnique (varName var) uniq } + +setVarName :: Var -> Name -> Var +setVarName var new_name + = var { realUnique = getKey (getUnique new_name), + varName = new_name } + +setVarType :: Id -> Type -> Id +setVarType id ty = id { varType = ty } + +updateVarType :: (Type -> Type) -> Id -> Id +updateVarType f id = id { varType = f (varType id) } + +updateVarTypeM :: Monad m => (Type -> m Type) -> Id -> m Id +updateVarTypeM f id = do { ty' <- f (varType id) + ; return (id { varType = ty' }) } + +{- ********************************************************************* +* * +* ArgFlag +* * +********************************************************************* -} + +-- | Argument Flag +-- +-- Is something required to appear in source Haskell ('Required'), +-- permitted by request ('Specified') (visible type application), or +-- prohibited entirely from appearing in source Haskell ('Inferred')? +-- See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep +data ArgFlag = Inferred | Specified | Required + deriving (Eq, Ord, Data) + -- (<) on ArgFlag means "is less visible than" + +-- | Does this 'ArgFlag' classify an argument that is written in Haskell? +isVisibleArgFlag :: ArgFlag -> Bool +isVisibleArgFlag Required = True +isVisibleArgFlag _ = False + +-- | Does this 'ArgFlag' classify an argument that is not written in Haskell? +isInvisibleArgFlag :: ArgFlag -> Bool +isInvisibleArgFlag = not . isVisibleArgFlag + +-- | Do these denote the same level of visibility? 'Required' +-- arguments are visible, others are not. So this function +-- equates 'Specified' and 'Inferred'. Used for printing. +sameVis :: ArgFlag -> ArgFlag -> Bool +sameVis Required Required = True +sameVis Required _ = False +sameVis _ Required = False +sameVis _ _ = True + +instance Outputable ArgFlag where + ppr Required = text "[req]" + ppr Specified = text "[spec]" + ppr Inferred = text "[infrd]" + +instance Binary ArgFlag where + put_ bh Required = putByte bh 0 + put_ bh Specified = putByte bh 1 + put_ bh Inferred = putByte bh 2 + + get bh = do + h <- getByte bh + case h of + 0 -> return Required + 1 -> return Specified + _ -> return Inferred + +-- | The non-dependent version of 'ArgFlag'. + +-- Appears here partly so that it's together with its friend ArgFlag, +-- but also because it is used in IfaceType, rather early in the +-- compilation chain +-- See Note [AnonArgFlag vs. ForallVisFlag] +data AnonArgFlag + = VisArg -- ^ Used for @(->)@: an ordinary non-dependent arrow. + -- The argument is visible in source code. + | InvisArg -- ^ Used for @(=>)@: a non-dependent predicate arrow. + -- The argument is invisible in source code. + deriving (Eq, Ord, Data) + +instance Outputable AnonArgFlag where + ppr VisArg = text "[vis]" + ppr InvisArg = text "[invis]" + +instance Binary AnonArgFlag where + put_ bh VisArg = putByte bh 0 + put_ bh InvisArg = putByte bh 1 + + get bh = do + h <- getByte bh + case h of + 0 -> return VisArg + _ -> return InvisArg + +-- | Is a @forall@ invisible (e.g., @forall a b. {...}@, with a dot) or visible +-- (e.g., @forall a b -> {...}@, with an arrow)? + +-- See Note [AnonArgFlag vs. ForallVisFlag] +data ForallVisFlag + = ForallVis -- ^ A visible @forall@ (with an arrow) + | ForallInvis -- ^ An invisible @forall@ (with a dot) + deriving (Eq, Ord, Data) + +instance Outputable ForallVisFlag where + ppr f = text $ case f of + ForallVis -> "ForallVis" + ForallInvis -> "ForallInvis" + +-- | Convert an 'ArgFlag' to its corresponding 'ForallVisFlag'. +argToForallVisFlag :: ArgFlag -> ForallVisFlag +argToForallVisFlag Required = ForallVis +argToForallVisFlag Specified = ForallInvis +argToForallVisFlag Inferred = ForallInvis + +{- +Note [AnonArgFlag vs. ForallVisFlag] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The AnonArgFlag and ForallVisFlag data types are quite similar at a first +glance: + + data AnonArgFlag = VisArg | InvisArg + data ForallVisFlag = ForallVis | ForallInvis + +Both data types keep track of visibility of some sort. AnonArgFlag tracks +whether a FunTy has a visible argument (->) or an invisible predicate argument +(=>). ForallVisFlag tracks whether a `forall` quantifier is visible +(forall a -> {...}) or invisible (forall a. {...}). + +Given their similarities, it's tempting to want to combine these two data types +into one, but they actually represent distinct concepts. AnonArgFlag reflects a +property of *Core* types, whereas ForallVisFlag reflects a property of the GHC +AST. In other words, AnonArgFlag is all about internals, whereas ForallVisFlag +is all about surface syntax. Therefore, they are kept as separate data types. +-} + +{- ********************************************************************* +* * +* VarBndr, TyCoVarBinder +* * +********************************************************************* -} + +-- Variable Binder +-- +-- VarBndr is polymorphic in both var and visibility fields. +-- Currently there are six different uses of 'VarBndr': +-- * Var.TyVarBinder = VarBndr TyVar ArgFlag +-- * Var.TyCoVarBinder = VarBndr TyCoVar ArgFlag +-- * TyCon.TyConBinder = VarBndr TyVar TyConBndrVis +-- * TyCon.TyConTyCoBinder = VarBndr TyCoVar TyConBndrVis +-- * IfaceType.IfaceForAllBndr = VarBndr IfaceBndr ArgFlag +-- * IfaceType.IfaceTyConBinder = VarBndr IfaceBndr TyConBndrVis +data VarBndr var argf = Bndr var argf + deriving( Data ) + +-- | Variable Binder +-- +-- A 'TyCoVarBinder' is the binder of a ForAllTy +-- It's convenient to define this synonym here rather its natural +-- home in TyCoRep, because it's used in DataCon.hs-boot +-- +-- A 'TyVarBinder' is a binder with only TyVar +type TyCoVarBinder = VarBndr TyCoVar ArgFlag +type TyVarBinder = VarBndr TyVar ArgFlag + +binderVar :: VarBndr tv argf -> tv +binderVar (Bndr v _) = v + +binderVars :: [VarBndr tv argf] -> [tv] +binderVars tvbs = map binderVar tvbs + +binderArgFlag :: VarBndr tv argf -> argf +binderArgFlag (Bndr _ argf) = argf + +binderType :: VarBndr TyCoVar argf -> Type +binderType (Bndr tv _) = varType tv + +-- | Make a named binder +mkTyCoVarBinder :: ArgFlag -> TyCoVar -> TyCoVarBinder +mkTyCoVarBinder vis var = Bndr var vis + +-- | Make a named binder +-- 'var' should be a type variable +mkTyVarBinder :: ArgFlag -> TyVar -> TyVarBinder +mkTyVarBinder vis var + = ASSERT( isTyVar var ) + Bndr var vis + +-- | Make many named binders +mkTyCoVarBinders :: ArgFlag -> [TyCoVar] -> [TyCoVarBinder] +mkTyCoVarBinders vis = map (mkTyCoVarBinder vis) + +-- | Make many named binders +-- Input vars should be type variables +mkTyVarBinders :: ArgFlag -> [TyVar] -> [TyVarBinder] +mkTyVarBinders vis = map (mkTyVarBinder vis) + +isTyVarBinder :: TyCoVarBinder -> Bool +isTyVarBinder (Bndr v _) = isTyVar v + +instance Outputable tv => Outputable (VarBndr tv ArgFlag) where + ppr (Bndr v Required) = ppr v + ppr (Bndr v Specified) = char '@' <> ppr v + ppr (Bndr v Inferred) = braces (ppr v) + +instance (Binary tv, Binary vis) => Binary (VarBndr tv vis) where + put_ bh (Bndr tv vis) = do { put_ bh tv; put_ bh vis } + + get bh = do { tv <- get bh; vis <- get bh; return (Bndr tv vis) } + +instance NamedThing tv => NamedThing (VarBndr tv flag) where + getName (Bndr tv _) = getName tv + +{- +************************************************************************ +* * +* Type and kind variables * +* * +************************************************************************ +-} + +tyVarName :: TyVar -> Name +tyVarName = varName + +tyVarKind :: TyVar -> Kind +tyVarKind = varType + +setTyVarUnique :: TyVar -> Unique -> TyVar +setTyVarUnique = setVarUnique + +setTyVarName :: TyVar -> Name -> TyVar +setTyVarName = setVarName + +setTyVarKind :: TyVar -> Kind -> TyVar +setTyVarKind tv k = tv {varType = k} + +updateTyVarKind :: (Kind -> Kind) -> TyVar -> TyVar +updateTyVarKind update tv = tv {varType = update (tyVarKind tv)} + +updateTyVarKindM :: (Monad m) => (Kind -> m Kind) -> TyVar -> m TyVar +updateTyVarKindM update tv + = do { k' <- update (tyVarKind tv) + ; return $ tv {varType = k'} } + +mkTyVar :: Name -> Kind -> TyVar +mkTyVar name kind = TyVar { varName = name + , realUnique = getKey (nameUnique name) + , varType = kind + } + +mkTcTyVar :: Name -> Kind -> TcTyVarDetails -> TyVar +mkTcTyVar name kind details + = -- NB: 'kind' may be a coercion kind; cf, 'TcMType.newMetaCoVar' + TcTyVar { varName = name, + realUnique = getKey (nameUnique name), + varType = kind, + tc_tv_details = details + } + +tcTyVarDetails :: TyVar -> TcTyVarDetails +-- See Note [TcTyVars in the typechecker] in TcType +tcTyVarDetails (TcTyVar { tc_tv_details = details }) = details +tcTyVarDetails (TyVar {}) = vanillaSkolemTv +tcTyVarDetails var = pprPanic "tcTyVarDetails" (ppr var <+> dcolon <+> pprKind (tyVarKind var)) + +setTcTyVarDetails :: TyVar -> TcTyVarDetails -> TyVar +setTcTyVarDetails tv details = tv { tc_tv_details = details } + +{- +%************************************************************************ +%* * +\subsection{Ids} +* * +************************************************************************ +-} + +idInfo :: HasDebugCallStack => Id -> IdInfo +idInfo (Id { id_info = info }) = info +idInfo other = pprPanic "idInfo" (ppr other) + +idDetails :: Id -> IdDetails +idDetails (Id { id_details = details }) = details +idDetails other = pprPanic "idDetails" (ppr other) + +-- The next three have a 'Var' suffix even though they always build +-- Ids, because Id.hs uses 'mkGlobalId' etc with different types +mkGlobalVar :: IdDetails -> Name -> Type -> IdInfo -> Id +mkGlobalVar details name ty info + = mk_id name ty GlobalId details info + +mkLocalVar :: IdDetails -> Name -> Type -> IdInfo -> Id +mkLocalVar details name ty info + = mk_id name ty (LocalId NotExported) details info + +mkCoVar :: Name -> Type -> CoVar +-- Coercion variables have no IdInfo +mkCoVar name ty = mk_id name ty (LocalId NotExported) coVarDetails vanillaIdInfo + +-- | Exported 'Var's will not be removed as dead code +mkExportedLocalVar :: IdDetails -> Name -> Type -> IdInfo -> Id +mkExportedLocalVar details name ty info + = mk_id name ty (LocalId Exported) details info + +mk_id :: Name -> Type -> IdScope -> IdDetails -> IdInfo -> Id +mk_id name ty scope details info + = Id { varName = name, + realUnique = getKey (nameUnique name), + varType = ty, + idScope = scope, + id_details = details, + id_info = info } + +------------------- +lazySetIdInfo :: Id -> IdInfo -> Var +lazySetIdInfo id info = id { id_info = info } + +setIdDetails :: Id -> IdDetails -> Id +setIdDetails id details = id { id_details = details } + +globaliseId :: Id -> Id +-- ^ If it's a local, make it global +globaliseId id = id { idScope = GlobalId } + +setIdExported :: Id -> Id +-- ^ Exports the given local 'Id'. Can also be called on global 'Id's, such as data constructors +-- and class operations, which are born as global 'Id's and automatically exported +setIdExported id@(Id { idScope = LocalId {} }) = id { idScope = LocalId Exported } +setIdExported id@(Id { idScope = GlobalId }) = id +setIdExported tv = pprPanic "setIdExported" (ppr tv) + +setIdNotExported :: Id -> Id +-- ^ We can only do this to LocalIds +setIdNotExported id = ASSERT( isLocalId id ) + id { idScope = LocalId NotExported } + +{- +************************************************************************ +* * +\subsection{Predicates over variables} +* * +************************************************************************ +-} + +isTyVar :: Var -> Bool -- True of both TyVar and TcTyVar +isTyVar (TyVar {}) = True +isTyVar (TcTyVar {}) = True +isTyVar _ = False + +isTcTyVar :: Var -> Bool -- True of TcTyVar only +isTcTyVar (TcTyVar {}) = True +isTcTyVar _ = False + +isTyCoVar :: Var -> Bool +isTyCoVar v = isTyVar v || isCoVar v + +isId :: Var -> Bool +isId (Id {}) = True +isId _ = False + +isCoVar :: Var -> Bool +-- A coercion variable +isCoVar (Id { id_details = details }) = isCoVarDetails details +isCoVar _ = False + +isNonCoVarId :: Var -> Bool +-- A term variable (Id) that is /not/ a coercion variable +isNonCoVarId (Id { id_details = details }) = not (isCoVarDetails details) +isNonCoVarId _ = False + +isLocalId :: Var -> Bool +isLocalId (Id { idScope = LocalId _ }) = True +isLocalId _ = False + +-- | 'isLocalVar' returns @True@ for type variables as well as local 'Id's +-- These are the variables that we need to pay attention to when finding free +-- variables, or doing dependency analysis. +isLocalVar :: Var -> Bool +isLocalVar v = not (isGlobalId v) + +isGlobalId :: Var -> Bool +isGlobalId (Id { idScope = GlobalId }) = True +isGlobalId _ = False + +-- | 'mustHaveLocalBinding' returns @True@ of 'Id's and 'TyVar's +-- that must have a binding in this module. The converse +-- is not quite right: there are some global 'Id's that must have +-- bindings, such as record selectors. But that doesn't matter, +-- because it's only used for assertions +mustHaveLocalBinding :: Var -> Bool +mustHaveLocalBinding var = isLocalVar var + +-- | 'isExportedIdVar' means \"don't throw this away\" +isExportedId :: Var -> Bool +isExportedId (Id { idScope = GlobalId }) = True +isExportedId (Id { idScope = LocalId Exported}) = True +isExportedId _ = False diff --git a/compiler/basicTypes/Var.hs-boot b/compiler/basicTypes/Var.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/basicTypes/Var.hs-boot @@ -0,0 +1,15 @@ +-- Var.hs-boot is Imported (only) by TyCoRep.hs-boot +module Var where + +import GhcPrelude () + -- We compile this module with -XNoImplicitPrelude (for some + -- reason), so if there are no imports it does not seem to + -- depend on anything. But it does! We must, for example, + -- compile GHC.Types in the ghc-prim library first. + -- So this otherwise-unnecessary import tells the build system + -- that this module depends on GhcPrelude, which ensures + -- that GHC.Type is built first. + +data ArgFlag +data AnonArgFlag +data Var diff --git a/compiler/basicTypes/VarEnv.hs b/compiler/basicTypes/VarEnv.hs new file mode 100644 --- /dev/null +++ b/compiler/basicTypes/VarEnv.hs @@ -0,0 +1,606 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +module VarEnv ( + -- * Var, Id and TyVar environments (maps) + VarEnv, IdEnv, TyVarEnv, CoVarEnv, TyCoVarEnv, + + -- ** Manipulating these environments + emptyVarEnv, unitVarEnv, mkVarEnv, mkVarEnv_Directly, + elemVarEnv, disjointVarEnv, + extendVarEnv, extendVarEnv_C, extendVarEnv_Acc, extendVarEnv_Directly, + extendVarEnvList, + plusVarEnv, plusVarEnv_C, plusVarEnv_CD, plusMaybeVarEnv_C, + plusVarEnvList, alterVarEnv, + delVarEnvList, delVarEnv, delVarEnv_Directly, + minusVarEnv, intersectsVarEnv, + lookupVarEnv, lookupVarEnv_NF, lookupWithDefaultVarEnv, + mapVarEnv, zipVarEnv, + modifyVarEnv, modifyVarEnv_Directly, + isEmptyVarEnv, + elemVarEnvByKey, lookupVarEnv_Directly, + filterVarEnv, filterVarEnv_Directly, restrictVarEnv, + partitionVarEnv, + + -- * Deterministic Var environments (maps) + DVarEnv, DIdEnv, DTyVarEnv, + + -- ** Manipulating these environments + emptyDVarEnv, mkDVarEnv, + dVarEnvElts, + extendDVarEnv, extendDVarEnv_C, + extendDVarEnvList, + lookupDVarEnv, elemDVarEnv, + isEmptyDVarEnv, foldDVarEnv, + mapDVarEnv, filterDVarEnv, + modifyDVarEnv, + alterDVarEnv, + plusDVarEnv, plusDVarEnv_C, + unitDVarEnv, + delDVarEnv, + delDVarEnvList, + minusDVarEnv, + partitionDVarEnv, + anyDVarEnv, + + -- * The InScopeSet type + InScopeSet, + + -- ** Operations on InScopeSets + emptyInScopeSet, mkInScopeSet, delInScopeSet, + extendInScopeSet, extendInScopeSetList, extendInScopeSetSet, + getInScopeVars, lookupInScope, lookupInScope_Directly, + unionInScope, elemInScopeSet, uniqAway, + varSetInScope, + + -- * The RnEnv2 type + RnEnv2, + + -- ** Operations on RnEnv2s + mkRnEnv2, rnBndr2, rnBndrs2, rnBndr2_var, + rnOccL, rnOccR, inRnEnvL, inRnEnvR, rnOccL_maybe, rnOccR_maybe, + rnBndrL, rnBndrR, nukeRnEnvL, nukeRnEnvR, rnSwap, + delBndrL, delBndrR, delBndrsL, delBndrsR, + addRnInScopeSet, + rnEtaL, rnEtaR, + rnInScope, rnInScopeSet, lookupRnInScope, + rnEnvL, rnEnvR, + + -- * TidyEnv and its operation + TidyEnv, + emptyTidyEnv, mkEmptyTidyEnv + ) where + +import GhcPrelude + +import OccName +import Var +import VarSet +import UniqSet +import UniqFM +import UniqDFM +import Unique +import Util +import Maybes +import Outputable + +{- +************************************************************************ +* * + In-scope sets +* * +************************************************************************ +-} + +-- | A set of variables that are in scope at some point +-- "Secrets of the Glasgow Haskell Compiler inliner" Section 3.2 provides +-- the motivation for this abstraction. +data InScopeSet = InScope VarSet {-# UNPACK #-} !Int + -- We store a VarSet here, but we use this for lookups rather than + -- just membership tests. Typically the InScopeSet contains the + -- canonical version of the variable (e.g. with an informative + -- unfolding), so this lookup is useful. + -- + -- The Int is a kind of hash-value used by uniqAway + -- For example, it might be the size of the set + -- INVARIANT: it's not zero; we use it as a multiplier in uniqAway + +instance Outputable InScopeSet where + ppr (InScope s _) = + text "InScope" <+> + braces (fsep (map (ppr . Var.varName) (nonDetEltsUniqSet s))) + -- It's OK to use nonDetEltsUniqSet here because it's + -- only for pretty printing + -- In-scope sets get big, and with -dppr-debug + -- the output is overwhelming + +emptyInScopeSet :: InScopeSet +emptyInScopeSet = InScope emptyVarSet 1 + +getInScopeVars :: InScopeSet -> VarSet +getInScopeVars (InScope vs _) = vs + +mkInScopeSet :: VarSet -> InScopeSet +mkInScopeSet in_scope = InScope in_scope 1 + +extendInScopeSet :: InScopeSet -> Var -> InScopeSet +extendInScopeSet (InScope in_scope n) v + = InScope (extendVarSet in_scope v) (n + 1) + +extendInScopeSetList :: InScopeSet -> [Var] -> InScopeSet +extendInScopeSetList (InScope in_scope n) vs + = InScope (foldl' (\s v -> extendVarSet s v) in_scope vs) + (n + length vs) + +extendInScopeSetSet :: InScopeSet -> VarSet -> InScopeSet +extendInScopeSetSet (InScope in_scope n) vs + = InScope (in_scope `unionVarSet` vs) (n + sizeUniqSet vs) + +delInScopeSet :: InScopeSet -> Var -> InScopeSet +delInScopeSet (InScope in_scope n) v = InScope (in_scope `delVarSet` v) n + +elemInScopeSet :: Var -> InScopeSet -> Bool +elemInScopeSet v (InScope in_scope _) = v `elemVarSet` in_scope + +-- | Look up a variable the 'InScopeSet'. This lets you map from +-- the variable's identity (unique) to its full value. +lookupInScope :: InScopeSet -> Var -> Maybe Var +lookupInScope (InScope in_scope _) v = lookupVarSet in_scope v + +lookupInScope_Directly :: InScopeSet -> Unique -> Maybe Var +lookupInScope_Directly (InScope in_scope _) uniq + = lookupVarSet_Directly in_scope uniq + +unionInScope :: InScopeSet -> InScopeSet -> InScopeSet +unionInScope (InScope s1 _) (InScope s2 n2) + = InScope (s1 `unionVarSet` s2) n2 + +varSetInScope :: VarSet -> InScopeSet -> Bool +varSetInScope vars (InScope s1 _) = vars `subVarSet` s1 + +-- | @uniqAway in_scope v@ finds a unique that is not used in the +-- in-scope set, and gives that to v. +uniqAway :: InScopeSet -> Var -> Var +-- It starts with v's current unique, of course, in the hope that it won't +-- have to change, and thereafter uses a combination of that and the hash-code +-- found in the in-scope set +uniqAway in_scope var + | var `elemInScopeSet` in_scope = uniqAway' in_scope var -- Make a new one + | otherwise = var -- Nothing to do + +uniqAway' :: InScopeSet -> Var -> Var +-- This one *always* makes up a new variable +uniqAway' (InScope set n) var + = try 1 + where + orig_unique = getUnique var + try k + | debugIsOn && (k > 1000) + = pprPanic "uniqAway loop:" msg + | uniq `elemVarSetByKey` set = try (k + 1) + | k > 3 + = pprTraceDebug "uniqAway:" msg + setVarUnique var uniq + | otherwise = setVarUnique var uniq + where + msg = ppr k <+> text "tries" <+> ppr var <+> int n + uniq = deriveUnique orig_unique (n * k) + +{- +************************************************************************ +* * + Dual renaming +* * +************************************************************************ +-} + +-- | Rename Environment 2 +-- +-- When we are comparing (or matching) types or terms, we are faced with +-- \"going under\" corresponding binders. E.g. when comparing: +-- +-- > \x. e1 ~ \y. e2 +-- +-- Basically we want to rename [@x@ -> @y@] or [@y@ -> @x@], but there are lots of +-- things we must be careful of. In particular, @x@ might be free in @e2@, or +-- y in @e1@. So the idea is that we come up with a fresh binder that is free +-- in neither, and rename @x@ and @y@ respectively. That means we must maintain: +-- +-- 1. A renaming for the left-hand expression +-- +-- 2. A renaming for the right-hand expressions +-- +-- 3. An in-scope set +-- +-- Furthermore, when matching, we want to be able to have an 'occurs check', +-- to prevent: +-- +-- > \x. f ~ \y. y +-- +-- matching with [@f@ -> @y@]. So for each expression we want to know that set of +-- locally-bound variables. That is precisely the domain of the mappings 1. +-- and 2., but we must ensure that we always extend the mappings as we go in. +-- +-- All of this information is bundled up in the 'RnEnv2' +data RnEnv2 + = RV2 { envL :: VarEnv Var -- Renaming for Left term + , envR :: VarEnv Var -- Renaming for Right term + , in_scope :: InScopeSet } -- In scope in left or right terms + +-- The renamings envL and envR are *guaranteed* to contain a binding +-- for every variable bound as we go into the term, even if it is not +-- renamed. That way we can ask what variables are locally bound +-- (inRnEnvL, inRnEnvR) + +mkRnEnv2 :: InScopeSet -> RnEnv2 +mkRnEnv2 vars = RV2 { envL = emptyVarEnv + , envR = emptyVarEnv + , in_scope = vars } + +addRnInScopeSet :: RnEnv2 -> VarSet -> RnEnv2 +addRnInScopeSet env vs + | isEmptyVarSet vs = env + | otherwise = env { in_scope = extendInScopeSetSet (in_scope env) vs } + +rnInScope :: Var -> RnEnv2 -> Bool +rnInScope x env = x `elemInScopeSet` in_scope env + +rnInScopeSet :: RnEnv2 -> InScopeSet +rnInScopeSet = in_scope + +-- | Retrieve the left mapping +rnEnvL :: RnEnv2 -> VarEnv Var +rnEnvL = envL + +-- | Retrieve the right mapping +rnEnvR :: RnEnv2 -> VarEnv Var +rnEnvR = envR + +rnBndrs2 :: RnEnv2 -> [Var] -> [Var] -> RnEnv2 +-- ^ Applies 'rnBndr2' to several variables: the two variable lists must be of equal length +rnBndrs2 env bsL bsR = foldl2 rnBndr2 env bsL bsR + +rnBndr2 :: RnEnv2 -> Var -> Var -> RnEnv2 +-- ^ @rnBndr2 env bL bR@ goes under a binder @bL@ in the Left term, +-- and binder @bR@ in the Right term. +-- It finds a new binder, @new_b@, +-- and returns an environment mapping @bL -> new_b@ and @bR -> new_b@ +rnBndr2 env bL bR = fst $ rnBndr2_var env bL bR + +rnBndr2_var :: RnEnv2 -> Var -> Var -> (RnEnv2, Var) +-- ^ Similar to 'rnBndr2' but returns the new variable as well as the +-- new environment +rnBndr2_var (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL bR + = (RV2 { envL = extendVarEnv envL bL new_b -- See Note + , envR = extendVarEnv envR bR new_b -- [Rebinding] + , in_scope = extendInScopeSet in_scope new_b }, new_b) + where + -- Find a new binder not in scope in either term + new_b | not (bL `elemInScopeSet` in_scope) = bL + | not (bR `elemInScopeSet` in_scope) = bR + | otherwise = uniqAway' in_scope bL + + -- Note [Rebinding] + -- If the new var is the same as the old one, note that + -- the extendVarEnv *deletes* any current renaming + -- E.g. (\x. \x. ...) ~ (\y. \z. ...) + -- + -- Inside \x \y { [x->y], [y->y], {y} } + -- \x \z { [x->x], [y->y, z->x], {y,x} } + +rnBndrL :: RnEnv2 -> Var -> (RnEnv2, Var) +-- ^ Similar to 'rnBndr2' but used when there's a binder on the left +-- side only. +rnBndrL (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL + = (RV2 { envL = extendVarEnv envL bL new_b + , envR = envR + , in_scope = extendInScopeSet in_scope new_b }, new_b) + where + new_b = uniqAway in_scope bL + +rnBndrR :: RnEnv2 -> Var -> (RnEnv2, Var) +-- ^ Similar to 'rnBndr2' but used when there's a binder on the right +-- side only. +rnBndrR (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bR + = (RV2 { envR = extendVarEnv envR bR new_b + , envL = envL + , in_scope = extendInScopeSet in_scope new_b }, new_b) + where + new_b = uniqAway in_scope bR + +rnEtaL :: RnEnv2 -> Var -> (RnEnv2, Var) +-- ^ Similar to 'rnBndrL' but used for eta expansion +-- See Note [Eta expansion] +rnEtaL (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bL + = (RV2 { envL = extendVarEnv envL bL new_b + , envR = extendVarEnv envR new_b new_b -- Note [Eta expansion] + , in_scope = extendInScopeSet in_scope new_b }, new_b) + where + new_b = uniqAway in_scope bL + +rnEtaR :: RnEnv2 -> Var -> (RnEnv2, Var) +-- ^ Similar to 'rnBndr2' but used for eta expansion +-- See Note [Eta expansion] +rnEtaR (RV2 { envL = envL, envR = envR, in_scope = in_scope }) bR + = (RV2 { envL = extendVarEnv envL new_b new_b -- Note [Eta expansion] + , envR = extendVarEnv envR bR new_b + , in_scope = extendInScopeSet in_scope new_b }, new_b) + where + new_b = uniqAway in_scope bR + +delBndrL, delBndrR :: RnEnv2 -> Var -> RnEnv2 +delBndrL rn@(RV2 { envL = env, in_scope = in_scope }) v + = rn { envL = env `delVarEnv` v, in_scope = in_scope `extendInScopeSet` v } +delBndrR rn@(RV2 { envR = env, in_scope = in_scope }) v + = rn { envR = env `delVarEnv` v, in_scope = in_scope `extendInScopeSet` v } + +delBndrsL, delBndrsR :: RnEnv2 -> [Var] -> RnEnv2 +delBndrsL rn@(RV2 { envL = env, in_scope = in_scope }) v + = rn { envL = env `delVarEnvList` v, in_scope = in_scope `extendInScopeSetList` v } +delBndrsR rn@(RV2 { envR = env, in_scope = in_scope }) v + = rn { envR = env `delVarEnvList` v, in_scope = in_scope `extendInScopeSetList` v } + +rnOccL, rnOccR :: RnEnv2 -> Var -> Var +-- ^ Look up the renaming of an occurrence in the left or right term +rnOccL (RV2 { envL = env }) v = lookupVarEnv env v `orElse` v +rnOccR (RV2 { envR = env }) v = lookupVarEnv env v `orElse` v + +rnOccL_maybe, rnOccR_maybe :: RnEnv2 -> Var -> Maybe Var +-- ^ Look up the renaming of an occurrence in the left or right term +rnOccL_maybe (RV2 { envL = env }) v = lookupVarEnv env v +rnOccR_maybe (RV2 { envR = env }) v = lookupVarEnv env v + +inRnEnvL, inRnEnvR :: RnEnv2 -> Var -> Bool +-- ^ Tells whether a variable is locally bound +inRnEnvL (RV2 { envL = env }) v = v `elemVarEnv` env +inRnEnvR (RV2 { envR = env }) v = v `elemVarEnv` env + +lookupRnInScope :: RnEnv2 -> Var -> Var +lookupRnInScope env v = lookupInScope (in_scope env) v `orElse` v + +nukeRnEnvL, nukeRnEnvR :: RnEnv2 -> RnEnv2 +-- ^ Wipe the left or right side renaming +nukeRnEnvL env = env { envL = emptyVarEnv } +nukeRnEnvR env = env { envR = emptyVarEnv } + +rnSwap :: RnEnv2 -> RnEnv2 +-- ^ swap the meaning of left and right +rnSwap (RV2 { envL = envL, envR = envR, in_scope = in_scope }) + = RV2 { envL = envR, envR = envL, in_scope = in_scope } + +{- +Note [Eta expansion] +~~~~~~~~~~~~~~~~~~~~ +When matching + (\x.M) ~ N +we rename x to x' with, where x' is not in scope in +either term. Then we want to behave as if we'd seen + (\x'.M) ~ (\x'.N x') +Since x' isn't in scope in N, the form (\x'. N x') doesn't +capture any variables in N. But we must nevertheless extend +the envR with a binding [x' -> x'], to support the occurs check. +For example, if we don't do this, we can get silly matches like + forall a. (\y.a) ~ v +succeeding with [a -> v y], which is bogus of course. + + +************************************************************************ +* * + Tidying +* * +************************************************************************ +-} + +-- | Tidy Environment +-- +-- When tidying up print names, we keep a mapping of in-scope occ-names +-- (the 'TidyOccEnv') and a Var-to-Var of the current renamings +type TidyEnv = (TidyOccEnv, VarEnv Var) + +emptyTidyEnv :: TidyEnv +emptyTidyEnv = (emptyTidyOccEnv, emptyVarEnv) + +mkEmptyTidyEnv :: TidyOccEnv -> TidyEnv +mkEmptyTidyEnv occ_env = (occ_env, emptyVarEnv) + +{- +************************************************************************ +* * +\subsection{@VarEnv@s} +* * +************************************************************************ +-} + +-- | Variable Environment +type VarEnv elt = UniqFM elt + +-- | Identifier Environment +type IdEnv elt = VarEnv elt + +-- | Type Variable Environment +type TyVarEnv elt = VarEnv elt + +-- | Type or Coercion Variable Environment +type TyCoVarEnv elt = VarEnv elt + +-- | Coercion Variable Environment +type CoVarEnv elt = VarEnv elt + +emptyVarEnv :: VarEnv a +mkVarEnv :: [(Var, a)] -> VarEnv a +mkVarEnv_Directly :: [(Unique, a)] -> VarEnv a +zipVarEnv :: [Var] -> [a] -> VarEnv a +unitVarEnv :: Var -> a -> VarEnv a +alterVarEnv :: (Maybe a -> Maybe a) -> VarEnv a -> Var -> VarEnv a +extendVarEnv :: VarEnv a -> Var -> a -> VarEnv a +extendVarEnv_C :: (a->a->a) -> VarEnv a -> Var -> a -> VarEnv a +extendVarEnv_Acc :: (a->b->b) -> (a->b) -> VarEnv b -> Var -> a -> VarEnv b +extendVarEnv_Directly :: VarEnv a -> Unique -> a -> VarEnv a +plusVarEnv :: VarEnv a -> VarEnv a -> VarEnv a +plusVarEnvList :: [VarEnv a] -> VarEnv a +extendVarEnvList :: VarEnv a -> [(Var, a)] -> VarEnv a + +lookupVarEnv_Directly :: VarEnv a -> Unique -> Maybe a +filterVarEnv_Directly :: (Unique -> a -> Bool) -> VarEnv a -> VarEnv a +delVarEnv_Directly :: VarEnv a -> Unique -> VarEnv a +partitionVarEnv :: (a -> Bool) -> VarEnv a -> (VarEnv a, VarEnv a) +restrictVarEnv :: VarEnv a -> VarSet -> VarEnv a +delVarEnvList :: VarEnv a -> [Var] -> VarEnv a +delVarEnv :: VarEnv a -> Var -> VarEnv a +minusVarEnv :: VarEnv a -> VarEnv b -> VarEnv a +intersectsVarEnv :: VarEnv a -> VarEnv a -> Bool +plusVarEnv_C :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a +plusVarEnv_CD :: (a -> a -> a) -> VarEnv a -> a -> VarEnv a -> a -> VarEnv a +plusMaybeVarEnv_C :: (a -> a -> Maybe a) -> VarEnv a -> VarEnv a -> VarEnv a +mapVarEnv :: (a -> b) -> VarEnv a -> VarEnv b +modifyVarEnv :: (a -> a) -> VarEnv a -> Var -> VarEnv a + +isEmptyVarEnv :: VarEnv a -> Bool +lookupVarEnv :: VarEnv a -> Var -> Maybe a +filterVarEnv :: (a -> Bool) -> VarEnv a -> VarEnv a +lookupVarEnv_NF :: VarEnv a -> Var -> a +lookupWithDefaultVarEnv :: VarEnv a -> a -> Var -> a +elemVarEnv :: Var -> VarEnv a -> Bool +elemVarEnvByKey :: Unique -> VarEnv a -> Bool +disjointVarEnv :: VarEnv a -> VarEnv a -> Bool + +elemVarEnv = elemUFM +elemVarEnvByKey = elemUFM_Directly +disjointVarEnv = disjointUFM +alterVarEnv = alterUFM +extendVarEnv = addToUFM +extendVarEnv_C = addToUFM_C +extendVarEnv_Acc = addToUFM_Acc +extendVarEnv_Directly = addToUFM_Directly +extendVarEnvList = addListToUFM +plusVarEnv_C = plusUFM_C +plusVarEnv_CD = plusUFM_CD +plusMaybeVarEnv_C = plusMaybeUFM_C +delVarEnvList = delListFromUFM +delVarEnv = delFromUFM +minusVarEnv = minusUFM +intersectsVarEnv e1 e2 = not (isEmptyVarEnv (e1 `intersectUFM` e2)) +plusVarEnv = plusUFM +plusVarEnvList = plusUFMList +lookupVarEnv = lookupUFM +filterVarEnv = filterUFM +lookupWithDefaultVarEnv = lookupWithDefaultUFM +mapVarEnv = mapUFM +mkVarEnv = listToUFM +mkVarEnv_Directly= listToUFM_Directly +emptyVarEnv = emptyUFM +unitVarEnv = unitUFM +isEmptyVarEnv = isNullUFM +lookupVarEnv_Directly = lookupUFM_Directly +filterVarEnv_Directly = filterUFM_Directly +delVarEnv_Directly = delFromUFM_Directly +partitionVarEnv = partitionUFM + +restrictVarEnv env vs = filterVarEnv_Directly keep env + where + keep u _ = u `elemVarSetByKey` vs + +zipVarEnv tyvars tys = mkVarEnv (zipEqual "zipVarEnv" tyvars tys) +lookupVarEnv_NF env id = case lookupVarEnv env id of + Just xx -> xx + Nothing -> panic "lookupVarEnv_NF: Nothing" + +{- +@modifyVarEnv@: Look up a thing in the VarEnv, +then mash it with the modify function, and put it back. +-} + +modifyVarEnv mangle_fn env key + = case (lookupVarEnv env key) of + Nothing -> env + Just xx -> extendVarEnv env key (mangle_fn xx) + +modifyVarEnv_Directly :: (a -> a) -> UniqFM a -> Unique -> UniqFM a +modifyVarEnv_Directly mangle_fn env key + = case (lookupUFM_Directly env key) of + Nothing -> env + Just xx -> addToUFM_Directly env key (mangle_fn xx) + +-- Deterministic VarEnv +-- See Note [Deterministic UniqFM] in UniqDFM for explanation why we need +-- DVarEnv. + +-- | Deterministic Variable Environment +type DVarEnv elt = UniqDFM elt + +-- | Deterministic Identifier Environment +type DIdEnv elt = DVarEnv elt + +-- | Deterministic Type Variable Environment +type DTyVarEnv elt = DVarEnv elt + +emptyDVarEnv :: DVarEnv a +emptyDVarEnv = emptyUDFM + +dVarEnvElts :: DVarEnv a -> [a] +dVarEnvElts = eltsUDFM + +mkDVarEnv :: [(Var, a)] -> DVarEnv a +mkDVarEnv = listToUDFM + +extendDVarEnv :: DVarEnv a -> Var -> a -> DVarEnv a +extendDVarEnv = addToUDFM + +minusDVarEnv :: DVarEnv a -> DVarEnv a' -> DVarEnv a +minusDVarEnv = minusUDFM + +lookupDVarEnv :: DVarEnv a -> Var -> Maybe a +lookupDVarEnv = lookupUDFM + +foldDVarEnv :: (a -> b -> b) -> b -> DVarEnv a -> b +foldDVarEnv = foldUDFM + +mapDVarEnv :: (a -> b) -> DVarEnv a -> DVarEnv b +mapDVarEnv = mapUDFM + +filterDVarEnv :: (a -> Bool) -> DVarEnv a -> DVarEnv a +filterDVarEnv = filterUDFM + +alterDVarEnv :: (Maybe a -> Maybe a) -> DVarEnv a -> Var -> DVarEnv a +alterDVarEnv = alterUDFM + +plusDVarEnv :: DVarEnv a -> DVarEnv a -> DVarEnv a +plusDVarEnv = plusUDFM + +plusDVarEnv_C :: (a -> a -> a) -> DVarEnv a -> DVarEnv a -> DVarEnv a +plusDVarEnv_C = plusUDFM_C + +unitDVarEnv :: Var -> a -> DVarEnv a +unitDVarEnv = unitUDFM + +delDVarEnv :: DVarEnv a -> Var -> DVarEnv a +delDVarEnv = delFromUDFM + +delDVarEnvList :: DVarEnv a -> [Var] -> DVarEnv a +delDVarEnvList = delListFromUDFM + +isEmptyDVarEnv :: DVarEnv a -> Bool +isEmptyDVarEnv = isNullUDFM + +elemDVarEnv :: Var -> DVarEnv a -> Bool +elemDVarEnv = elemUDFM + +extendDVarEnv_C :: (a -> a -> a) -> DVarEnv a -> Var -> a -> DVarEnv a +extendDVarEnv_C = addToUDFM_C + +modifyDVarEnv :: (a -> a) -> DVarEnv a -> Var -> DVarEnv a +modifyDVarEnv mangle_fn env key + = case (lookupDVarEnv env key) of + Nothing -> env + Just xx -> extendDVarEnv env key (mangle_fn xx) + +partitionDVarEnv :: (a -> Bool) -> DVarEnv a -> (DVarEnv a, DVarEnv a) +partitionDVarEnv = partitionUDFM + +extendDVarEnvList :: DVarEnv a -> [(Var, a)] -> DVarEnv a +extendDVarEnvList = addListToUDFM + +anyDVarEnv :: (a -> Bool) -> DVarEnv a -> Bool +anyDVarEnv = anyUDFM diff --git a/compiler/basicTypes/VarSet.hs b/compiler/basicTypes/VarSet.hs new file mode 100644 --- /dev/null +++ b/compiler/basicTypes/VarSet.hs @@ -0,0 +1,350 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE CPP #-} + +module VarSet ( + -- * Var, Id and TyVar set types + VarSet, IdSet, TyVarSet, CoVarSet, TyCoVarSet, + + -- ** Manipulating these sets + emptyVarSet, unitVarSet, mkVarSet, + extendVarSet, extendVarSetList, + elemVarSet, subVarSet, + unionVarSet, unionVarSets, mapUnionVarSet, + intersectVarSet, intersectsVarSet, disjointVarSet, + isEmptyVarSet, delVarSet, delVarSetList, delVarSetByKey, + minusVarSet, filterVarSet, mapVarSet, + anyVarSet, allVarSet, + transCloVarSet, fixVarSet, + lookupVarSet_Directly, lookupVarSet, lookupVarSetByName, + sizeVarSet, seqVarSet, + elemVarSetByKey, partitionVarSet, + pluralVarSet, pprVarSet, + + -- * Deterministic Var set types + DVarSet, DIdSet, DTyVarSet, DTyCoVarSet, + + -- ** Manipulating these sets + emptyDVarSet, unitDVarSet, mkDVarSet, + extendDVarSet, extendDVarSetList, + elemDVarSet, dVarSetElems, subDVarSet, + unionDVarSet, unionDVarSets, mapUnionDVarSet, + intersectDVarSet, dVarSetIntersectVarSet, + intersectsDVarSet, disjointDVarSet, + isEmptyDVarSet, delDVarSet, delDVarSetList, + minusDVarSet, foldDVarSet, filterDVarSet, mapDVarSet, + dVarSetMinusVarSet, anyDVarSet, allDVarSet, + transCloDVarSet, + sizeDVarSet, seqDVarSet, + partitionDVarSet, + dVarSetToVarSet, + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import Var ( Var, TyVar, CoVar, TyCoVar, Id ) +import Unique +import Name ( Name ) +import UniqSet +import UniqDSet +import UniqFM( disjointUFM, pluralUFM, pprUFM ) +import UniqDFM( disjointUDFM, udfmToUfm, anyUDFM, allUDFM ) +import Outputable (SDoc) + +-- | A non-deterministic Variable Set +-- +-- A non-deterministic set of variables. +-- See Note [Deterministic UniqFM] in UniqDFM for explanation why it's not +-- deterministic and why it matters. Use DVarSet if the set eventually +-- gets converted into a list or folded over in a way where the order +-- changes the generated code, for example when abstracting variables. +type VarSet = UniqSet Var + +-- | Identifier Set +type IdSet = UniqSet Id + +-- | Type Variable Set +type TyVarSet = UniqSet TyVar + +-- | Coercion Variable Set +type CoVarSet = UniqSet CoVar + +-- | Type or Coercion Variable Set +type TyCoVarSet = UniqSet TyCoVar + +emptyVarSet :: VarSet +intersectVarSet :: VarSet -> VarSet -> VarSet +unionVarSet :: VarSet -> VarSet -> VarSet +unionVarSets :: [VarSet] -> VarSet + +mapUnionVarSet :: (a -> VarSet) -> [a] -> VarSet +-- ^ map the function over the list, and union the results + +unitVarSet :: Var -> VarSet +extendVarSet :: VarSet -> Var -> VarSet +extendVarSetList:: VarSet -> [Var] -> VarSet +elemVarSet :: Var -> VarSet -> Bool +delVarSet :: VarSet -> Var -> VarSet +delVarSetList :: VarSet -> [Var] -> VarSet +minusVarSet :: VarSet -> VarSet -> VarSet +isEmptyVarSet :: VarSet -> Bool +mkVarSet :: [Var] -> VarSet +lookupVarSet_Directly :: VarSet -> Unique -> Maybe Var +lookupVarSet :: VarSet -> Var -> Maybe Var + -- Returns the set element, which may be + -- (==) to the argument, but not the same as +lookupVarSetByName :: VarSet -> Name -> Maybe Var +sizeVarSet :: VarSet -> Int +filterVarSet :: (Var -> Bool) -> VarSet -> VarSet + +delVarSetByKey :: VarSet -> Unique -> VarSet +elemVarSetByKey :: Unique -> VarSet -> Bool +partitionVarSet :: (Var -> Bool) -> VarSet -> (VarSet, VarSet) + +emptyVarSet = emptyUniqSet +unitVarSet = unitUniqSet +extendVarSet = addOneToUniqSet +extendVarSetList= addListToUniqSet +intersectVarSet = intersectUniqSets + +intersectsVarSet:: VarSet -> VarSet -> Bool -- True if non-empty intersection +disjointVarSet :: VarSet -> VarSet -> Bool -- True if empty intersection +subVarSet :: VarSet -> VarSet -> Bool -- True if first arg is subset of second + -- (s1 `intersectsVarSet` s2) doesn't compute s2 if s1 is empty; + -- ditto disjointVarSet, subVarSet + +unionVarSet = unionUniqSets +unionVarSets = unionManyUniqSets +elemVarSet = elementOfUniqSet +minusVarSet = minusUniqSet +delVarSet = delOneFromUniqSet +delVarSetList = delListFromUniqSet +isEmptyVarSet = isEmptyUniqSet +mkVarSet = mkUniqSet +lookupVarSet_Directly = lookupUniqSet_Directly +lookupVarSet = lookupUniqSet +lookupVarSetByName = lookupUniqSet +sizeVarSet = sizeUniqSet +filterVarSet = filterUniqSet +delVarSetByKey = delOneFromUniqSet_Directly +elemVarSetByKey = elemUniqSet_Directly +partitionVarSet = partitionUniqSet + +mapUnionVarSet get_set xs = foldr (unionVarSet . get_set) emptyVarSet xs + +-- See comments with type signatures +intersectsVarSet s1 s2 = not (s1 `disjointVarSet` s2) +disjointVarSet s1 s2 = disjointUFM (getUniqSet s1) (getUniqSet s2) +subVarSet s1 s2 = isEmptyVarSet (s1 `minusVarSet` s2) + +anyVarSet :: (Var -> Bool) -> VarSet -> Bool +anyVarSet = uniqSetAny + +allVarSet :: (Var -> Bool) -> VarSet -> Bool +allVarSet = uniqSetAll + +mapVarSet :: Uniquable b => (a -> b) -> UniqSet a -> UniqSet b +mapVarSet = mapUniqSet + +fixVarSet :: (VarSet -> VarSet) -- Map the current set to a new set + -> VarSet -> VarSet +-- (fixVarSet f s) repeatedly applies f to the set s, +-- until it reaches a fixed point. +fixVarSet fn vars + | new_vars `subVarSet` vars = vars + | otherwise = fixVarSet fn new_vars + where + new_vars = fn vars + +transCloVarSet :: (VarSet -> VarSet) + -- Map some variables in the set to + -- extra variables that should be in it + -> VarSet -> VarSet +-- (transCloVarSet f s) repeatedly applies f to new candidates, adding any +-- new variables to s that it finds thereby, until it reaches a fixed point. +-- +-- The function fn could be (Var -> VarSet), but we use (VarSet -> VarSet) +-- for efficiency, so that the test can be batched up. +-- It's essential that fn will work fine if given new candidates +-- one at at time; ie fn {v1,v2} = fn v1 `union` fn v2 +-- Use fixVarSet if the function needs to see the whole set all at once +transCloVarSet fn seeds + = go seeds seeds + where + go :: VarSet -- Accumulating result + -> VarSet -- Work-list; un-processed subset of accumulating result + -> VarSet + -- Specification: go acc vs = acc `union` transClo fn vs + + go acc candidates + | isEmptyVarSet new_vs = acc + | otherwise = go (acc `unionVarSet` new_vs) new_vs + where + new_vs = fn candidates `minusVarSet` acc + +seqVarSet :: VarSet -> () +seqVarSet s = sizeVarSet s `seq` () + +-- | Determines the pluralisation suffix appropriate for the length of a set +-- in the same way that plural from Outputable does for lists. +pluralVarSet :: VarSet -> SDoc +pluralVarSet = pluralUFM . getUniqSet + +-- | Pretty-print a non-deterministic set. +-- The order of variables is non-deterministic and for pretty-printing that +-- shouldn't be a problem. +-- Having this function helps contain the non-determinism created with +-- nonDetEltsUFM. +-- Passing a list to the pretty-printing function allows the caller +-- to decide on the order of Vars (eg. toposort them) without them having +-- to use nonDetEltsUFM at the call site. This prevents from let-binding +-- non-deterministically ordered lists and reusing them where determinism +-- matters. +pprVarSet :: VarSet -- ^ The things to be pretty printed + -> ([Var] -> SDoc) -- ^ The pretty printing function to use on the + -- elements + -> SDoc -- ^ 'SDoc' where the things have been pretty + -- printed +pprVarSet = pprUFM . getUniqSet + +-- Deterministic VarSet +-- See Note [Deterministic UniqFM] in UniqDFM for explanation why we need +-- DVarSet. + +-- | Deterministic Variable Set +type DVarSet = UniqDSet Var + +-- | Deterministic Identifier Set +type DIdSet = UniqDSet Id + +-- | Deterministic Type Variable Set +type DTyVarSet = UniqDSet TyVar + +-- | Deterministic Type or Coercion Variable Set +type DTyCoVarSet = UniqDSet TyCoVar + +emptyDVarSet :: DVarSet +emptyDVarSet = emptyUniqDSet + +unitDVarSet :: Var -> DVarSet +unitDVarSet = unitUniqDSet + +mkDVarSet :: [Var] -> DVarSet +mkDVarSet = mkUniqDSet + +-- The new element always goes to the right of existing ones. +extendDVarSet :: DVarSet -> Var -> DVarSet +extendDVarSet = addOneToUniqDSet + +elemDVarSet :: Var -> DVarSet -> Bool +elemDVarSet = elementOfUniqDSet + +dVarSetElems :: DVarSet -> [Var] +dVarSetElems = uniqDSetToList + +subDVarSet :: DVarSet -> DVarSet -> Bool +subDVarSet s1 s2 = isEmptyDVarSet (s1 `minusDVarSet` s2) + +unionDVarSet :: DVarSet -> DVarSet -> DVarSet +unionDVarSet = unionUniqDSets + +unionDVarSets :: [DVarSet] -> DVarSet +unionDVarSets = unionManyUniqDSets + +-- | Map the function over the list, and union the results +mapUnionDVarSet :: (a -> DVarSet) -> [a] -> DVarSet +mapUnionDVarSet get_set xs = foldr (unionDVarSet . get_set) emptyDVarSet xs + +intersectDVarSet :: DVarSet -> DVarSet -> DVarSet +intersectDVarSet = intersectUniqDSets + +dVarSetIntersectVarSet :: DVarSet -> VarSet -> DVarSet +dVarSetIntersectVarSet = uniqDSetIntersectUniqSet + +-- | True if empty intersection +disjointDVarSet :: DVarSet -> DVarSet -> Bool +disjointDVarSet s1 s2 = disjointUDFM (getUniqDSet s1) (getUniqDSet s2) + +-- | True if non-empty intersection +intersectsDVarSet :: DVarSet -> DVarSet -> Bool +intersectsDVarSet s1 s2 = not (s1 `disjointDVarSet` s2) + +isEmptyDVarSet :: DVarSet -> Bool +isEmptyDVarSet = isEmptyUniqDSet + +delDVarSet :: DVarSet -> Var -> DVarSet +delDVarSet = delOneFromUniqDSet + +minusDVarSet :: DVarSet -> DVarSet -> DVarSet +minusDVarSet = minusUniqDSet + +dVarSetMinusVarSet :: DVarSet -> VarSet -> DVarSet +dVarSetMinusVarSet = uniqDSetMinusUniqSet + +foldDVarSet :: (Var -> a -> a) -> a -> DVarSet -> a +foldDVarSet = foldUniqDSet + +anyDVarSet :: (Var -> Bool) -> DVarSet -> Bool +anyDVarSet p = anyUDFM p . getUniqDSet + +allDVarSet :: (Var -> Bool) -> DVarSet -> Bool +allDVarSet p = allUDFM p . getUniqDSet + +mapDVarSet :: Uniquable b => (a -> b) -> UniqDSet a -> UniqDSet b +mapDVarSet = mapUniqDSet + +filterDVarSet :: (Var -> Bool) -> DVarSet -> DVarSet +filterDVarSet = filterUniqDSet + +sizeDVarSet :: DVarSet -> Int +sizeDVarSet = sizeUniqDSet + +-- | Partition DVarSet according to the predicate given +partitionDVarSet :: (Var -> Bool) -> DVarSet -> (DVarSet, DVarSet) +partitionDVarSet = partitionUniqDSet + +-- | Delete a list of variables from DVarSet +delDVarSetList :: DVarSet -> [Var] -> DVarSet +delDVarSetList = delListFromUniqDSet + +seqDVarSet :: DVarSet -> () +seqDVarSet s = sizeDVarSet s `seq` () + +-- | Add a list of variables to DVarSet +extendDVarSetList :: DVarSet -> [Var] -> DVarSet +extendDVarSetList = addListToUniqDSet + +-- | Convert a DVarSet to a VarSet by forgeting the order of insertion +dVarSetToVarSet :: DVarSet -> VarSet +dVarSetToVarSet = unsafeUFMToUniqSet . udfmToUfm . getUniqDSet + +-- | transCloVarSet for DVarSet +transCloDVarSet :: (DVarSet -> DVarSet) + -- Map some variables in the set to + -- extra variables that should be in it + -> DVarSet -> DVarSet +-- (transCloDVarSet f s) repeatedly applies f to new candidates, adding any +-- new variables to s that it finds thereby, until it reaches a fixed point. +-- +-- The function fn could be (Var -> DVarSet), but we use (DVarSet -> DVarSet) +-- for efficiency, so that the test can be batched up. +-- It's essential that fn will work fine if given new candidates +-- one at at time; ie fn {v1,v2} = fn v1 `union` fn v2 +transCloDVarSet fn seeds + = go seeds seeds + where + go :: DVarSet -- Accumulating result + -> DVarSet -- Work-list; un-processed subset of accumulating result + -> DVarSet + -- Specification: go acc vs = acc `union` transClo fn vs + + go acc candidates + | isEmptyDVarSet new_vs = acc + | otherwise = go (acc `unionDVarSet` new_vs) new_vs + where + new_vs = fn candidates `minusDVarSet` acc diff --git a/compiler/cbits/genSym.c b/compiler/cbits/genSym.c new file mode 100644 --- /dev/null +++ b/compiler/cbits/genSym.c @@ -0,0 +1,40 @@ +#include +#include "Rts.h" +#include "Unique.h" + +static HsInt GenSymCounter = 0; +static HsInt GenSymInc = 1; + +#define UNIQUE_BITS (sizeof (HsInt) * 8 - UNIQUE_TAG_BITS) +#define UNIQUE_MASK ((1ULL << UNIQUE_BITS) - 1) + +STATIC_INLINE void checkUniqueRange(HsInt u STG_UNUSED) { +#if DEBUG + // Uh oh! We will overflow next time a unique is requested. + assert(u != UNIQUE_MASK); +#endif +} + +HsInt genSym(void) { +#if defined(THREADED_RTS) + if (n_capabilities == 1) { + GenSymCounter = (GenSymCounter + GenSymInc) & UNIQUE_MASK; + checkUniqueRange(GenSymCounter); + return GenSymCounter; + } else { + HsInt n = atomic_inc((StgWord *)&GenSymCounter, GenSymInc) + & UNIQUE_MASK; + checkUniqueRange(n); + return n; + } +#else + GenSymCounter = (GenSymCounter + GenSymInc) & UNIQUE_MASK; + checkUniqueRange(GenSymCounter); + return GenSymCounter; +#endif +} + +void initGenSym(HsInt NewGenSymCounter, HsInt NewGenSymInc) { + GenSymCounter = NewGenSymCounter; + GenSymInc = NewGenSymInc; +} diff --git a/compiler/cmm/CmmType.hs b/compiler/cmm/CmmType.hs new file mode 100644 --- /dev/null +++ b/compiler/cmm/CmmType.hs @@ -0,0 +1,442 @@ +module CmmType + ( CmmType -- Abstract + , b8, b16, b32, b64, b128, b256, b512, f32, f64, bWord, bHalfWord, gcWord + , cInt + , cmmBits, cmmFloat + , typeWidth, cmmEqType, cmmEqType_ignoring_ptrhood + , isFloatType, isGcPtrType, isBitsType + , isWord32, isWord64, isFloat64, isFloat32 + + , Width(..) + , widthInBits, widthInBytes, widthInLog, widthFromBytes + , wordWidth, halfWordWidth, cIntWidth + , halfWordMask + , narrowU, narrowS + , rEP_CostCentreStack_mem_alloc + , rEP_CostCentreStack_scc_count + , rEP_StgEntCounter_allocs + , rEP_StgEntCounter_allocd + + , ForeignHint(..) + + , Length + , vec, vec2, vec4, vec8, vec16 + , vec2f64, vec2b64, vec4f32, vec4b32, vec8b16, vec16b8 + , cmmVec + , vecLength, vecElemType + , isVecType + ) +where + + +import GhcPrelude + +import DynFlags +import FastString +import Outputable + +import Data.Word +import Data.Int + +----------------------------------------------------------------------------- +-- CmmType +----------------------------------------------------------------------------- + + -- NOTE: CmmType is an abstract type, not exported from this + -- module so you can easily change its representation + -- + -- However Width is exported in a concrete way, + -- and is used extensively in pattern-matching + +data CmmType -- The important one! + = CmmType CmmCat Width + +data CmmCat -- "Category" (not exported) + = GcPtrCat -- GC pointer + | BitsCat -- Non-pointer + | FloatCat -- Float + | VecCat Length CmmCat -- Vector + deriving( Eq ) + -- See Note [Signed vs unsigned] at the end + +instance Outputable CmmType where + ppr (CmmType cat wid) = ppr cat <> ppr (widthInBits wid) + +instance Outputable CmmCat where + ppr FloatCat = text "F" + ppr GcPtrCat = text "P" + ppr BitsCat = text "I" + ppr (VecCat n cat) = ppr cat <> text "x" <> ppr n <> text "V" + +-- Why is CmmType stratified? For native code generation, +-- most of the time you just want to know what sort of register +-- to put the thing in, and for this you need to know how +-- many bits thing has, and whether it goes in a floating-point +-- register. By contrast, the distinction between GcPtr and +-- GcNonPtr is of interest to only a few parts of the code generator. + +-------- Equality on CmmType -------------- +-- CmmType is *not* an instance of Eq; sometimes we care about the +-- Gc/NonGc distinction, and sometimes we don't +-- So we use an explicit function to force you to think about it +cmmEqType :: CmmType -> CmmType -> Bool -- Exact equality +cmmEqType (CmmType c1 w1) (CmmType c2 w2) = c1==c2 && w1==w2 + +cmmEqType_ignoring_ptrhood :: CmmType -> CmmType -> Bool + -- This equality is temporary; used in CmmLint + -- but the RTS files are not yet well-typed wrt pointers +cmmEqType_ignoring_ptrhood (CmmType c1 w1) (CmmType c2 w2) + = c1 `weak_eq` c2 && w1==w2 + where + weak_eq :: CmmCat -> CmmCat -> Bool + FloatCat `weak_eq` FloatCat = True + FloatCat `weak_eq` _other = False + _other `weak_eq` FloatCat = False + (VecCat l1 cat1) `weak_eq` (VecCat l2 cat2) = l1 == l2 + && cat1 `weak_eq` cat2 + (VecCat {}) `weak_eq` _other = False + _other `weak_eq` (VecCat {}) = False + _word1 `weak_eq` _word2 = True -- Ignores GcPtr + +--- Simple operations on CmmType ----- +typeWidth :: CmmType -> Width +typeWidth (CmmType _ w) = w + +cmmBits, cmmFloat :: Width -> CmmType +cmmBits = CmmType BitsCat +cmmFloat = CmmType FloatCat + +-------- Common CmmTypes ------------ +-- Floats and words of specific widths +b8, b16, b32, b64, b128, b256, b512, f32, f64 :: CmmType +b8 = cmmBits W8 +b16 = cmmBits W16 +b32 = cmmBits W32 +b64 = cmmBits W64 +b128 = cmmBits W128 +b256 = cmmBits W256 +b512 = cmmBits W512 +f32 = cmmFloat W32 +f64 = cmmFloat W64 + +-- CmmTypes of native word widths +bWord :: DynFlags -> CmmType +bWord dflags = cmmBits (wordWidth dflags) + +bHalfWord :: DynFlags -> CmmType +bHalfWord dflags = cmmBits (halfWordWidth dflags) + +gcWord :: DynFlags -> CmmType +gcWord dflags = CmmType GcPtrCat (wordWidth dflags) + +cInt :: DynFlags -> CmmType +cInt dflags = cmmBits (cIntWidth dflags) + +------------ Predicates ---------------- +isFloatType, isGcPtrType, isBitsType :: CmmType -> Bool +isFloatType (CmmType FloatCat _) = True +isFloatType _other = False + +isGcPtrType (CmmType GcPtrCat _) = True +isGcPtrType _other = False + +isBitsType (CmmType BitsCat _) = True +isBitsType _ = False + +isWord32, isWord64, isFloat32, isFloat64 :: CmmType -> Bool +-- isWord64 is true of 64-bit non-floats (both gc-ptrs and otherwise) +-- isFloat32 and 64 are obvious + +isWord64 (CmmType BitsCat W64) = True +isWord64 (CmmType GcPtrCat W64) = True +isWord64 _other = False + +isWord32 (CmmType BitsCat W32) = True +isWord32 (CmmType GcPtrCat W32) = True +isWord32 _other = False + +isFloat32 (CmmType FloatCat W32) = True +isFloat32 _other = False + +isFloat64 (CmmType FloatCat W64) = True +isFloat64 _other = False + +----------------------------------------------------------------------------- +-- Width +----------------------------------------------------------------------------- + +data Width = W8 | W16 | W32 | W64 + | W80 -- Extended double-precision float, + -- used in x86 native codegen only. + -- (we use Ord, so it'd better be in this order) + | W128 + | W256 + | W512 + deriving (Eq, Ord, Show) + +instance Outputable Width where + ppr rep = ptext (mrStr rep) + +mrStr :: Width -> PtrString +mrStr W8 = sLit("W8") +mrStr W16 = sLit("W16") +mrStr W32 = sLit("W32") +mrStr W64 = sLit("W64") +mrStr W128 = sLit("W128") +mrStr W256 = sLit("W256") +mrStr W512 = sLit("W512") +mrStr W80 = sLit("W80") + + +-------- Common Widths ------------ +wordWidth :: DynFlags -> Width +wordWidth dflags + | wORD_SIZE dflags == 4 = W32 + | wORD_SIZE dflags == 8 = W64 + | otherwise = panic "MachOp.wordRep: Unknown word size" + +halfWordWidth :: DynFlags -> Width +halfWordWidth dflags + | wORD_SIZE dflags == 4 = W16 + | wORD_SIZE dflags == 8 = W32 + | otherwise = panic "MachOp.halfWordRep: Unknown word size" + +halfWordMask :: DynFlags -> Integer +halfWordMask dflags + | wORD_SIZE dflags == 4 = 0xFFFF + | wORD_SIZE dflags == 8 = 0xFFFFFFFF + | otherwise = panic "MachOp.halfWordMask: Unknown word size" + +-- cIntRep is the Width for a C-language 'int' +cIntWidth :: DynFlags -> Width +cIntWidth dflags = case cINT_SIZE dflags of + 4 -> W32 + 8 -> W64 + s -> panic ("cIntWidth: Unknown cINT_SIZE: " ++ show s) + +widthInBits :: Width -> Int +widthInBits W8 = 8 +widthInBits W16 = 16 +widthInBits W32 = 32 +widthInBits W64 = 64 +widthInBits W128 = 128 +widthInBits W256 = 256 +widthInBits W512 = 512 +widthInBits W80 = 80 + +widthInBytes :: Width -> Int +widthInBytes W8 = 1 +widthInBytes W16 = 2 +widthInBytes W32 = 4 +widthInBytes W64 = 8 +widthInBytes W128 = 16 +widthInBytes W256 = 32 +widthInBytes W512 = 64 +widthInBytes W80 = 10 + +widthFromBytes :: Int -> Width +widthFromBytes 1 = W8 +widthFromBytes 2 = W16 +widthFromBytes 4 = W32 +widthFromBytes 8 = W64 +widthFromBytes 16 = W128 +widthFromBytes 32 = W256 +widthFromBytes 64 = W512 +widthFromBytes 10 = W80 +widthFromBytes n = pprPanic "no width for given number of bytes" (ppr n) + +-- log_2 of the width in bytes, useful for generating shifts. +widthInLog :: Width -> Int +widthInLog W8 = 0 +widthInLog W16 = 1 +widthInLog W32 = 2 +widthInLog W64 = 3 +widthInLog W128 = 4 +widthInLog W256 = 5 +widthInLog W512 = 6 +widthInLog W80 = panic "widthInLog: F80" + +-- widening / narrowing + +narrowU :: Width -> Integer -> Integer +narrowU W8 x = fromIntegral (fromIntegral x :: Word8) +narrowU W16 x = fromIntegral (fromIntegral x :: Word16) +narrowU W32 x = fromIntegral (fromIntegral x :: Word32) +narrowU W64 x = fromIntegral (fromIntegral x :: Word64) +narrowU _ _ = panic "narrowTo" + +narrowS :: Width -> Integer -> Integer +narrowS W8 x = fromIntegral (fromIntegral x :: Int8) +narrowS W16 x = fromIntegral (fromIntegral x :: Int16) +narrowS W32 x = fromIntegral (fromIntegral x :: Int32) +narrowS W64 x = fromIntegral (fromIntegral x :: Int64) +narrowS _ _ = panic "narrowTo" + +----------------------------------------------------------------------------- +-- SIMD +----------------------------------------------------------------------------- + +type Length = Int + +vec :: Length -> CmmType -> CmmType +vec l (CmmType cat w) = CmmType (VecCat l cat) vecw + where + vecw :: Width + vecw = widthFromBytes (l*widthInBytes w) + +vec2, vec4, vec8, vec16 :: CmmType -> CmmType +vec2 = vec 2 +vec4 = vec 4 +vec8 = vec 8 +vec16 = vec 16 + +vec2f64, vec2b64, vec4f32, vec4b32, vec8b16, vec16b8 :: CmmType +vec2f64 = vec 2 f64 +vec2b64 = vec 2 b64 +vec4f32 = vec 4 f32 +vec4b32 = vec 4 b32 +vec8b16 = vec 8 b16 +vec16b8 = vec 16 b8 + +cmmVec :: Int -> CmmType -> CmmType +cmmVec n (CmmType cat w) = + CmmType (VecCat n cat) (widthFromBytes (n*widthInBytes w)) + +vecLength :: CmmType -> Length +vecLength (CmmType (VecCat l _) _) = l +vecLength _ = panic "vecLength: not a vector" + +vecElemType :: CmmType -> CmmType +vecElemType (CmmType (VecCat l cat) w) = CmmType cat scalw + where + scalw :: Width + scalw = widthFromBytes (widthInBytes w `div` l) +vecElemType _ = panic "vecElemType: not a vector" + +isVecType :: CmmType -> Bool +isVecType (CmmType (VecCat {}) _) = True +isVecType _ = False + +------------------------------------------------------------------------- +-- Hints + +-- Hints are extra type information we attach to the arguments and +-- results of a foreign call, where more type information is sometimes +-- needed by the ABI to make the correct kind of call. + +data ForeignHint + = NoHint | AddrHint | SignedHint + deriving( Eq ) + -- Used to give extra per-argument or per-result + -- information needed by foreign calling conventions + +------------------------------------------------------------------------- + +-- These don't really belong here, but I don't know where is best to +-- put them. + +rEP_CostCentreStack_mem_alloc :: DynFlags -> CmmType +rEP_CostCentreStack_mem_alloc dflags + = cmmBits (widthFromBytes (pc_REP_CostCentreStack_mem_alloc pc)) + where pc = sPlatformConstants (settings dflags) + +rEP_CostCentreStack_scc_count :: DynFlags -> CmmType +rEP_CostCentreStack_scc_count dflags + = cmmBits (widthFromBytes (pc_REP_CostCentreStack_scc_count pc)) + where pc = sPlatformConstants (settings dflags) + +rEP_StgEntCounter_allocs :: DynFlags -> CmmType +rEP_StgEntCounter_allocs dflags + = cmmBits (widthFromBytes (pc_REP_StgEntCounter_allocs pc)) + where pc = sPlatformConstants (settings dflags) + +rEP_StgEntCounter_allocd :: DynFlags -> CmmType +rEP_StgEntCounter_allocd dflags + = cmmBits (widthFromBytes (pc_REP_StgEntCounter_allocd pc)) + where pc = sPlatformConstants (settings dflags) + +------------------------------------------------------------------------- +{- Note [Signed vs unsigned] + ~~~~~~~~~~~~~~~~~~~~~~~~~ +Should a CmmType include a signed vs. unsigned distinction? + +This is very much like a "hint" in C-- terminology: it isn't necessary +in order to generate correct code, but it might be useful in that the +compiler can generate better code if it has access to higher-level +hints about data. This is important at call boundaries, because the +definition of a function is not visible at all of its call sites, so +the compiler cannot infer the hints. + +Here in Cmm, we're taking a slightly different approach. We include +the int vs. float hint in the CmmType, because (a) the majority of +platforms have a strong distinction between float and int registers, +and (b) we don't want to do any heavyweight hint-inference in the +native code backend in order to get good code. We're treating the +hint more like a type: our Cmm is always completely consistent with +respect to hints. All coercions between float and int are explicit. + +What about the signed vs. unsigned hint? This information might be +useful if we want to keep sub-word-sized values in word-size +registers, which we must do if we only have word-sized registers. + +On such a system, there are two straightforward conventions for +representing sub-word-sized values: + +(a) Leave the upper bits undefined. Comparison operations must + sign- or zero-extend both operands before comparing them, + depending on whether the comparison is signed or unsigned. + +(b) Always keep the values sign- or zero-extended as appropriate. + Arithmetic operations must narrow the result to the appropriate + size. + +A clever compiler might not use either (a) or (b) exclusively, instead +it would attempt to minimize the coercions by analysis: the same kind +of analysis that propagates hints around. In Cmm we don't want to +have to do this, so we plump for having richer types and keeping the +type information consistent. + +If signed/unsigned hints are missing from CmmType, then the only +choice we have is (a), because we don't know whether the result of an +operation should be sign- or zero-extended. + +Many architectures have extending load operations, which work well +with (b). To make use of them with (a), you need to know whether the +value is going to be sign- or zero-extended by an enclosing comparison +(for example), which involves knowing above the context. This is +doable but more complex. + +Further complicating the issue is foreign calls: a foreign calling +convention can specify that signed 8-bit quantities are passed as +sign-extended 32 bit quantities, for example (this is the case on the +PowerPC). So we *do* need sign information on foreign call arguments. + +Pros for adding signed vs. unsigned to CmmType: + + - It would let us use convention (b) above, and get easier + code generation for extending loads. + + - Less information required on foreign calls. + + - MachOp type would be simpler + +Cons: + + - More complexity + + - What is the CmmType for a VanillaReg? Currently it is + always wordRep, but now we have to decide whether it is + signed or unsigned. The same VanillaReg can thus have + different CmmType in different parts of the program. + + - Extra coercions cluttering up expressions. + +Currently for GHC, the foreign call point is moot, because we do our +own promotion of sub-word-sized values to word-sized values. The Int8 +type is represented by an Int# which is kept sign-extended at all times +(this is slightly naughty, because we're making assumptions about the +C calling convention rather early on in the compiler). However, given +this, the cons outweigh the pros. + +-} + diff --git a/compiler/coreSyn/CoreArity.hs b/compiler/coreSyn/CoreArity.hs new file mode 100644 --- /dev/null +++ b/compiler/coreSyn/CoreArity.hs @@ -0,0 +1,1159 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + + Arity and eta expansion +-} + +{-# LANGUAGE CPP #-} + +-- | Arity and eta expansion +module CoreArity ( + manifestArity, joinRhsArity, exprArity, typeArity, + exprEtaExpandArity, findRhsArity, CheapFun, etaExpand, + etaExpandToJoinPoint, etaExpandToJoinPointRule, + exprBotStrictness_maybe + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import CoreSyn +import CoreFVs +import CoreUtils +import CoreSubst +import Demand +import Var +import VarEnv +import Id +import Type +import TyCon ( initRecTc, checkRecTc ) +import Coercion +import BasicTypes +import Unique +import DynFlags ( DynFlags, GeneralFlag(..), gopt ) +import Outputable +import FastString +import Pair +import Util ( debugIsOn ) + +{- +************************************************************************ +* * + manifestArity and exprArity +* * +************************************************************************ + +exprArity is a cheap-and-cheerful version of exprEtaExpandArity. +It tells how many things the expression can be applied to before doing +any work. It doesn't look inside cases, lets, etc. The idea is that +exprEtaExpandArity will do the hard work, leaving something that's easy +for exprArity to grapple with. In particular, Simplify uses exprArity to +compute the ArityInfo for the Id. + +Originally I thought that it was enough just to look for top-level lambdas, but +it isn't. I've seen this + + foo = PrelBase.timesInt + +We want foo to get arity 2 even though the eta-expander will leave it +unchanged, in the expectation that it'll be inlined. But occasionally it +isn't, because foo is blacklisted (used in a rule). + +Similarly, see the ok_note check in exprEtaExpandArity. So + f = __inline_me (\x -> e) +won't be eta-expanded. + +And in any case it seems more robust to have exprArity be a bit more intelligent. +But note that (\x y z -> f x y z) +should have arity 3, regardless of f's arity. +-} + +manifestArity :: CoreExpr -> Arity +-- ^ manifestArity sees how many leading value lambdas there are, +-- after looking through casts +manifestArity (Lam v e) | isId v = 1 + manifestArity e + | otherwise = manifestArity e +manifestArity (Tick t e) | not (tickishIsCode t) = manifestArity e +manifestArity (Cast e _) = manifestArity e +manifestArity _ = 0 + +joinRhsArity :: CoreExpr -> JoinArity +-- Join points are supposed to have manifestly-visible +-- lambdas at the top: no ticks, no casts, nothing +-- Moreover, type lambdas count in JoinArity +joinRhsArity (Lam _ e) = 1 + joinRhsArity e +joinRhsArity _ = 0 + + +--------------- +exprArity :: CoreExpr -> Arity +-- ^ An approximate, fast, version of 'exprEtaExpandArity' +exprArity e = go e + where + go (Var v) = idArity v + go (Lam x e) | isId x = go e + 1 + | otherwise = go e + go (Tick t e) | not (tickishIsCode t) = go e + go (Cast e co) = trim_arity (go e) (pSnd (coercionKind co)) + -- Note [exprArity invariant] + go (App e (Type _)) = go e + go (App f a) | exprIsTrivial a = (go f - 1) `max` 0 + -- See Note [exprArity for applications] + -- NB: coercions count as a value argument + + go _ = 0 + + trim_arity :: Arity -> Type -> Arity + trim_arity arity ty = arity `min` length (typeArity ty) + +--------------- +typeArity :: Type -> [OneShotInfo] +-- How many value arrows are visible in the type? +-- We look through foralls, and newtypes +-- See Note [exprArity invariant] +typeArity ty + = go initRecTc ty + where + go rec_nts ty + | Just (_, ty') <- splitForAllTy_maybe ty + = go rec_nts ty' + + | Just (arg,res) <- splitFunTy_maybe ty + = typeOneShot arg : go rec_nts res + + | Just (tc,tys) <- splitTyConApp_maybe ty + , Just (ty', _) <- instNewTyCon_maybe tc tys + , Just rec_nts' <- checkRecTc rec_nts tc -- See Note [Expanding newtypes] + -- in TyCon +-- , not (isClassTyCon tc) -- Do not eta-expand through newtype classes +-- -- See Note [Newtype classes and eta expansion] +-- (no longer required) + = go rec_nts' ty' + -- Important to look through non-recursive newtypes, so that, eg + -- (f x) where f has arity 2, f :: Int -> IO () + -- Here we want to get arity 1 for the result! + -- + -- AND through a layer of recursive newtypes + -- e.g. newtype Stream m a b = Stream (m (Either b (a, Stream m a b))) + + | otherwise + = [] + +--------------- +exprBotStrictness_maybe :: CoreExpr -> Maybe (Arity, StrictSig) +-- A cheap and cheerful function that identifies bottoming functions +-- and gives them a suitable strictness signatures. It's used during +-- float-out +exprBotStrictness_maybe e + = case getBotArity (arityType env e) of + Nothing -> Nothing + Just ar -> Just (ar, sig ar) + where + env = AE { ae_ped_bot = True, ae_cheap_fn = \ _ _ -> False } + sig ar = mkClosedStrictSig (replicate ar topDmd) botRes + +{- +Note [exprArity invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +exprArity has the following invariant: + + (1) If typeArity (exprType e) = n, + then manifestArity (etaExpand e n) = n + + That is, etaExpand can always expand as much as typeArity says + So the case analysis in etaExpand and in typeArity must match + + (2) exprArity e <= typeArity (exprType e) + + (3) Hence if (exprArity e) = n, then manifestArity (etaExpand e n) = n + + That is, if exprArity says "the arity is n" then etaExpand really + can get "n" manifest lambdas to the top. + +Why is this important? Because + - In TidyPgm we use exprArity to fix the *final arity* of + each top-level Id, and in + - In CorePrep we use etaExpand on each rhs, so that the visible lambdas + actually match that arity, which in turn means + that the StgRhs has the right number of lambdas + +An alternative would be to do the eta-expansion in TidyPgm, at least +for top-level bindings, in which case we would not need the trim_arity +in exprArity. That is a less local change, so I'm going to leave it for today! + +Note [Newtype classes and eta expansion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + NB: this nasty special case is no longer required, because + for newtype classes we don't use the class-op rule mechanism + at all. See Note [Single-method classes] in TcInstDcls. SLPJ May 2013 + +-------- Old out of date comments, just for interest ----------- +We have to be careful when eta-expanding through newtypes. In general +it's a good idea, but annoyingly it interacts badly with the class-op +rule mechanism. Consider + + class C a where { op :: a -> a } + instance C b => C [b] where + op x = ... + +These translate to + + co :: forall a. (a->a) ~ C a + + $copList :: C b -> [b] -> [b] + $copList d x = ... + + $dfList :: C b -> C [b] + {-# DFunUnfolding = [$copList] #-} + $dfList d = $copList d |> co@[b] + +Now suppose we have: + + dCInt :: C Int + + blah :: [Int] -> [Int] + blah = op ($dfList dCInt) + +Now we want the built-in op/$dfList rule will fire to give + blah = $copList dCInt + +But with eta-expansion 'blah' might (and in #3772, which is +slightly more complicated, does) turn into + + blah = op (\eta. ($dfList dCInt |> sym co) eta) + +and now it is *much* harder for the op/$dfList rule to fire, because +exprIsConApp_maybe won't hold of the argument to op. I considered +trying to *make* it hold, but it's tricky and I gave up. + +The test simplCore/should_compile/T3722 is an excellent example. +-------- End of old out of date comments, just for interest ----------- + + +Note [exprArity for applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we come to an application we check that the arg is trivial. + eg f (fac x) does not have arity 2, + even if f has arity 3! + +* We require that is trivial rather merely cheap. Suppose f has arity 2. + Then f (Just y) + has arity 0, because if we gave it arity 1 and then inlined f we'd get + let v = Just y in \w. + which has arity 0. And we try to maintain the invariant that we don't + have arity decreases. + +* The `max 0` is important! (\x y -> f x) has arity 2, even if f is + unknown, hence arity 0 + + +************************************************************************ +* * + Computing the "arity" of an expression +* * +************************************************************************ + +Note [Definition of arity] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +The "arity" of an expression 'e' is n if + applying 'e' to *fewer* than n *value* arguments + converges rapidly + +Or, to put it another way + + there is no work lost in duplicating the partial + application (e x1 .. x(n-1)) + +In the divegent case, no work is lost by duplicating because if the thing +is evaluated once, that's the end of the program. + +Or, to put it another way, in any context C + + C[ (\x1 .. xn. e x1 .. xn) ] + is as efficient as + C[ e ] + +It's all a bit more subtle than it looks: + +Note [One-shot lambdas] +~~~~~~~~~~~~~~~~~~~~~~~ +Consider one-shot lambdas + let x = expensive in \y z -> E +We want this to have arity 1 if the \y-abstraction is a 1-shot lambda. + +Note [Dealing with bottom] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +A Big Deal with computing arities is expressions like + + f = \x -> case x of + True -> \s -> e1 + False -> \s -> e2 + +This happens all the time when f :: Bool -> IO () +In this case we do eta-expand, in order to get that \s to the +top, and give f arity 2. + +This isn't really right in the presence of seq. Consider + (f bot) `seq` 1 + +This should diverge! But if we eta-expand, it won't. We ignore this +"problem" (unless -fpedantic-bottoms is on), because being scrupulous +would lose an important transformation for many programs. (See +#5587 for an example.) + +Consider also + f = \x -> error "foo" +Here, arity 1 is fine. But if it is + f = \x -> case x of + True -> error "foo" + False -> \y -> x+y +then we want to get arity 2. Technically, this isn't quite right, because + (f True) `seq` 1 +should diverge, but it'll converge if we eta-expand f. Nevertheless, we +do so; it improves some programs significantly, and increasing convergence +isn't a bad thing. Hence the ABot/ATop in ArityType. + +So these two transformations aren't always the Right Thing, and we +have several tickets reporting unexpected behaviour resulting from +this transformation. So we try to limit it as much as possible: + + (1) Do NOT move a lambda outside a known-bottom case expression + case undefined of { (a,b) -> \y -> e } + This showed up in #5557 + + (2) Do NOT move a lambda outside a case if all the branches of + the case are known to return bottom. + case x of { (a,b) -> \y -> error "urk" } + This case is less important, but the idea is that if the fn is + going to diverge eventually anyway then getting the best arity + isn't an issue, so we might as well play safe + + (3) Do NOT move a lambda outside a case unless + (a) The scrutinee is ok-for-speculation, or + (b) more liberally: the scrutinee is cheap (e.g. a variable), and + -fpedantic-bottoms is not enforced (see #2915 for an example) + +Of course both (1) and (2) are readily defeated by disguising the bottoms. + +4. Note [Newtype arity] +~~~~~~~~~~~~~~~~~~~~~~~~ +Non-recursive newtypes are transparent, and should not get in the way. +We do (currently) eta-expand recursive newtypes too. So if we have, say + + newtype T = MkT ([T] -> Int) + +Suppose we have + e = coerce T f +where f has arity 1. Then: etaExpandArity e = 1; +that is, etaExpandArity looks through the coerce. + +When we eta-expand e to arity 1: eta_expand 1 e T +we want to get: coerce T (\x::[T] -> (coerce ([T]->Int) e) x) + + HOWEVER, note that if you use coerce bogusly you can ge + coerce Int negate + And since negate has arity 2, you might try to eta expand. But you can't + decopose Int to a function type. Hence the final case in eta_expand. + +Note [The state-transformer hack] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + f = e +where e has arity n. Then, if we know from the context that f has +a usage type like + t1 -> ... -> tn -1-> t(n+1) -1-> ... -1-> tm -> ... +then we can expand the arity to m. This usage type says that +any application (x e1 .. en) will be applied to uniquely to (m-n) more args +Consider f = \x. let y = + in case x of + True -> foo + False -> \(s:RealWorld) -> e +where foo has arity 1. Then we want the state hack to +apply to foo too, so we can eta expand the case. + +Then we expect that if f is applied to one arg, it'll be applied to two +(that's the hack -- we don't really know, and sometimes it's false) +See also Id.isOneShotBndr. + +Note [State hack and bottoming functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's a terrible idea to use the state hack on a bottoming function. +Here's what happens (#2861): + + f :: String -> IO T + f = \p. error "..." + +Eta-expand, using the state hack: + + f = \p. (\s. ((error "...") |> g1) s) |> g2 + g1 :: IO T ~ (S -> (S,T)) + g2 :: (S -> (S,T)) ~ IO T + +Extrude the g2 + + f' = \p. \s. ((error "...") |> g1) s + f = f' |> (String -> g2) + +Discard args for bottomming function + + f' = \p. \s. ((error "...") |> g1 |> g3 + g3 :: (S -> (S,T)) ~ (S,T) + +Extrude g1.g3 + + f'' = \p. \s. (error "...") + f' = f'' |> (String -> S -> g1.g3) + +And now we can repeat the whole loop. Aargh! The bug is in applying the +state hack to a function which then swallows the argument. + +This arose in another guise in #3959. Here we had + + catch# (throw exn >> return ()) + +Note that (throw :: forall a e. Exn e => e -> a) is called with [a = IO ()]. +After inlining (>>) we get + + catch# (\_. throw {IO ()} exn) + +We must *not* eta-expand to + + catch# (\_ _. throw {...} exn) + +because 'catch#' expects to get a (# _,_ #) after applying its argument to +a State#, not another function! + +In short, we use the state hack to allow us to push let inside a lambda, +but not to introduce a new lambda. + + +Note [ArityType] +~~~~~~~~~~~~~~~~ +ArityType is the result of a compositional analysis on expressions, +from which we can decide the real arity of the expression (extracted +with function exprEtaExpandArity). + +Here is what the fields mean. If an arbitrary expression 'f' has +ArityType 'at', then + + * If at = ABot n, then (f x1..xn) definitely diverges. Partial + applications to fewer than n args may *or may not* diverge. + + We allow ourselves to eta-expand bottoming functions, even + if doing so may lose some `seq` sharing, + let x = in \y. error (g x y) + ==> \y. let x = in error (g x y) + + * If at = ATop as, and n=length as, + then expanding 'f' to (\x1..xn. f x1 .. xn) loses no sharing, + assuming the calls of f respect the one-shot-ness of + its definition. + + NB 'f' is an arbitrary expression, eg (f = g e1 e2). This 'f' + can have ArityType as ATop, with length as > 0, only if e1 e2 are + themselves. + + * In both cases, f, (f x1), ... (f x1 ... f(n-1)) are definitely + really functions, or bottom, but *not* casts from a data type, in + at least one case branch. (If it's a function in one case branch but + an unsafe cast from a data type in another, the program is bogus.) + So eta expansion is dynamically ok; see Note [State hack and + bottoming functions], the part about catch# + +Example: + f = \x\y. let v = in + \s(one-shot) \t(one-shot). blah + 'f' has ArityType [ManyShot,ManyShot,OneShot,OneShot] + The one-shot-ness means we can, in effect, push that + 'let' inside the \st. + + +Suppose f = \xy. x+y +Then f :: AT [False,False] ATop + f v :: AT [False] ATop + f :: AT [] ATop + +-------------------- Main arity code ---------------------------- +-} + +-- See Note [ArityType] +data ArityType = ATop [OneShotInfo] | ABot Arity + -- There is always an explicit lambda + -- to justify the [OneShot], or the Arity + +instance Outputable ArityType where + ppr (ATop os) = text "ATop" <> parens (ppr (length os)) + ppr (ABot n) = text "ABot" <> parens (ppr n) + +vanillaArityType :: ArityType +vanillaArityType = ATop [] -- Totally uninformative + +-- ^ The Arity returned is the number of value args the +-- expression can be applied to without doing much work +exprEtaExpandArity :: DynFlags -> CoreExpr -> Arity +-- exprEtaExpandArity is used when eta expanding +-- e ==> \xy -> e x y +exprEtaExpandArity dflags e + = case (arityType env e) of + ATop oss -> length oss + ABot n -> n + where + env = AE { ae_cheap_fn = mk_cheap_fn dflags isCheapApp + , ae_ped_bot = gopt Opt_PedanticBottoms dflags } + +getBotArity :: ArityType -> Maybe Arity +-- Arity of a divergent function +getBotArity (ABot n) = Just n +getBotArity _ = Nothing + +mk_cheap_fn :: DynFlags -> CheapAppFun -> CheapFun +mk_cheap_fn dflags cheap_app + | not (gopt Opt_DictsCheap dflags) + = \e _ -> exprIsCheapX cheap_app e + | otherwise + = \e mb_ty -> exprIsCheapX cheap_app e + || case mb_ty of + Nothing -> False + Just ty -> isDictLikeTy ty + + +---------------------- +findRhsArity :: DynFlags -> Id -> CoreExpr -> Arity -> (Arity, Bool) +-- This implements the fixpoint loop for arity analysis +-- See Note [Arity analysis] +-- If findRhsArity e = (n, is_bot) then +-- (a) any application of e to (\x1..xn. e x1 .. xn) +-- (b) if is_bot=True, then e applied to n args is guaranteed bottom +findRhsArity dflags bndr rhs old_arity + = go (get_arity init_cheap_app) + -- We always call exprEtaExpandArity once, but usually + -- that produces a result equal to old_arity, and then + -- we stop right away (since arities should not decrease) + -- Result: the common case is that there is just one iteration + where + is_lam = has_lam rhs + + has_lam (Tick _ e) = has_lam e + has_lam (Lam b e) = isId b || has_lam e + has_lam _ = False + + init_cheap_app :: CheapAppFun + init_cheap_app fn n_val_args + | fn == bndr = True -- On the first pass, this binder gets infinite arity + | otherwise = isCheapApp fn n_val_args + + go :: (Arity, Bool) -> (Arity, Bool) + go cur_info@(cur_arity, _) + | cur_arity <= old_arity = cur_info + | new_arity == cur_arity = cur_info + | otherwise = ASSERT( new_arity < cur_arity ) +#if defined(DEBUG) + pprTrace "Exciting arity" + (vcat [ ppr bndr <+> ppr cur_arity <+> ppr new_arity + , ppr rhs]) +#endif + go new_info + where + new_info@(new_arity, _) = get_arity cheap_app + + cheap_app :: CheapAppFun + cheap_app fn n_val_args + | fn == bndr = n_val_args < cur_arity + | otherwise = isCheapApp fn n_val_args + + get_arity :: CheapAppFun -> (Arity, Bool) + get_arity cheap_app + = case (arityType env rhs) of + ABot n -> (n, True) + ATop (os:oss) | isOneShotInfo os || is_lam + -> (1 + length oss, False) -- Don't expand PAPs/thunks + ATop _ -> (0, False) -- Note [Eta expanding thunks] + where + env = AE { ae_cheap_fn = mk_cheap_fn dflags cheap_app + , ae_ped_bot = gopt Opt_PedanticBottoms dflags } + +{- +Note [Arity analysis] +~~~~~~~~~~~~~~~~~~~~~ +The motivating example for arity analysis is this: + + f = \x. let g = f (x+1) + in \y. ...g... + +What arity does f have? Really it should have arity 2, but a naive +look at the RHS won't see that. You need a fixpoint analysis which +says it has arity "infinity" the first time round. + +This example happens a lot; it first showed up in Andy Gill's thesis, +fifteen years ago! It also shows up in the code for 'rnf' on lists +in #4138. + +The analysis is easy to achieve because exprEtaExpandArity takes an +argument + type CheapFun = CoreExpr -> Maybe Type -> Bool +used to decide if an expression is cheap enough to push inside a +lambda. And exprIsCheapX in turn takes an argument + type CheapAppFun = Id -> Int -> Bool +which tells when an application is cheap. This makes it easy to +write the analysis loop. + +The analysis is cheap-and-cheerful because it doesn't deal with +mutual recursion. But the self-recursive case is the important one. + + +Note [Eta expanding through dictionaries] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If the experimental -fdicts-cheap flag is on, we eta-expand through +dictionary bindings. This improves arities. Thereby, it also +means that full laziness is less prone to floating out the +application of a function to its dictionary arguments, which +can thereby lose opportunities for fusion. Example: + foo :: Ord a => a -> ... + foo = /\a \(d:Ord a). let d' = ...d... in \(x:a). .... + -- So foo has arity 1 + + f = \x. foo dInt $ bar x + +The (foo DInt) is floated out, and makes ineffective a RULE + foo (bar x) = ... + +One could go further and make exprIsCheap reply True to any +dictionary-typed expression, but that's more work. + +See Note [Dictionary-like types] in TcType.hs for why we use +isDictLikeTy here rather than isDictTy + +Note [Eta expanding thunks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't eta-expand + * Trivial RHSs x = y + * PAPs x = map g + * Thunks f = case y of p -> \x -> blah + +When we see + f = case y of p -> \x -> blah +should we eta-expand it? Well, if 'x' is a one-shot state token +then 'yes' because 'f' will only be applied once. But otherwise +we (conservatively) say no. My main reason is to avoid expanding +PAPSs + f = g d ==> f = \x. g d x +because that might in turn make g inline (if it has an inline pragma), +which we might not want. After all, INLINE pragmas say "inline only +when saturated" so we don't want to be too gung-ho about saturating! +-} + +arityLam :: Id -> ArityType -> ArityType +arityLam id (ATop as) = ATop (idStateHackOneShotInfo id : as) +arityLam _ (ABot n) = ABot (n+1) + +floatIn :: Bool -> ArityType -> ArityType +-- We have something like (let x = E in b), +-- where b has the given arity type. +floatIn _ (ABot n) = ABot n +floatIn True (ATop as) = ATop as +floatIn False (ATop as) = ATop (takeWhile isOneShotInfo as) + -- If E is not cheap, keep arity only for one-shots + +arityApp :: ArityType -> Bool -> ArityType +-- Processing (fun arg) where at is the ArityType of fun, +-- Knock off an argument and behave like 'let' +arityApp (ABot 0) _ = ABot 0 +arityApp (ABot n) _ = ABot (n-1) +arityApp (ATop []) _ = ATop [] +arityApp (ATop (_:as)) cheap = floatIn cheap (ATop as) + +andArityType :: ArityType -> ArityType -> ArityType -- Used for branches of a 'case' +andArityType (ABot n1) (ABot n2) = ABot (n1 `max` n2) -- Note [ABot branches: use max] +andArityType (ATop as) (ABot _) = ATop as +andArityType (ABot _) (ATop bs) = ATop bs +andArityType (ATop as) (ATop bs) = ATop (as `combine` bs) + where -- See Note [Combining case branches] + combine (a:as) (b:bs) = (a `bestOneShot` b) : combine as bs + combine [] bs = takeWhile isOneShotInfo bs + combine as [] = takeWhile isOneShotInfo as + +{- Note [ABot branches: use max] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider case x of + True -> \x. error "urk" + False -> \xy. error "urk2" + +Remember: ABot n means "if you apply to n args, it'll definitely diverge". +So we need (ABot 2) for the whole thing, the /max/ of the ABot arities. + +Note [Combining case branches] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + go = \x. let z = go e0 + go2 = \x. case x of + True -> z + False -> \s(one-shot). e1 + in go2 x +We *really* want to eta-expand go and go2. +When combining the barnches of the case we have + ATop [] `andAT` ATop [OneShotLam] +and we want to get ATop [OneShotLam]. But if the inner +lambda wasn't one-shot we don't want to do this. +(We need a proper arity analysis to justify that.) + +So we combine the best of the two branches, on the (slightly dodgy) +basis that if we know one branch is one-shot, then they all must be. +-} + +--------------------------- +type CheapFun = CoreExpr -> Maybe Type -> Bool + -- How to decide if an expression is cheap + -- If the Maybe is Just, the type is the type + -- of the expression; Nothing means "don't know" + +data ArityEnv + = AE { ae_cheap_fn :: CheapFun + , ae_ped_bot :: Bool -- True <=> be pedantic about bottoms + } + +arityType :: ArityEnv -> CoreExpr -> ArityType + +arityType env (Cast e co) + = case arityType env e of + ATop os -> ATop (take co_arity os) + ABot n -> ABot (n `min` co_arity) + where + co_arity = length (typeArity (pSnd (coercionKind co))) + -- See Note [exprArity invariant] (2); must be true of + -- arityType too, since that is how we compute the arity + -- of variables, and they in turn affect result of exprArity + -- #5441 is a nice demo + -- However, do make sure that ATop -> ATop and ABot -> ABot! + -- Casts don't affect that part. Getting this wrong provoked #5475 + +arityType _ (Var v) + | strict_sig <- idStrictness v + , not $ isTopSig strict_sig + , (ds, res) <- splitStrictSig strict_sig + , let arity = length ds + = if isBotRes res then ABot arity + else ATop (take arity one_shots) + | otherwise + = ATop (take (idArity v) one_shots) + where + one_shots :: [OneShotInfo] -- One-shot-ness derived from the type + one_shots = typeArity (idType v) + + -- Lambdas; increase arity +arityType env (Lam x e) + | isId x = arityLam x (arityType env e) + | otherwise = arityType env e + + -- Applications; decrease arity, except for types +arityType env (App fun (Type _)) + = arityType env fun +arityType env (App fun arg ) + = arityApp (arityType env fun) (ae_cheap_fn env arg Nothing) + + -- Case/Let; keep arity if either the expression is cheap + -- or it's a 1-shot lambda + -- The former is not really right for Haskell + -- f x = case x of { (a,b) -> \y. e } + -- ===> + -- f x y = case x of { (a,b) -> e } + -- The difference is observable using 'seq' + -- +arityType env (Case scrut _ _ alts) + | exprIsBottom scrut || null alts + = ABot 0 -- Do not eta expand + -- See Note [Dealing with bottom (1)] + | otherwise + = case alts_type of + ABot n | n>0 -> ATop [] -- Don't eta expand + | otherwise -> ABot 0 -- if RHS is bottomming + -- See Note [Dealing with bottom (2)] + + ATop as | not (ae_ped_bot env) -- See Note [Dealing with bottom (3)] + , ae_cheap_fn env scrut Nothing -> ATop as + | exprOkForSpeculation scrut -> ATop as + | otherwise -> ATop (takeWhile isOneShotInfo as) + where + alts_type = foldr1 andArityType [arityType env rhs | (_,_,rhs) <- alts] + +arityType env (Let b e) + = floatIn (cheap_bind b) (arityType env e) + where + cheap_bind (NonRec b e) = is_cheap (b,e) + cheap_bind (Rec prs) = all is_cheap prs + is_cheap (b,e) = ae_cheap_fn env e (Just (idType b)) + +arityType env (Tick t e) + | not (tickishIsCode t) = arityType env e + +arityType _ _ = vanillaArityType + +{- +%************************************************************************ +%* * + The main eta-expander +%* * +%************************************************************************ + +We go for: + f = \x1..xn -> N ==> f = \x1..xn y1..ym -> N y1..ym + (n >= 0) + +where (in both cases) + + * The xi can include type variables + + * The yi are all value variables + + * N is a NORMAL FORM (i.e. no redexes anywhere) + wanting a suitable number of extra args. + +The biggest reason for doing this is for cases like + + f = \x -> case x of + True -> \y -> e1 + False -> \y -> e2 + +Here we want to get the lambdas together. A good example is the nofib +program fibheaps, which gets 25% more allocation if you don't do this +eta-expansion. + +We may have to sandwich some coerces between the lambdas +to make the types work. exprEtaExpandArity looks through coerces +when computing arity; and etaExpand adds the coerces as necessary when +actually computing the expansion. + +Note [No crap in eta-expanded code] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The eta expander is careful not to introduce "crap". In particular, +given a CoreExpr satisfying the 'CpeRhs' invariant (in CorePrep), it +returns a CoreExpr satisfying the same invariant. See Note [Eta +expansion and the CorePrep invariants] in CorePrep. + +This means the eta-expander has to do a bit of on-the-fly +simplification but it's not too hard. The alernative, of relying on +a subsequent clean-up phase of the Simplifier to de-crapify the result, +means you can't really use it in CorePrep, which is painful. + +Note [Eta expansion for join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The no-crap rule is very tiresome to guarantee when +we have join points. Consider eta-expanding + let j :: Int -> Int -> Bool + j x = e + in b + +The simple way is + \(y::Int). (let j x = e in b) y + +The no-crap way is + \(y::Int). let j' :: Int -> Bool + j' x = e y + in b[j'/j] y +where I have written to stress that j's type has +changed. Note that (of course!) we have to push the application +inside the RHS of the join as well as into the body. AND if j +has an unfolding we have to push it into there too. AND j might +be recursive... + +So for now I'm abandonig the no-crap rule in this case. I think +that for the use in CorePrep it really doesn't matter; and if +it does, then CoreToStg.myCollectArgs will fall over. + +(Moreover, I think that casts can make the no-crap rule fail too.) + +Note [Eta expansion and SCCs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note that SCCs are not treated specially by etaExpand. If we have + etaExpand 2 (\x -> scc "foo" e) + = (\xy -> (scc "foo" e) y) +So the costs of evaluating 'e' (not 'e y') are attributed to "foo" + +Note [Eta expansion and source notes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +CorePrep puts floatable ticks outside of value applications, but not +type applications. As a result we might be trying to eta-expand an +expression like + + (src<...> v) @a + +which we want to lead to code like + + \x -> src<...> v @a x + +This means that we need to look through type applications and be ready +to re-add floats on the top. + +-} + +-- | @etaExpand n e@ returns an expression with +-- the same meaning as @e@, but with arity @n@. +-- +-- Given: +-- +-- > e' = etaExpand n e +-- +-- We should have that: +-- +-- > ty = exprType e = exprType e' +etaExpand :: Arity -- ^ Result should have this number of value args + -> CoreExpr -- ^ Expression to expand + -> CoreExpr +-- etaExpand arity e = res +-- Then 'res' has at least 'arity' lambdas at the top +-- +-- etaExpand deals with for-alls. For example: +-- etaExpand 1 E +-- where E :: forall a. a -> a +-- would return +-- (/\b. \y::a -> E b y) +-- +-- It deals with coerces too, though they are now rare +-- so perhaps the extra code isn't worth it + +etaExpand n orig_expr + = go n orig_expr + where + -- Strip off existing lambdas and casts + -- Note [Eta expansion and SCCs] + go 0 expr = expr + go n (Lam v body) | isTyVar v = Lam v (go n body) + | otherwise = Lam v (go (n-1) body) + go n (Cast expr co) = Cast (go n expr) co + go n expr + = -- pprTrace "ee" (vcat [ppr orig_expr, ppr expr, ppr etas]) $ + retick $ etaInfoAbs etas (etaInfoApp subst' sexpr etas) + where + in_scope = mkInScopeSet (exprFreeVars expr) + (in_scope', etas) = mkEtaWW n orig_expr in_scope (exprType expr) + subst' = mkEmptySubst in_scope' + + -- Find ticks behind type apps. + -- See Note [Eta expansion and source notes] + (expr', args) = collectArgs expr + (ticks, expr'') = stripTicksTop tickishFloatable expr' + sexpr = foldl' App expr'' args + retick expr = foldr mkTick expr ticks + + -- Abstraction Application +-------------- +data EtaInfo = EtaVar Var -- /\a. [] [] a + -- \x. [] [] x + | EtaCo Coercion -- [] |> sym co [] |> co + +instance Outputable EtaInfo where + ppr (EtaVar v) = text "EtaVar" <+> ppr v + ppr (EtaCo co) = text "EtaCo" <+> ppr co + +pushCoercion :: Coercion -> [EtaInfo] -> [EtaInfo] +pushCoercion co1 (EtaCo co2 : eis) + | isReflCo co = eis + | otherwise = EtaCo co : eis + where + co = co1 `mkTransCo` co2 + +pushCoercion co eis = EtaCo co : eis + +-------------- +etaInfoAbs :: [EtaInfo] -> CoreExpr -> CoreExpr +etaInfoAbs [] expr = expr +etaInfoAbs (EtaVar v : eis) expr = Lam v (etaInfoAbs eis expr) +etaInfoAbs (EtaCo co : eis) expr = Cast (etaInfoAbs eis expr) (mkSymCo co) + +-------------- +etaInfoApp :: Subst -> CoreExpr -> [EtaInfo] -> CoreExpr +-- (etaInfoApp s e eis) returns something equivalent to +-- ((substExpr s e) `appliedto` eis) + +etaInfoApp subst (Lam v1 e) (EtaVar v2 : eis) + = etaInfoApp (CoreSubst.extendSubstWithVar subst v1 v2) e eis + +etaInfoApp subst (Cast e co1) eis + = etaInfoApp subst e (pushCoercion co' eis) + where + co' = CoreSubst.substCo subst co1 + +etaInfoApp subst (Case e b ty alts) eis + = Case (subst_expr subst e) b1 ty' alts' + where + (subst1, b1) = substBndr subst b + alts' = map subst_alt alts + ty' = etaInfoAppTy (CoreSubst.substTy subst ty) eis + subst_alt (con, bs, rhs) = (con, bs', etaInfoApp subst2 rhs eis) + where + (subst2,bs') = substBndrs subst1 bs + +etaInfoApp subst (Let b e) eis + | not (isJoinBind b) + -- See Note [Eta expansion for join points] + = Let b' (etaInfoApp subst' e eis) + where + (subst', b') = substBindSC subst b + +etaInfoApp subst (Tick t e) eis + = Tick (substTickish subst t) (etaInfoApp subst e eis) + +etaInfoApp subst expr _ + | (Var fun, _) <- collectArgs expr + , Var fun' <- lookupIdSubst (text "etaInfoApp" <+> ppr fun) subst fun + , isJoinId fun' + = subst_expr subst expr + +etaInfoApp subst e eis + = go (subst_expr subst e) eis + where + go e [] = e + go e (EtaVar v : eis) = go (App e (varToCoreExpr v)) eis + go e (EtaCo co : eis) = go (Cast e co) eis + + +-------------- +etaInfoAppTy :: Type -> [EtaInfo] -> Type +-- If e :: ty +-- then etaInfoApp e eis :: etaInfoApp ty eis +etaInfoAppTy ty [] = ty +etaInfoAppTy ty (EtaVar v : eis) = etaInfoAppTy (applyTypeToArg ty (varToCoreExpr v)) eis +etaInfoAppTy _ (EtaCo co : eis) = etaInfoAppTy (pSnd (coercionKind co)) eis + +-------------- +mkEtaWW :: Arity -> CoreExpr -> InScopeSet -> Type + -> (InScopeSet, [EtaInfo]) + -- EtaInfo contains fresh variables, + -- not free in the incoming CoreExpr + -- Outgoing InScopeSet includes the EtaInfo vars + -- and the original free vars + +mkEtaWW orig_n orig_expr in_scope orig_ty + = go orig_n empty_subst orig_ty [] + where + empty_subst = mkEmptyTCvSubst in_scope + + go n subst ty eis -- See Note [exprArity invariant] + | n == 0 + = (getTCvInScope subst, reverse eis) + + | Just (tcv,ty') <- splitForAllTy_maybe ty + , let (subst', tcv') = Type.substVarBndr subst tcv + = let ((n_subst, n_tcv), n_n) + -- We want to have at least 'n' lambdas at the top. + -- If tcv is a tyvar, it corresponds to one Lambda (/\). + -- And we won't reduce n. + -- If tcv is a covar, we could eta-expand the expr with one + -- lambda \co:ty. e co. In this case we generate a new variable + -- of the coercion type, update the scope, and reduce n by 1. + | isTyVar tcv = ((subst', tcv'), n) + | otherwise = (freshEtaId n subst' (varType tcv'), n-1) + -- Avoid free vars of the original expression + in go n_n n_subst ty' (EtaVar n_tcv : eis) + + | Just (arg_ty, res_ty) <- splitFunTy_maybe ty + , not (isTypeLevPoly arg_ty) + -- See Note [Levity polymorphism invariants] in CoreSyn + -- See also test case typecheck/should_run/EtaExpandLevPoly + + , let (subst', eta_id') = freshEtaId n subst arg_ty + -- Avoid free vars of the original expression + = go (n-1) subst' res_ty (EtaVar eta_id' : eis) + + | Just (co, ty') <- topNormaliseNewType_maybe ty + = -- Given this: + -- newtype T = MkT ([T] -> Int) + -- Consider eta-expanding this + -- eta_expand 1 e T + -- We want to get + -- coerce T (\x::[T] -> (coerce ([T]->Int) e) x) + go n subst ty' (pushCoercion co eis) + + | otherwise -- We have an expression of arity > 0, + -- but its type isn't a function, or a binder + -- is levity-polymorphic + = WARN( True, (ppr orig_n <+> ppr orig_ty) $$ ppr orig_expr ) + (getTCvInScope subst, reverse eis) + -- This *can* legitmately happen: + -- e.g. coerce Int (\x. x) Essentially the programmer is + -- playing fast and loose with types (Happy does this a lot). + -- So we simply decline to eta-expand. Otherwise we'd end up + -- with an explicit lambda having a non-function type + + + +-------------- +-- Don't use short-cutting substitution - we may be changing the types of join +-- points, so applying the in-scope set is necessary +-- TODO Check if we actually *are* changing any join points' types + +subst_expr :: Subst -> CoreExpr -> CoreExpr +subst_expr = substExpr (text "CoreArity:substExpr") + + +-------------- + +-- | Split an expression into the given number of binders and a body, +-- eta-expanding if necessary. Counts value *and* type binders. +etaExpandToJoinPoint :: JoinArity -> CoreExpr -> ([CoreBndr], CoreExpr) +etaExpandToJoinPoint join_arity expr + = go join_arity [] expr + where + go 0 rev_bs e = (reverse rev_bs, e) + go n rev_bs (Lam b e) = go (n-1) (b : rev_bs) e + go n rev_bs e = case etaBodyForJoinPoint n e of + (bs, e') -> (reverse rev_bs ++ bs, e') + +etaExpandToJoinPointRule :: JoinArity -> CoreRule -> CoreRule +etaExpandToJoinPointRule _ rule@(BuiltinRule {}) + = WARN(True, (sep [text "Can't eta-expand built-in rule:", ppr rule])) + -- How did a local binding get a built-in rule anyway? Probably a plugin. + rule +etaExpandToJoinPointRule join_arity rule@(Rule { ru_bndrs = bndrs, ru_rhs = rhs + , ru_args = args }) + | need_args == 0 + = rule + | need_args < 0 + = pprPanic "etaExpandToJoinPointRule" (ppr join_arity $$ ppr rule) + | otherwise + = rule { ru_bndrs = bndrs ++ new_bndrs, ru_args = args ++ new_args + , ru_rhs = new_rhs } + where + need_args = join_arity - length args + (new_bndrs, new_rhs) = etaBodyForJoinPoint need_args rhs + new_args = varsToCoreExprs new_bndrs + +-- Adds as many binders as asked for; assumes expr is not a lambda +etaBodyForJoinPoint :: Int -> CoreExpr -> ([CoreBndr], CoreExpr) +etaBodyForJoinPoint need_args body + = go need_args (exprType body) (init_subst body) [] body + where + go 0 _ _ rev_bs e + = (reverse rev_bs, e) + go n ty subst rev_bs e + | Just (tv, res_ty) <- splitForAllTy_maybe ty + , let (subst', tv') = Type.substVarBndr subst tv + = go (n-1) res_ty subst' (tv' : rev_bs) (e `App` varToCoreExpr tv') + | Just (arg_ty, res_ty) <- splitFunTy_maybe ty + , let (subst', b) = freshEtaId n subst arg_ty + = go (n-1) res_ty subst' (b : rev_bs) (e `App` Var b) + | otherwise + = pprPanic "etaBodyForJoinPoint" $ int need_args $$ + ppr body $$ ppr (exprType body) + + init_subst e = mkEmptyTCvSubst (mkInScopeSet (exprFreeVars e)) + +-------------- +freshEtaId :: Int -> TCvSubst -> Type -> (TCvSubst, Id) +-- Make a fresh Id, with specified type (after applying substitution) +-- It should be "fresh" in the sense that it's not in the in-scope set +-- of the TvSubstEnv; and it should itself then be added to the in-scope +-- set of the TvSubstEnv +-- +-- The Int is just a reasonable starting point for generating a unique; +-- it does not necessarily have to be unique itself. +freshEtaId n subst ty + = (subst', eta_id') + where + ty' = Type.substTyUnchecked subst ty + eta_id' = uniqAway (getTCvInScope subst) $ + mkSysLocalOrCoVar (fsLit "eta") (mkBuiltinUnique n) ty' + subst' = extendTCvInScope subst eta_id' diff --git a/compiler/coreSyn/CoreFVs.hs b/compiler/coreSyn/CoreFVs.hs new file mode 100644 --- /dev/null +++ b/compiler/coreSyn/CoreFVs.hs @@ -0,0 +1,777 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +Taken quite directly from the Peyton Jones/Lester paper. +-} + +{-# LANGUAGE CPP #-} + +-- | A module concerned with finding the free variables of an expression. +module CoreFVs ( + -- * Free variables of expressions and binding groups + exprFreeVars, + exprFreeVarsDSet, + exprFreeVarsList, + exprFreeIds, + exprFreeIdsDSet, + exprFreeIdsList, + exprsFreeIdsDSet, + exprsFreeIdsList, + exprsFreeVars, + exprsFreeVarsList, + bindFreeVars, + + -- * Selective free variables of expressions + InterestingVarFun, + exprSomeFreeVars, exprsSomeFreeVars, + exprSomeFreeVarsList, exprsSomeFreeVarsList, + + -- * Free variables of Rules, Vars and Ids + varTypeTyCoVars, + varTypeTyCoFVs, + idUnfoldingVars, idFreeVars, dIdFreeVars, + bndrRuleAndUnfoldingVarsDSet, + idFVs, + idRuleVars, idRuleRhsVars, stableUnfoldingVars, + ruleRhsFreeVars, ruleFreeVars, rulesFreeVars, + rulesFreeVarsDSet, + ruleLhsFreeIds, ruleLhsFreeIdsList, + + expr_fvs, + + -- * Orphan names + orphNamesOfType, orphNamesOfCo, orphNamesOfAxiom, + orphNamesOfTypes, orphNamesOfCoCon, + exprsOrphNames, orphNamesOfFamInst, + + -- * Core syntax tree annotation with free variables + FVAnn, -- annotation, abstract + CoreExprWithFVs, -- = AnnExpr Id FVAnn + CoreExprWithFVs', -- = AnnExpr' Id FVAnn + CoreBindWithFVs, -- = AnnBind Id FVAnn + CoreAltWithFVs, -- = AnnAlt Id FVAnn + freeVars, -- CoreExpr -> CoreExprWithFVs + freeVarsBind, -- CoreBind -> DVarSet -> (DVarSet, CoreBindWithFVs) + freeVarsOf, -- CoreExprWithFVs -> DIdSet + freeVarsOfAnn + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import CoreSyn +import Id +import IdInfo +import NameSet +import UniqSet +import Unique (Uniquable (..)) +import Name +import VarSet +import Var +import Type +import TyCoRep +import TyCon +import CoAxiom +import FamInstEnv +import TysPrim( funTyConName ) +import Maybes( orElse ) +import Util +import BasicTypes( Activation ) +import Outputable +import FV + +{- +************************************************************************ +* * +\section{Finding the free variables of an expression} +* * +************************************************************************ + +This function simply finds the free variables of an expression. +So far as type variables are concerned, it only finds tyvars that are + + * free in type arguments, + * free in the type of a binder, + +but not those that are free in the type of variable occurrence. +-} + +-- | Find all locally-defined free Ids or type variables in an expression +-- returning a non-deterministic set. +exprFreeVars :: CoreExpr -> VarSet +exprFreeVars = fvVarSet . exprFVs + +-- | Find all locally-defined free Ids or type variables in an expression +-- returning a composable FV computation. See Note [FV naming conventions] in FV +-- for why export it. +exprFVs :: CoreExpr -> FV +exprFVs = filterFV isLocalVar . expr_fvs + +-- | Find all locally-defined free Ids or type variables in an expression +-- returning a deterministic set. +exprFreeVarsDSet :: CoreExpr -> DVarSet +exprFreeVarsDSet = fvDVarSet . exprFVs + +-- | Find all locally-defined free Ids or type variables in an expression +-- returning a deterministically ordered list. +exprFreeVarsList :: CoreExpr -> [Var] +exprFreeVarsList = fvVarList . exprFVs + +-- | Find all locally-defined free Ids in an expression +exprFreeIds :: CoreExpr -> IdSet -- Find all locally-defined free Ids +exprFreeIds = exprSomeFreeVars isLocalId + +-- | Find all locally-defined free Ids in an expression +-- returning a deterministic set. +exprFreeIdsDSet :: CoreExpr -> DIdSet -- Find all locally-defined free Ids +exprFreeIdsDSet = exprSomeFreeVarsDSet isLocalId + +-- | Find all locally-defined free Ids in an expression +-- returning a deterministically ordered list. +exprFreeIdsList :: CoreExpr -> [Id] -- Find all locally-defined free Ids +exprFreeIdsList = exprSomeFreeVarsList isLocalId + +-- | Find all locally-defined free Ids in several expressions +-- returning a deterministic set. +exprsFreeIdsDSet :: [CoreExpr] -> DIdSet -- Find all locally-defined free Ids +exprsFreeIdsDSet = exprsSomeFreeVarsDSet isLocalId + +-- | Find all locally-defined free Ids in several expressions +-- returning a deterministically ordered list. +exprsFreeIdsList :: [CoreExpr] -> [Id] -- Find all locally-defined free Ids +exprsFreeIdsList = exprsSomeFreeVarsList isLocalId + +-- | Find all locally-defined free Ids or type variables in several expressions +-- returning a non-deterministic set. +exprsFreeVars :: [CoreExpr] -> VarSet +exprsFreeVars = fvVarSet . exprsFVs + +-- | Find all locally-defined free Ids or type variables in several expressions +-- returning a composable FV computation. See Note [FV naming conventions] in FV +-- for why export it. +exprsFVs :: [CoreExpr] -> FV +exprsFVs exprs = mapUnionFV exprFVs exprs + +-- | Find all locally-defined free Ids or type variables in several expressions +-- returning a deterministically ordered list. +exprsFreeVarsList :: [CoreExpr] -> [Var] +exprsFreeVarsList = fvVarList . exprsFVs + +-- | Find all locally defined free Ids in a binding group +bindFreeVars :: CoreBind -> VarSet +bindFreeVars (NonRec b r) = fvVarSet $ filterFV isLocalVar $ rhs_fvs (b,r) +bindFreeVars (Rec prs) = fvVarSet $ filterFV isLocalVar $ + addBndrs (map fst prs) + (mapUnionFV rhs_fvs prs) + +-- | Finds free variables in an expression selected by a predicate +exprSomeFreeVars :: InterestingVarFun -- ^ Says which 'Var's are interesting + -> CoreExpr + -> VarSet +exprSomeFreeVars fv_cand e = fvVarSet $ filterFV fv_cand $ expr_fvs e + +-- | Finds free variables in an expression selected by a predicate +-- returning a deterministically ordered list. +exprSomeFreeVarsList :: InterestingVarFun -- ^ Says which 'Var's are interesting + -> CoreExpr + -> [Var] +exprSomeFreeVarsList fv_cand e = fvVarList $ filterFV fv_cand $ expr_fvs e + +-- | Finds free variables in an expression selected by a predicate +-- returning a deterministic set. +exprSomeFreeVarsDSet :: InterestingVarFun -- ^ Says which 'Var's are interesting + -> CoreExpr + -> DVarSet +exprSomeFreeVarsDSet fv_cand e = fvDVarSet $ filterFV fv_cand $ expr_fvs e + +-- | Finds free variables in several expressions selected by a predicate +exprsSomeFreeVars :: InterestingVarFun -- Says which 'Var's are interesting + -> [CoreExpr] + -> VarSet +exprsSomeFreeVars fv_cand es = + fvVarSet $ filterFV fv_cand $ mapUnionFV expr_fvs es + +-- | Finds free variables in several expressions selected by a predicate +-- returning a deterministically ordered list. +exprsSomeFreeVarsList :: InterestingVarFun -- Says which 'Var's are interesting + -> [CoreExpr] + -> [Var] +exprsSomeFreeVarsList fv_cand es = + fvVarList $ filterFV fv_cand $ mapUnionFV expr_fvs es + +-- | Finds free variables in several expressions selected by a predicate +-- returning a deterministic set. +exprsSomeFreeVarsDSet :: InterestingVarFun -- ^ Says which 'Var's are interesting + -> [CoreExpr] + -> DVarSet +exprsSomeFreeVarsDSet fv_cand e = + fvDVarSet $ filterFV fv_cand $ mapUnionFV expr_fvs e + +-- Comment about obselete code +-- We used to gather the free variables the RULES at a variable occurrence +-- with the following cryptic comment: +-- "At a variable occurrence, add in any free variables of its rule rhss +-- Curiously, we gather the Id's free *type* variables from its binding +-- site, but its free *rule-rhs* variables from its usage sites. This +-- is a little weird. The reason is that the former is more efficient, +-- but the latter is more fine grained, and a makes a difference when +-- a variable mentions itself one of its own rule RHSs" +-- Not only is this "weird", but it's also pretty bad because it can make +-- a function seem more recursive than it is. Suppose +-- f = ...g... +-- g = ... +-- RULE g x = ...f... +-- Then f is not mentioned in its own RHS, and needn't be a loop breaker +-- (though g may be). But if we collect the rule fvs from g's occurrence, +-- it looks as if f mentions itself. (This bites in the eftInt/eftIntFB +-- code in GHC.Enum.) +-- +-- Anyway, it seems plain wrong. The RULE is like an extra RHS for the +-- function, so its free variables belong at the definition site. +-- +-- Deleted code looked like +-- foldVarSet add_rule_var var_itself_set (idRuleVars var) +-- add_rule_var var set | keep_it fv_cand in_scope var = extendVarSet set var +-- | otherwise = set +-- SLPJ Feb06 + +addBndr :: CoreBndr -> FV -> FV +addBndr bndr fv fv_cand in_scope acc + = (varTypeTyCoFVs bndr `unionFV` + -- Include type variables in the binder's type + -- (not just Ids; coercion variables too!) + FV.delFV bndr fv) fv_cand in_scope acc + +addBndrs :: [CoreBndr] -> FV -> FV +addBndrs bndrs fv = foldr addBndr fv bndrs + +expr_fvs :: CoreExpr -> FV +expr_fvs (Type ty) fv_cand in_scope acc = + tyCoFVsOfType ty fv_cand in_scope acc +expr_fvs (Coercion co) fv_cand in_scope acc = + tyCoFVsOfCo co fv_cand in_scope acc +expr_fvs (Var var) fv_cand in_scope acc = FV.unitFV var fv_cand in_scope acc +expr_fvs (Lit _) fv_cand in_scope acc = emptyFV fv_cand in_scope acc +expr_fvs (Tick t expr) fv_cand in_scope acc = + (tickish_fvs t `unionFV` expr_fvs expr) fv_cand in_scope acc +expr_fvs (App fun arg) fv_cand in_scope acc = + (expr_fvs fun `unionFV` expr_fvs arg) fv_cand in_scope acc +expr_fvs (Lam bndr body) fv_cand in_scope acc = + addBndr bndr (expr_fvs body) fv_cand in_scope acc +expr_fvs (Cast expr co) fv_cand in_scope acc = + (expr_fvs expr `unionFV` tyCoFVsOfCo co) fv_cand in_scope acc + +expr_fvs (Case scrut bndr ty alts) fv_cand in_scope acc + = (expr_fvs scrut `unionFV` tyCoFVsOfType ty `unionFV` addBndr bndr + (mapUnionFV alt_fvs alts)) fv_cand in_scope acc + where + alt_fvs (_, bndrs, rhs) = addBndrs bndrs (expr_fvs rhs) + +expr_fvs (Let (NonRec bndr rhs) body) fv_cand in_scope acc + = (rhs_fvs (bndr, rhs) `unionFV` addBndr bndr (expr_fvs body)) + fv_cand in_scope acc + +expr_fvs (Let (Rec pairs) body) fv_cand in_scope acc + = addBndrs (map fst pairs) + (mapUnionFV rhs_fvs pairs `unionFV` expr_fvs body) + fv_cand in_scope acc + +--------- +rhs_fvs :: (Id, CoreExpr) -> FV +rhs_fvs (bndr, rhs) = expr_fvs rhs `unionFV` + bndrRuleAndUnfoldingFVs bndr + -- Treat any RULES as extra RHSs of the binding + +--------- +exprs_fvs :: [CoreExpr] -> FV +exprs_fvs exprs = mapUnionFV expr_fvs exprs + +tickish_fvs :: Tickish Id -> FV +tickish_fvs (Breakpoint _ ids) = FV.mkFVs ids +tickish_fvs _ = emptyFV + +{- +************************************************************************ +* * +\section{Free names} +* * +************************************************************************ +-} + +-- | Finds the free /external/ names of an expression, notably +-- including the names of type constructors (which of course do not show +-- up in 'exprFreeVars'). +exprOrphNames :: CoreExpr -> NameSet +-- There's no need to delete local binders, because they will all +-- be /internal/ names. +exprOrphNames e + = go e + where + go (Var v) + | isExternalName n = unitNameSet n + | otherwise = emptyNameSet + where n = idName v + go (Lit _) = emptyNameSet + go (Type ty) = orphNamesOfType ty -- Don't need free tyvars + go (Coercion co) = orphNamesOfCo co + go (App e1 e2) = go e1 `unionNameSet` go e2 + go (Lam v e) = go e `delFromNameSet` idName v + go (Tick _ e) = go e + go (Cast e co) = go e `unionNameSet` orphNamesOfCo co + go (Let (NonRec _ r) e) = go e `unionNameSet` go r + go (Let (Rec prs) e) = exprsOrphNames (map snd prs) `unionNameSet` go e + go (Case e _ ty as) = go e `unionNameSet` orphNamesOfType ty + `unionNameSet` unionNameSets (map go_alt as) + + go_alt (_,_,r) = go r + +-- | Finds the free /external/ names of several expressions: see 'exprOrphNames' for details +exprsOrphNames :: [CoreExpr] -> NameSet +exprsOrphNames es = foldr (unionNameSet . exprOrphNames) emptyNameSet es + + +{- ********************************************************************** +%* * + orphNamesXXX + +%* * +%********************************************************************* -} + +orphNamesOfTyCon :: TyCon -> NameSet +orphNamesOfTyCon tycon = unitNameSet (getName tycon) `unionNameSet` case tyConClass_maybe tycon of + Nothing -> emptyNameSet + Just cls -> unitNameSet (getName cls) + +orphNamesOfType :: Type -> NameSet +orphNamesOfType ty | Just ty' <- coreView ty = orphNamesOfType ty' + -- Look through type synonyms (#4912) +orphNamesOfType (TyVarTy _) = emptyNameSet +orphNamesOfType (LitTy {}) = emptyNameSet +orphNamesOfType (TyConApp tycon tys) = orphNamesOfTyCon tycon + `unionNameSet` orphNamesOfTypes tys +orphNamesOfType (ForAllTy bndr res) = orphNamesOfType (binderType bndr) + `unionNameSet` orphNamesOfType res +orphNamesOfType (FunTy _ arg res) = unitNameSet funTyConName -- NB! See #8535 + `unionNameSet` orphNamesOfType arg + `unionNameSet` orphNamesOfType res +orphNamesOfType (AppTy fun arg) = orphNamesOfType fun `unionNameSet` orphNamesOfType arg +orphNamesOfType (CastTy ty co) = orphNamesOfType ty `unionNameSet` orphNamesOfCo co +orphNamesOfType (CoercionTy co) = orphNamesOfCo co + +orphNamesOfThings :: (a -> NameSet) -> [a] -> NameSet +orphNamesOfThings f = foldr (unionNameSet . f) emptyNameSet + +orphNamesOfTypes :: [Type] -> NameSet +orphNamesOfTypes = orphNamesOfThings orphNamesOfType + +orphNamesOfMCo :: MCoercion -> NameSet +orphNamesOfMCo MRefl = emptyNameSet +orphNamesOfMCo (MCo co) = orphNamesOfCo co + +orphNamesOfCo :: Coercion -> NameSet +orphNamesOfCo (Refl ty) = orphNamesOfType ty +orphNamesOfCo (GRefl _ ty mco) = orphNamesOfType ty `unionNameSet` orphNamesOfMCo mco +orphNamesOfCo (TyConAppCo _ tc cos) = unitNameSet (getName tc) `unionNameSet` orphNamesOfCos cos +orphNamesOfCo (AppCo co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2 +orphNamesOfCo (ForAllCo _ kind_co co) + = orphNamesOfCo kind_co `unionNameSet` orphNamesOfCo co +orphNamesOfCo (FunCo _ co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2 +orphNamesOfCo (CoVarCo _) = emptyNameSet +orphNamesOfCo (AxiomInstCo con _ cos) = orphNamesOfCoCon con `unionNameSet` orphNamesOfCos cos +orphNamesOfCo (UnivCo p _ t1 t2) = orphNamesOfProv p `unionNameSet` orphNamesOfType t1 `unionNameSet` orphNamesOfType t2 +orphNamesOfCo (SymCo co) = orphNamesOfCo co +orphNamesOfCo (TransCo co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2 +orphNamesOfCo (NthCo _ _ co) = orphNamesOfCo co +orphNamesOfCo (LRCo _ co) = orphNamesOfCo co +orphNamesOfCo (InstCo co arg) = orphNamesOfCo co `unionNameSet` orphNamesOfCo arg +orphNamesOfCo (KindCo co) = orphNamesOfCo co +orphNamesOfCo (SubCo co) = orphNamesOfCo co +orphNamesOfCo (AxiomRuleCo _ cs) = orphNamesOfCos cs +orphNamesOfCo (HoleCo _) = emptyNameSet + +orphNamesOfProv :: UnivCoProvenance -> NameSet +orphNamesOfProv UnsafeCoerceProv = emptyNameSet +orphNamesOfProv (PhantomProv co) = orphNamesOfCo co +orphNamesOfProv (ProofIrrelProv co) = orphNamesOfCo co +orphNamesOfProv (PluginProv _) = emptyNameSet + +orphNamesOfCos :: [Coercion] -> NameSet +orphNamesOfCos = orphNamesOfThings orphNamesOfCo + +orphNamesOfCoCon :: CoAxiom br -> NameSet +orphNamesOfCoCon (CoAxiom { co_ax_tc = tc, co_ax_branches = branches }) + = orphNamesOfTyCon tc `unionNameSet` orphNamesOfCoAxBranches branches + +orphNamesOfAxiom :: CoAxiom br -> NameSet +orphNamesOfAxiom axiom + = orphNamesOfTypes (concatMap coAxBranchLHS $ fromBranches $ coAxiomBranches axiom) + `extendNameSet` getName (coAxiomTyCon axiom) + +orphNamesOfCoAxBranches :: Branches br -> NameSet +orphNamesOfCoAxBranches + = foldr (unionNameSet . orphNamesOfCoAxBranch) emptyNameSet . fromBranches + +orphNamesOfCoAxBranch :: CoAxBranch -> NameSet +orphNamesOfCoAxBranch (CoAxBranch { cab_lhs = lhs, cab_rhs = rhs }) + = orphNamesOfTypes lhs `unionNameSet` orphNamesOfType rhs + +-- | orphNamesOfAxiom collects the names of the concrete types and +-- type constructors that make up the LHS of a type family instance, +-- including the family name itself. +-- +-- For instance, given `type family Foo a b`: +-- `type instance Foo (F (G (H a))) b = ...` would yield [Foo,F,G,H] +-- +-- Used in the implementation of ":info" in GHCi. +orphNamesOfFamInst :: FamInst -> NameSet +orphNamesOfFamInst fam_inst = orphNamesOfAxiom (famInstAxiom fam_inst) + +{- +************************************************************************ +* * +\section[freevars-everywhere]{Attaching free variables to every sub-expression} +* * +************************************************************************ +-} + +-- | Those variables free in the right hand side of a rule returned as a +-- non-deterministic set +ruleRhsFreeVars :: CoreRule -> VarSet +ruleRhsFreeVars (BuiltinRule {}) = noFVs +ruleRhsFreeVars (Rule { ru_fn = _, ru_bndrs = bndrs, ru_rhs = rhs }) + = fvVarSet $ filterFV isLocalVar $ addBndrs bndrs (expr_fvs rhs) + -- See Note [Rule free var hack] + +-- | Those variables free in the both the left right hand sides of a rule +-- returned as a non-deterministic set +ruleFreeVars :: CoreRule -> VarSet +ruleFreeVars = fvVarSet . ruleFVs + +-- | Those variables free in the both the left right hand sides of a rule +-- returned as FV computation +ruleFVs :: CoreRule -> FV +ruleFVs (BuiltinRule {}) = emptyFV +ruleFVs (Rule { ru_fn = _do_not_include + -- See Note [Rule free var hack] + , ru_bndrs = bndrs + , ru_rhs = rhs, ru_args = args }) + = filterFV isLocalVar $ addBndrs bndrs (exprs_fvs (rhs:args)) + +-- | Those variables free in the both the left right hand sides of rules +-- returned as FV computation +rulesFVs :: [CoreRule] -> FV +rulesFVs = mapUnionFV ruleFVs + +-- | Those variables free in the both the left right hand sides of rules +-- returned as a deterministic set +rulesFreeVarsDSet :: [CoreRule] -> DVarSet +rulesFreeVarsDSet rules = fvDVarSet $ rulesFVs rules + +idRuleRhsVars :: (Activation -> Bool) -> Id -> VarSet +-- Just the variables free on the *rhs* of a rule +idRuleRhsVars is_active id + = mapUnionVarSet get_fvs (idCoreRules id) + where + get_fvs (Rule { ru_fn = fn, ru_bndrs = bndrs + , ru_rhs = rhs, ru_act = act }) + | is_active act + -- See Note [Finding rule RHS free vars] in OccAnal.hs + = delOneFromUniqSet_Directly fvs (getUnique fn) + -- Note [Rule free var hack] + where + fvs = fvVarSet $ filterFV isLocalVar $ addBndrs bndrs (expr_fvs rhs) + get_fvs _ = noFVs + +-- | Those variables free in the right hand side of several rules +rulesFreeVars :: [CoreRule] -> VarSet +rulesFreeVars rules = mapUnionVarSet ruleFreeVars rules + +ruleLhsFreeIds :: CoreRule -> VarSet +-- ^ This finds all locally-defined free Ids on the left hand side of a rule +-- and returns them as a non-deterministic set +ruleLhsFreeIds = fvVarSet . ruleLhsFVIds + +ruleLhsFreeIdsList :: CoreRule -> [Var] +-- ^ This finds all locally-defined free Ids on the left hand side of a rule +-- and returns them as a determinisitcally ordered list +ruleLhsFreeIdsList = fvVarList . ruleLhsFVIds + +ruleLhsFVIds :: CoreRule -> FV +-- ^ This finds all locally-defined free Ids on the left hand side of a rule +-- and returns an FV computation +ruleLhsFVIds (BuiltinRule {}) = emptyFV +ruleLhsFVIds (Rule { ru_bndrs = bndrs, ru_args = args }) + = filterFV isLocalId $ addBndrs bndrs (exprs_fvs args) + +{- +Note [Rule free var hack] (Not a hack any more) +~~~~~~~~~~~~~~~~~~~~~~~~~ +We used not to include the Id in its own rhs free-var set. +Otherwise the occurrence analyser makes bindings recursive: + f x y = x+y + RULE: f (f x y) z ==> f x (f y z) +However, the occurrence analyser distinguishes "non-rule loop breakers" +from "rule-only loop breakers" (see BasicTypes.OccInfo). So it will +put this 'f' in a Rec block, but will mark the binding as a non-rule loop +breaker, which is perfectly inlinable. +-} + +{- +************************************************************************ +* * +\section[freevars-everywhere]{Attaching free variables to every sub-expression} +* * +************************************************************************ + +The free variable pass annotates every node in the expression with its +NON-GLOBAL free variables and type variables. +-} + +type FVAnn = DVarSet -- See Note [The FVAnn invariant] + +{- Note [The FVAnn invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Invariant: a FVAnn, say S, is closed: + That is: if v is in S, + then freevars( v's type/kind ) is also in S +-} + +-- | Every node in a binding group annotated with its +-- (non-global) free variables, both Ids and TyVars, and type. +type CoreBindWithFVs = AnnBind Id FVAnn + +-- | Every node in an expression annotated with its +-- (non-global) free variables, both Ids and TyVars, and type. +-- NB: see Note [The FVAnn invariant] +type CoreExprWithFVs = AnnExpr Id FVAnn +type CoreExprWithFVs' = AnnExpr' Id FVAnn + +-- | Every node in an expression annotated with its +-- (non-global) free variables, both Ids and TyVars, and type. +type CoreAltWithFVs = AnnAlt Id FVAnn + +freeVarsOf :: CoreExprWithFVs -> DIdSet +-- ^ Inverse function to 'freeVars' +freeVarsOf (fvs, _) = fvs + +-- | Extract the vars reported in a FVAnn +freeVarsOfAnn :: FVAnn -> DIdSet +freeVarsOfAnn fvs = fvs + +noFVs :: VarSet +noFVs = emptyVarSet + +aFreeVar :: Var -> DVarSet +aFreeVar = unitDVarSet + +unionFVs :: DVarSet -> DVarSet -> DVarSet +unionFVs = unionDVarSet + +unionFVss :: [DVarSet] -> DVarSet +unionFVss = unionDVarSets + +delBindersFV :: [Var] -> DVarSet -> DVarSet +delBindersFV bs fvs = foldr delBinderFV fvs bs + +delBinderFV :: Var -> DVarSet -> DVarSet +-- This way round, so we can do it multiple times using foldr + +-- (b `delBinderFV` s) +-- * removes the binder b from the free variable set s, +-- * AND *adds* to s the free variables of b's type +-- +-- This is really important for some lambdas: +-- In (\x::a -> x) the only mention of "a" is in the binder. +-- +-- Also in +-- let x::a = b in ... +-- we should really note that "a" is free in this expression. +-- It'll be pinned inside the /\a by the binding for b, but +-- it seems cleaner to make sure that a is in the free-var set +-- when it is mentioned. +-- +-- This also shows up in recursive bindings. Consider: +-- /\a -> letrec x::a = x in E +-- Now, there are no explicit free type variables in the RHS of x, +-- but nevertheless "a" is free in its definition. So we add in +-- the free tyvars of the types of the binders, and include these in the +-- free vars of the group, attached to the top level of each RHS. +-- +-- This actually happened in the defn of errorIO in IOBase.hs: +-- errorIO (ST io) = case (errorIO# io) of +-- _ -> bottom +-- where +-- bottom = bottom -- Never evaluated + +delBinderFV b s = (s `delDVarSet` b) `unionFVs` dVarTypeTyCoVars b + -- Include coercion variables too! + +varTypeTyCoVars :: Var -> TyCoVarSet +-- Find the type/kind variables free in the type of the id/tyvar +varTypeTyCoVars var = fvVarSet $ varTypeTyCoFVs var + +dVarTypeTyCoVars :: Var -> DTyCoVarSet +-- Find the type/kind/coercion variables free in the type of the id/tyvar +dVarTypeTyCoVars var = fvDVarSet $ varTypeTyCoFVs var + +varTypeTyCoFVs :: Var -> FV +varTypeTyCoFVs var = tyCoFVsOfType (varType var) + +idFreeVars :: Id -> VarSet +idFreeVars id = ASSERT( isId id) fvVarSet $ idFVs id + +dIdFreeVars :: Id -> DVarSet +dIdFreeVars id = fvDVarSet $ idFVs id + +idFVs :: Id -> FV +-- Type variables, rule variables, and inline variables +idFVs id = ASSERT( isId id) + varTypeTyCoFVs id `unionFV` + bndrRuleAndUnfoldingFVs id + +bndrRuleAndUnfoldingVarsDSet :: Id -> DVarSet +bndrRuleAndUnfoldingVarsDSet id = fvDVarSet $ bndrRuleAndUnfoldingFVs id + +bndrRuleAndUnfoldingFVs :: Id -> FV +bndrRuleAndUnfoldingFVs id + | isId id = idRuleFVs id `unionFV` idUnfoldingFVs id + | otherwise = emptyFV + +idRuleVars ::Id -> VarSet -- Does *not* include CoreUnfolding vars +idRuleVars id = fvVarSet $ idRuleFVs id + +idRuleFVs :: Id -> FV +idRuleFVs id = ASSERT( isId id) + FV.mkFVs (dVarSetElems $ ruleInfoFreeVars (idSpecialisation id)) + +idUnfoldingVars :: Id -> VarSet +-- Produce free vars for an unfolding, but NOT for an ordinary +-- (non-inline) unfolding, since it is a dup of the rhs +-- and we'll get exponential behaviour if we look at both unf and rhs! +-- But do look at the *real* unfolding, even for loop breakers, else +-- we might get out-of-scope variables +idUnfoldingVars id = fvVarSet $ idUnfoldingFVs id + +idUnfoldingFVs :: Id -> FV +idUnfoldingFVs id = stableUnfoldingFVs (realIdUnfolding id) `orElse` emptyFV + +stableUnfoldingVars :: Unfolding -> Maybe VarSet +stableUnfoldingVars unf = fvVarSet `fmap` stableUnfoldingFVs unf + +stableUnfoldingFVs :: Unfolding -> Maybe FV +stableUnfoldingFVs unf + = case unf of + CoreUnfolding { uf_tmpl = rhs, uf_src = src } + | isStableSource src + -> Just (filterFV isLocalVar $ expr_fvs rhs) + DFunUnfolding { df_bndrs = bndrs, df_args = args } + -> Just (filterFV isLocalVar $ FV.delFVs (mkVarSet bndrs) $ exprs_fvs args) + -- DFuns are top level, so no fvs from types of bndrs + _other -> Nothing + + +{- +************************************************************************ +* * +\subsection{Free variables (and types)} +* * +************************************************************************ +-} + +freeVarsBind :: CoreBind + -> DVarSet -- Free vars of scope of binding + -> (CoreBindWithFVs, DVarSet) -- Return free vars of binding + scope +freeVarsBind (NonRec binder rhs) body_fvs + = ( AnnNonRec binder rhs2 + , freeVarsOf rhs2 `unionFVs` body_fvs2 + `unionFVs` bndrRuleAndUnfoldingVarsDSet binder ) + where + rhs2 = freeVars rhs + body_fvs2 = binder `delBinderFV` body_fvs + +freeVarsBind (Rec binds) body_fvs + = ( AnnRec (binders `zip` rhss2) + , delBindersFV binders all_fvs ) + where + (binders, rhss) = unzip binds + rhss2 = map freeVars rhss + rhs_body_fvs = foldr (unionFVs . freeVarsOf) body_fvs rhss2 + binders_fvs = fvDVarSet $ mapUnionFV bndrRuleAndUnfoldingFVs binders + -- See Note [The FVAnn invariant] + all_fvs = rhs_body_fvs `unionFVs` binders_fvs + -- The "delBinderFV" happens after adding the idSpecVars, + -- since the latter may add some of the binders as fvs + +freeVars :: CoreExpr -> CoreExprWithFVs +-- ^ Annotate a 'CoreExpr' with its (non-global) free type +-- and value variables at every tree node. +freeVars = go + where + go :: CoreExpr -> CoreExprWithFVs + go (Var v) + | isLocalVar v = (aFreeVar v `unionFVs` ty_fvs, AnnVar v) + | otherwise = (emptyDVarSet, AnnVar v) + where + ty_fvs = dVarTypeTyCoVars v + -- See Note [The FVAnn invariant] + + go (Lit lit) = (emptyDVarSet, AnnLit lit) + go (Lam b body) + = ( b_fvs `unionFVs` (b `delBinderFV` body_fvs) + , AnnLam b body' ) + where + body'@(body_fvs, _) = go body + b_ty = idType b + b_fvs = tyCoVarsOfTypeDSet b_ty + -- See Note [The FVAnn invariant] + + go (App fun arg) + = ( freeVarsOf fun' `unionFVs` freeVarsOf arg' + , AnnApp fun' arg' ) + where + fun' = go fun + arg' = go arg + + go (Case scrut bndr ty alts) + = ( (bndr `delBinderFV` alts_fvs) + `unionFVs` freeVarsOf scrut2 + `unionFVs` tyCoVarsOfTypeDSet ty + -- Don't need to look at (idType bndr) + -- because that's redundant with scrut + , AnnCase scrut2 bndr ty alts2 ) + where + scrut2 = go scrut + + (alts_fvs_s, alts2) = mapAndUnzip fv_alt alts + alts_fvs = unionFVss alts_fvs_s + + fv_alt (con,args,rhs) = (delBindersFV args (freeVarsOf rhs2), + (con, args, rhs2)) + where + rhs2 = go rhs + + go (Let bind body) + = (bind_fvs, AnnLet bind2 body2) + where + (bind2, bind_fvs) = freeVarsBind bind (freeVarsOf body2) + body2 = go body + + go (Cast expr co) + = ( freeVarsOf expr2 `unionFVs` cfvs + , AnnCast expr2 (cfvs, co) ) + where + expr2 = go expr + cfvs = tyCoVarsOfCoDSet co + + go (Tick tickish expr) + = ( tickishFVs tickish `unionFVs` freeVarsOf expr2 + , AnnTick tickish expr2 ) + where + expr2 = go expr + tickishFVs (Breakpoint _ ids) = mkDVarSet ids + tickishFVs _ = emptyDVarSet + + go (Type ty) = (tyCoVarsOfTypeDSet ty, AnnType ty) + go (Coercion co) = (tyCoVarsOfCoDSet co, AnnCoercion co) diff --git a/compiler/coreSyn/CoreMap.hs b/compiler/coreSyn/CoreMap.hs new file mode 100644 --- /dev/null +++ b/compiler/coreSyn/CoreMap.hs @@ -0,0 +1,803 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +module CoreMap( + -- * Maps over Core expressions + CoreMap, emptyCoreMap, extendCoreMap, lookupCoreMap, foldCoreMap, + -- * Maps over 'Type's + TypeMap, emptyTypeMap, extendTypeMap, lookupTypeMap, foldTypeMap, + LooseTypeMap, + -- ** With explicit scoping + CmEnv, lookupCME, extendTypeMapWithScope, lookupTypeMapWithScope, + mkDeBruijnContext, + -- * Maps over 'Maybe' values + MaybeMap, + -- * Maps over 'List' values + ListMap, + -- * Maps over 'Literal's + LiteralMap, + -- * Map for compressing leaves. See Note [Compressed TrieMap] + GenMap, + -- * 'TrieMap' class + TrieMap(..), insertTM, deleteTM, + lkDFreeVar, xtDFreeVar, + lkDNamed, xtDNamed, + (>.>), (|>), (|>>), + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import TrieMap +import CoreSyn +import Coercion +import Name +import Type +import TyCoRep +import Var +import FastString(FastString) +import Util + +import qualified Data.Map as Map +import qualified Data.IntMap as IntMap +import VarEnv +import NameEnv +import Outputable +import Control.Monad( (>=>) ) + +{- +This module implements TrieMaps over Core related data structures +like CoreExpr or Type. It is built on the Tries from the TrieMap +module. + +The code is very regular and boilerplate-like, but there is +some neat handling of *binders*. In effect they are deBruijn +numbered on the fly. + + +-} + +---------------------- +-- Recall that +-- Control.Monad.(>=>) :: (a -> Maybe b) -> (b -> Maybe c) -> a -> Maybe c + +-- NB: Be careful about RULES and type families (#5821). So we should make sure +-- to specify @Key TypeMapX@ (and not @DeBruijn Type@, the reduced form) + +-- The CoreMap makes heavy use of GenMap. However the CoreMap Types are not +-- known when defining GenMap so we can only specialize them here. + +{-# SPECIALIZE lkG :: Key TypeMapX -> TypeMapG a -> Maybe a #-} +{-# SPECIALIZE lkG :: Key CoercionMapX -> CoercionMapG a -> Maybe a #-} +{-# SPECIALIZE lkG :: Key CoreMapX -> CoreMapG a -> Maybe a #-} + + +{-# SPECIALIZE xtG :: Key TypeMapX -> XT a -> TypeMapG a -> TypeMapG a #-} +{-# SPECIALIZE xtG :: Key CoercionMapX -> XT a -> CoercionMapG a -> CoercionMapG a #-} +{-# SPECIALIZE xtG :: Key CoreMapX -> XT a -> CoreMapG a -> CoreMapG a #-} + +{-# SPECIALIZE mapG :: (a -> b) -> TypeMapG a -> TypeMapG b #-} +{-# SPECIALIZE mapG :: (a -> b) -> CoercionMapG a -> CoercionMapG b #-} +{-# SPECIALIZE mapG :: (a -> b) -> CoreMapG a -> CoreMapG b #-} + +{-# SPECIALIZE fdG :: (a -> b -> b) -> TypeMapG a -> b -> b #-} +{-# SPECIALIZE fdG :: (a -> b -> b) -> CoercionMapG a -> b -> b #-} +{-# SPECIALIZE fdG :: (a -> b -> b) -> CoreMapG a -> b -> b #-} + + +{- +************************************************************************ +* * + CoreMap +* * +************************************************************************ +-} + +lkDNamed :: NamedThing n => n -> DNameEnv a -> Maybe a +lkDNamed n env = lookupDNameEnv env (getName n) + +xtDNamed :: NamedThing n => n -> XT a -> DNameEnv a -> DNameEnv a +xtDNamed tc f m = alterDNameEnv f m (getName tc) + + +{- +Note [Binders] +~~~~~~~~~~~~~~ + * In general we check binders as late as possible because types are + less likely to differ than expression structure. That's why + cm_lam :: CoreMapG (TypeMapG a) + rather than + cm_lam :: TypeMapG (CoreMapG a) + + * We don't need to look at the type of some binders, notably + - the case binder in (Case _ b _ _) + - the binders in an alternative + because they are totally fixed by the context + +Note [Empty case alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* For a key (Case e b ty (alt:alts)) we don't need to look the return type + 'ty', because every alternative has that type. + +* For a key (Case e b ty []) we MUST look at the return type 'ty', because + otherwise (Case (error () "urk") _ Int []) would compare equal to + (Case (error () "urk") _ Bool []) + which is utterly wrong (#6097) + +We could compare the return type regardless, but the wildly common case +is that it's unnecessary, so we have two fields (cm_case and cm_ecase) +for the two possibilities. Only cm_ecase looks at the type. + +See also Note [Empty case alternatives] in CoreSyn. +-} + +-- | @CoreMap a@ is a map from 'CoreExpr' to @a@. If you are a client, this +-- is the type you want. +newtype CoreMap a = CoreMap (CoreMapG a) + +instance TrieMap CoreMap where + type Key CoreMap = CoreExpr + emptyTM = CoreMap emptyTM + lookupTM k (CoreMap m) = lookupTM (deBruijnize k) m + alterTM k f (CoreMap m) = CoreMap (alterTM (deBruijnize k) f m) + foldTM k (CoreMap m) = foldTM k m + mapTM f (CoreMap m) = CoreMap (mapTM f m) + +-- | @CoreMapG a@ is a map from @DeBruijn CoreExpr@ to @a@. The extended +-- key makes it suitable for recursive traversal, since it can track binders, +-- but it is strictly internal to this module. If you are including a 'CoreMap' +-- inside another 'TrieMap', this is the type you want. +type CoreMapG = GenMap CoreMapX + +-- | @CoreMapX a@ is the base map from @DeBruijn CoreExpr@ to @a@, but without +-- the 'GenMap' optimization. +data CoreMapX a + = CM { cm_var :: VarMap a + , cm_lit :: LiteralMap a + , cm_co :: CoercionMapG a + , cm_type :: TypeMapG a + , cm_cast :: CoreMapG (CoercionMapG a) + , cm_tick :: CoreMapG (TickishMap a) + , cm_app :: CoreMapG (CoreMapG a) + , cm_lam :: CoreMapG (BndrMap a) -- Note [Binders] + , cm_letn :: CoreMapG (CoreMapG (BndrMap a)) + , cm_letr :: ListMap CoreMapG (CoreMapG (ListMap BndrMap a)) + , cm_case :: CoreMapG (ListMap AltMap a) + , cm_ecase :: CoreMapG (TypeMapG a) -- Note [Empty case alternatives] + } + +instance Eq (DeBruijn CoreExpr) where + D env1 e1 == D env2 e2 = go e1 e2 where + go (Var v1) (Var v2) = case (lookupCME env1 v1, lookupCME env2 v2) of + (Just b1, Just b2) -> b1 == b2 + (Nothing, Nothing) -> v1 == v2 + _ -> False + go (Lit lit1) (Lit lit2) = lit1 == lit2 + go (Type t1) (Type t2) = D env1 t1 == D env2 t2 + go (Coercion co1) (Coercion co2) = D env1 co1 == D env2 co2 + go (Cast e1 co1) (Cast e2 co2) = D env1 co1 == D env2 co2 && go e1 e2 + go (App f1 a1) (App f2 a2) = go f1 f2 && go a1 a2 + -- This seems a bit dodgy, see 'eqTickish' + go (Tick n1 e1) (Tick n2 e2) = n1 == n2 && go e1 e2 + + go (Lam b1 e1) (Lam b2 e2) + = D env1 (varType b1) == D env2 (varType b2) + && D (extendCME env1 b1) e1 == D (extendCME env2 b2) e2 + + go (Let (NonRec v1 r1) e1) (Let (NonRec v2 r2) e2) + = go r1 r2 + && D (extendCME env1 v1) e1 == D (extendCME env2 v2) e2 + + go (Let (Rec ps1) e1) (Let (Rec ps2) e2) + = equalLength ps1 ps2 + && D env1' rs1 == D env2' rs2 + && D env1' e1 == D env2' e2 + where + (bs1,rs1) = unzip ps1 + (bs2,rs2) = unzip ps2 + env1' = extendCMEs env1 bs1 + env2' = extendCMEs env2 bs2 + + go (Case e1 b1 t1 a1) (Case e2 b2 t2 a2) + | null a1 -- See Note [Empty case alternatives] + = null a2 && go e1 e2 && D env1 t1 == D env2 t2 + | otherwise + = go e1 e2 && D (extendCME env1 b1) a1 == D (extendCME env2 b2) a2 + + go _ _ = False + +emptyE :: CoreMapX a +emptyE = CM { cm_var = emptyTM, cm_lit = emptyTM + , cm_co = emptyTM, cm_type = emptyTM + , cm_cast = emptyTM, cm_app = emptyTM + , cm_lam = emptyTM, cm_letn = emptyTM + , cm_letr = emptyTM, cm_case = emptyTM + , cm_ecase = emptyTM, cm_tick = emptyTM } + +instance TrieMap CoreMapX where + type Key CoreMapX = DeBruijn CoreExpr + emptyTM = emptyE + lookupTM = lkE + alterTM = xtE + foldTM = fdE + mapTM = mapE + +-------------------------- +mapE :: (a->b) -> CoreMapX a -> CoreMapX b +mapE f (CM { cm_var = cvar, cm_lit = clit + , cm_co = cco, cm_type = ctype + , cm_cast = ccast , cm_app = capp + , cm_lam = clam, cm_letn = cletn + , cm_letr = cletr, cm_case = ccase + , cm_ecase = cecase, cm_tick = ctick }) + = CM { cm_var = mapTM f cvar, cm_lit = mapTM f clit + , cm_co = mapTM f cco, cm_type = mapTM f ctype + , cm_cast = mapTM (mapTM f) ccast, cm_app = mapTM (mapTM f) capp + , cm_lam = mapTM (mapTM f) clam, cm_letn = mapTM (mapTM (mapTM f)) cletn + , cm_letr = mapTM (mapTM (mapTM f)) cletr, cm_case = mapTM (mapTM f) ccase + , cm_ecase = mapTM (mapTM f) cecase, cm_tick = mapTM (mapTM f) ctick } + +-------------------------- +lookupCoreMap :: CoreMap a -> CoreExpr -> Maybe a +lookupCoreMap cm e = lookupTM e cm + +extendCoreMap :: CoreMap a -> CoreExpr -> a -> CoreMap a +extendCoreMap m e v = alterTM e (\_ -> Just v) m + +foldCoreMap :: (a -> b -> b) -> b -> CoreMap a -> b +foldCoreMap k z m = foldTM k m z + +emptyCoreMap :: CoreMap a +emptyCoreMap = emptyTM + +instance Outputable a => Outputable (CoreMap a) where + ppr m = text "CoreMap elts" <+> ppr (foldTM (:) m []) + +------------------------- +fdE :: (a -> b -> b) -> CoreMapX a -> b -> b +fdE k m + = foldTM k (cm_var m) + . foldTM k (cm_lit m) + . foldTM k (cm_co m) + . foldTM k (cm_type m) + . foldTM (foldTM k) (cm_cast m) + . foldTM (foldTM k) (cm_tick m) + . foldTM (foldTM k) (cm_app m) + . foldTM (foldTM k) (cm_lam m) + . foldTM (foldTM (foldTM k)) (cm_letn m) + . foldTM (foldTM (foldTM k)) (cm_letr m) + . foldTM (foldTM k) (cm_case m) + . foldTM (foldTM k) (cm_ecase m) + +-- lkE: lookup in trie for expressions +lkE :: DeBruijn CoreExpr -> CoreMapX a -> Maybe a +lkE (D env expr) cm = go expr cm + where + go (Var v) = cm_var >.> lkVar env v + go (Lit l) = cm_lit >.> lookupTM l + go (Type t) = cm_type >.> lkG (D env t) + go (Coercion c) = cm_co >.> lkG (D env c) + go (Cast e c) = cm_cast >.> lkG (D env e) >=> lkG (D env c) + go (Tick tickish e) = cm_tick >.> lkG (D env e) >=> lkTickish tickish + go (App e1 e2) = cm_app >.> lkG (D env e2) >=> lkG (D env e1) + go (Lam v e) = cm_lam >.> lkG (D (extendCME env v) e) + >=> lkBndr env v + go (Let (NonRec b r) e) = cm_letn >.> lkG (D env r) + >=> lkG (D (extendCME env b) e) >=> lkBndr env b + go (Let (Rec prs) e) = let (bndrs,rhss) = unzip prs + env1 = extendCMEs env bndrs + in cm_letr + >.> lkList (lkG . D env1) rhss + >=> lkG (D env1 e) + >=> lkList (lkBndr env1) bndrs + go (Case e b ty as) -- See Note [Empty case alternatives] + | null as = cm_ecase >.> lkG (D env e) >=> lkG (D env ty) + | otherwise = cm_case >.> lkG (D env e) + >=> lkList (lkA (extendCME env b)) as + +xtE :: DeBruijn CoreExpr -> XT a -> CoreMapX a -> CoreMapX a +xtE (D env (Var v)) f m = m { cm_var = cm_var m + |> xtVar env v f } +xtE (D env (Type t)) f m = m { cm_type = cm_type m + |> xtG (D env t) f } +xtE (D env (Coercion c)) f m = m { cm_co = cm_co m + |> xtG (D env c) f } +xtE (D _ (Lit l)) f m = m { cm_lit = cm_lit m |> alterTM l f } +xtE (D env (Cast e c)) f m = m { cm_cast = cm_cast m |> xtG (D env e) + |>> xtG (D env c) f } +xtE (D env (Tick t e)) f m = m { cm_tick = cm_tick m |> xtG (D env e) + |>> xtTickish t f } +xtE (D env (App e1 e2)) f m = m { cm_app = cm_app m |> xtG (D env e2) + |>> xtG (D env e1) f } +xtE (D env (Lam v e)) f m = m { cm_lam = cm_lam m + |> xtG (D (extendCME env v) e) + |>> xtBndr env v f } +xtE (D env (Let (NonRec b r) e)) f m = m { cm_letn = cm_letn m + |> xtG (D (extendCME env b) e) + |>> xtG (D env r) + |>> xtBndr env b f } +xtE (D env (Let (Rec prs) e)) f m = m { cm_letr = + let (bndrs,rhss) = unzip prs + env1 = extendCMEs env bndrs + in cm_letr m + |> xtList (xtG . D env1) rhss + |>> xtG (D env1 e) + |>> xtList (xtBndr env1) + bndrs f } +xtE (D env (Case e b ty as)) f m + | null as = m { cm_ecase = cm_ecase m |> xtG (D env e) + |>> xtG (D env ty) f } + | otherwise = m { cm_case = cm_case m |> xtG (D env e) + |>> let env1 = extendCME env b + in xtList (xtA env1) as f } + +-- TODO: this seems a bit dodgy, see 'eqTickish' +type TickishMap a = Map.Map (Tickish Id) a +lkTickish :: Tickish Id -> TickishMap a -> Maybe a +lkTickish = lookupTM + +xtTickish :: Tickish Id -> XT a -> TickishMap a -> TickishMap a +xtTickish = alterTM + +------------------------ +data AltMap a -- A single alternative + = AM { am_deflt :: CoreMapG a + , am_data :: DNameEnv (CoreMapG a) + , am_lit :: LiteralMap (CoreMapG a) } + +instance TrieMap AltMap where + type Key AltMap = CoreAlt + emptyTM = AM { am_deflt = emptyTM + , am_data = emptyDNameEnv + , am_lit = emptyTM } + lookupTM = lkA emptyCME + alterTM = xtA emptyCME + foldTM = fdA + mapTM = mapA + +instance Eq (DeBruijn CoreAlt) where + D env1 a1 == D env2 a2 = go a1 a2 where + go (DEFAULT, _, rhs1) (DEFAULT, _, rhs2) + = D env1 rhs1 == D env2 rhs2 + go (LitAlt lit1, _, rhs1) (LitAlt lit2, _, rhs2) + = lit1 == lit2 && D env1 rhs1 == D env2 rhs2 + go (DataAlt dc1, bs1, rhs1) (DataAlt dc2, bs2, rhs2) + = dc1 == dc2 && + D (extendCMEs env1 bs1) rhs1 == D (extendCMEs env2 bs2) rhs2 + go _ _ = False + +mapA :: (a->b) -> AltMap a -> AltMap b +mapA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit }) + = AM { am_deflt = mapTM f adeflt + , am_data = mapTM (mapTM f) adata + , am_lit = mapTM (mapTM f) alit } + +lkA :: CmEnv -> CoreAlt -> AltMap a -> Maybe a +lkA env (DEFAULT, _, rhs) = am_deflt >.> lkG (D env rhs) +lkA env (LitAlt lit, _, rhs) = am_lit >.> lookupTM lit >=> lkG (D env rhs) +lkA env (DataAlt dc, bs, rhs) = am_data >.> lkDNamed dc + >=> lkG (D (extendCMEs env bs) rhs) + +xtA :: CmEnv -> CoreAlt -> XT a -> AltMap a -> AltMap a +xtA env (DEFAULT, _, rhs) f m = + m { am_deflt = am_deflt m |> xtG (D env rhs) f } +xtA env (LitAlt l, _, rhs) f m = + m { am_lit = am_lit m |> alterTM l |>> xtG (D env rhs) f } +xtA env (DataAlt d, bs, rhs) f m = + m { am_data = am_data m |> xtDNamed d + |>> xtG (D (extendCMEs env bs) rhs) f } + +fdA :: (a -> b -> b) -> AltMap a -> b -> b +fdA k m = foldTM k (am_deflt m) + . foldTM (foldTM k) (am_data m) + . foldTM (foldTM k) (am_lit m) + +{- +************************************************************************ +* * + Coercions +* * +************************************************************************ +-} + +-- We should really never care about the contents of a coercion. Instead, +-- just look up the coercion's type. +newtype CoercionMap a = CoercionMap (CoercionMapG a) + +instance TrieMap CoercionMap where + type Key CoercionMap = Coercion + emptyTM = CoercionMap emptyTM + lookupTM k (CoercionMap m) = lookupTM (deBruijnize k) m + alterTM k f (CoercionMap m) = CoercionMap (alterTM (deBruijnize k) f m) + foldTM k (CoercionMap m) = foldTM k m + mapTM f (CoercionMap m) = CoercionMap (mapTM f m) + +type CoercionMapG = GenMap CoercionMapX +newtype CoercionMapX a = CoercionMapX (TypeMapX a) + +instance TrieMap CoercionMapX where + type Key CoercionMapX = DeBruijn Coercion + emptyTM = CoercionMapX emptyTM + lookupTM = lkC + alterTM = xtC + foldTM f (CoercionMapX core_tm) = foldTM f core_tm + mapTM f (CoercionMapX core_tm) = CoercionMapX (mapTM f core_tm) + +instance Eq (DeBruijn Coercion) where + D env1 co1 == D env2 co2 + = D env1 (coercionType co1) == + D env2 (coercionType co2) + +lkC :: DeBruijn Coercion -> CoercionMapX a -> Maybe a +lkC (D env co) (CoercionMapX core_tm) = lkT (D env $ coercionType co) + core_tm + +xtC :: DeBruijn Coercion -> XT a -> CoercionMapX a -> CoercionMapX a +xtC (D env co) f (CoercionMapX m) + = CoercionMapX (xtT (D env $ coercionType co) f m) + +{- +************************************************************************ +* * + Types +* * +************************************************************************ +-} + +-- | @TypeMapG a@ is a map from @DeBruijn Type@ to @a@. The extended +-- key makes it suitable for recursive traversal, since it can track binders, +-- but it is strictly internal to this module. If you are including a 'TypeMap' +-- inside another 'TrieMap', this is the type you want. Note that this +-- lookup does not do a kind-check. Thus, all keys in this map must have +-- the same kind. Also note that this map respects the distinction between +-- @Type@ and @Constraint@, despite the fact that they are equivalent type +-- synonyms in Core. +type TypeMapG = GenMap TypeMapX + +-- | @TypeMapX a@ is the base map from @DeBruijn Type@ to @a@, but without the +-- 'GenMap' optimization. +data TypeMapX a + = TM { tm_var :: VarMap a + , tm_app :: TypeMapG (TypeMapG a) + , tm_tycon :: DNameEnv a + , tm_forall :: TypeMapG (BndrMap a) -- See Note [Binders] + , tm_tylit :: TyLitMap a + , tm_coerce :: Maybe a + } + -- Note that there is no tyconapp case; see Note [Equality on AppTys] in Type + +-- | Squeeze out any synonyms, and change TyConApps to nested AppTys. Why the +-- last one? See Note [Equality on AppTys] in Type +-- +-- Note, however, that we keep Constraint and Type apart here, despite the fact +-- that they are both synonyms of TYPE 'LiftedRep (see #11715). +trieMapView :: Type -> Maybe Type +trieMapView ty + -- First check for TyConApps that need to be expanded to + -- AppTy chains. + | Just (tc, tys@(_:_)) <- tcSplitTyConApp_maybe ty + = Just $ foldl' AppTy (TyConApp tc []) tys + + -- Then resolve any remaining nullary synonyms. + | Just ty' <- tcView ty = Just ty' +trieMapView _ = Nothing + +instance TrieMap TypeMapX where + type Key TypeMapX = DeBruijn Type + emptyTM = emptyT + lookupTM = lkT + alterTM = xtT + foldTM = fdT + mapTM = mapT + +instance Eq (DeBruijn Type) where + env_t@(D env t) == env_t'@(D env' t') + | Just new_t <- tcView t = D env new_t == env_t' + | Just new_t' <- tcView t' = env_t == D env' new_t' + | otherwise + = case (t, t') of + (CastTy t1 _, _) -> D env t1 == D env t' + (_, CastTy t1' _) -> D env t == D env t1' + + (TyVarTy v, TyVarTy v') + -> case (lookupCME env v, lookupCME env' v') of + (Just bv, Just bv') -> bv == bv' + (Nothing, Nothing) -> v == v' + _ -> False + -- See Note [Equality on AppTys] in Type + (AppTy t1 t2, s) | Just (t1', t2') <- repSplitAppTy_maybe s + -> D env t1 == D env' t1' && D env t2 == D env' t2' + (s, AppTy t1' t2') | Just (t1, t2) <- repSplitAppTy_maybe s + -> D env t1 == D env' t1' && D env t2 == D env' t2' + (FunTy _ t1 t2, FunTy _ t1' t2') + -> D env t1 == D env' t1' && D env t2 == D env' t2' + (TyConApp tc tys, TyConApp tc' tys') + -> tc == tc' && D env tys == D env' tys' + (LitTy l, LitTy l') + -> l == l' + (ForAllTy (Bndr tv _) ty, ForAllTy (Bndr tv' _) ty') + -> D env (varType tv) == D env' (varType tv') && + D (extendCME env tv) ty == D (extendCME env' tv') ty' + (CoercionTy {}, CoercionTy {}) + -> True + _ -> False + +instance {-# OVERLAPPING #-} + Outputable a => Outputable (TypeMapG a) where + ppr m = text "TypeMap elts" <+> ppr (foldTM (:) m []) + +emptyT :: TypeMapX a +emptyT = TM { tm_var = emptyTM + , tm_app = emptyTM + , tm_tycon = emptyDNameEnv + , tm_forall = emptyTM + , tm_tylit = emptyTyLitMap + , tm_coerce = Nothing } + +mapT :: (a->b) -> TypeMapX a -> TypeMapX b +mapT f (TM { tm_var = tvar, tm_app = tapp, tm_tycon = ttycon + , tm_forall = tforall, tm_tylit = tlit + , tm_coerce = tcoerce }) + = TM { tm_var = mapTM f tvar + , tm_app = mapTM (mapTM f) tapp + , tm_tycon = mapTM f ttycon + , tm_forall = mapTM (mapTM f) tforall + , tm_tylit = mapTM f tlit + , tm_coerce = fmap f tcoerce } + +----------------- +lkT :: DeBruijn Type -> TypeMapX a -> Maybe a +lkT (D env ty) m = go ty m + where + go ty | Just ty' <- trieMapView ty = go ty' + go (TyVarTy v) = tm_var >.> lkVar env v + go (AppTy t1 t2) = tm_app >.> lkG (D env t1) + >=> lkG (D env t2) + go (TyConApp tc []) = tm_tycon >.> lkDNamed tc + go ty@(TyConApp _ (_:_)) = pprPanic "lkT TyConApp" (ppr ty) + go (LitTy l) = tm_tylit >.> lkTyLit l + go (ForAllTy (Bndr tv _) ty) = tm_forall >.> lkG (D (extendCME env tv) ty) + >=> lkBndr env tv + go ty@(FunTy {}) = pprPanic "lkT FunTy" (ppr ty) + go (CastTy t _) = go t + go (CoercionTy {}) = tm_coerce + +----------------- +xtT :: DeBruijn Type -> XT a -> TypeMapX a -> TypeMapX a +xtT (D env ty) f m | Just ty' <- trieMapView ty = xtT (D env ty') f m + +xtT (D env (TyVarTy v)) f m = m { tm_var = tm_var m |> xtVar env v f } +xtT (D env (AppTy t1 t2)) f m = m { tm_app = tm_app m |> xtG (D env t1) + |>> xtG (D env t2) f } +xtT (D _ (TyConApp tc [])) f m = m { tm_tycon = tm_tycon m |> xtDNamed tc f } +xtT (D _ (LitTy l)) f m = m { tm_tylit = tm_tylit m |> xtTyLit l f } +xtT (D env (CastTy t _)) f m = xtT (D env t) f m +xtT (D _ (CoercionTy {})) f m = m { tm_coerce = tm_coerce m |> f } +xtT (D env (ForAllTy (Bndr tv _) ty)) f m + = m { tm_forall = tm_forall m |> xtG (D (extendCME env tv) ty) + |>> xtBndr env tv f } +xtT (D _ ty@(TyConApp _ (_:_))) _ _ = pprPanic "xtT TyConApp" (ppr ty) +xtT (D _ ty@(FunTy {})) _ _ = pprPanic "xtT FunTy" (ppr ty) + +fdT :: (a -> b -> b) -> TypeMapX a -> b -> b +fdT k m = foldTM k (tm_var m) + . foldTM (foldTM k) (tm_app m) + . foldTM k (tm_tycon m) + . foldTM (foldTM k) (tm_forall m) + . foldTyLit k (tm_tylit m) + . foldMaybe k (tm_coerce m) + +------------------------ +data TyLitMap a = TLM { tlm_number :: Map.Map Integer a + , tlm_string :: Map.Map FastString a + } + +instance TrieMap TyLitMap where + type Key TyLitMap = TyLit + emptyTM = emptyTyLitMap + lookupTM = lkTyLit + alterTM = xtTyLit + foldTM = foldTyLit + mapTM = mapTyLit + +emptyTyLitMap :: TyLitMap a +emptyTyLitMap = TLM { tlm_number = Map.empty, tlm_string = Map.empty } + +mapTyLit :: (a->b) -> TyLitMap a -> TyLitMap b +mapTyLit f (TLM { tlm_number = tn, tlm_string = ts }) + = TLM { tlm_number = Map.map f tn, tlm_string = Map.map f ts } + +lkTyLit :: TyLit -> TyLitMap a -> Maybe a +lkTyLit l = + case l of + NumTyLit n -> tlm_number >.> Map.lookup n + StrTyLit n -> tlm_string >.> Map.lookup n + +xtTyLit :: TyLit -> XT a -> TyLitMap a -> TyLitMap a +xtTyLit l f m = + case l of + NumTyLit n -> m { tlm_number = tlm_number m |> Map.alter f n } + StrTyLit n -> m { tlm_string = tlm_string m |> Map.alter f n } + +foldTyLit :: (a -> b -> b) -> TyLitMap a -> b -> b +foldTyLit l m = flip (Map.foldr l) (tlm_string m) + . flip (Map.foldr l) (tlm_number m) + +------------------------------------------------- +-- | @TypeMap a@ is a map from 'Type' to @a@. If you are a client, this +-- is the type you want. The keys in this map may have different kinds. +newtype TypeMap a = TypeMap (TypeMapG (TypeMapG a)) + +lkTT :: DeBruijn Type -> TypeMap a -> Maybe a +lkTT (D env ty) (TypeMap m) = lkG (D env $ typeKind ty) m + >>= lkG (D env ty) + +xtTT :: DeBruijn Type -> XT a -> TypeMap a -> TypeMap a +xtTT (D env ty) f (TypeMap m) + = TypeMap (m |> xtG (D env $ typeKind ty) + |>> xtG (D env ty) f) + +-- Below are some client-oriented functions which operate on 'TypeMap'. + +instance TrieMap TypeMap where + type Key TypeMap = Type + emptyTM = TypeMap emptyTM + lookupTM k m = lkTT (deBruijnize k) m + alterTM k f m = xtTT (deBruijnize k) f m + foldTM k (TypeMap m) = foldTM (foldTM k) m + mapTM f (TypeMap m) = TypeMap (mapTM (mapTM f) m) + +foldTypeMap :: (a -> b -> b) -> b -> TypeMap a -> b +foldTypeMap k z m = foldTM k m z + +emptyTypeMap :: TypeMap a +emptyTypeMap = emptyTM + +lookupTypeMap :: TypeMap a -> Type -> Maybe a +lookupTypeMap cm t = lookupTM t cm + +extendTypeMap :: TypeMap a -> Type -> a -> TypeMap a +extendTypeMap m t v = alterTM t (const (Just v)) m + +lookupTypeMapWithScope :: TypeMap a -> CmEnv -> Type -> Maybe a +lookupTypeMapWithScope m cm t = lkTT (D cm t) m + +-- | Extend a 'TypeMap' with a type in the given context. +-- @extendTypeMapWithScope m (mkDeBruijnContext [a,b,c]) t v@ is equivalent to +-- @extendTypeMap m (forall a b c. t) v@, but allows reuse of the context over +-- multiple insertions. +extendTypeMapWithScope :: TypeMap a -> CmEnv -> Type -> a -> TypeMap a +extendTypeMapWithScope m cm t v = xtTT (D cm t) (const (Just v)) m + +-- | Construct a deBruijn environment with the given variables in scope. +-- e.g. @mkDeBruijnEnv [a,b,c]@ constructs a context @forall a b c.@ +mkDeBruijnContext :: [Var] -> CmEnv +mkDeBruijnContext = extendCMEs emptyCME + +-- | A 'LooseTypeMap' doesn't do a kind-check. Thus, when lookup up (t |> g), +-- you'll find entries inserted under (t), even if (g) is non-reflexive. +newtype LooseTypeMap a + = LooseTypeMap (TypeMapG a) + +instance TrieMap LooseTypeMap where + type Key LooseTypeMap = Type + emptyTM = LooseTypeMap emptyTM + lookupTM k (LooseTypeMap m) = lookupTM (deBruijnize k) m + alterTM k f (LooseTypeMap m) = LooseTypeMap (alterTM (deBruijnize k) f m) + foldTM f (LooseTypeMap m) = foldTM f m + mapTM f (LooseTypeMap m) = LooseTypeMap (mapTM f m) + +{- +************************************************************************ +* * + Variables +* * +************************************************************************ +-} + +type BoundVar = Int -- Bound variables are deBruijn numbered +type BoundVarMap a = IntMap.IntMap a + +data CmEnv = CME { cme_next :: !BoundVar + , cme_env :: VarEnv BoundVar } + +emptyCME :: CmEnv +emptyCME = CME { cme_next = 0, cme_env = emptyVarEnv } + +extendCME :: CmEnv -> Var -> CmEnv +extendCME (CME { cme_next = bv, cme_env = env }) v + = CME { cme_next = bv+1, cme_env = extendVarEnv env v bv } + +extendCMEs :: CmEnv -> [Var] -> CmEnv +extendCMEs env vs = foldl' extendCME env vs + +lookupCME :: CmEnv -> Var -> Maybe BoundVar +lookupCME (CME { cme_env = env }) v = lookupVarEnv env v + +-- | @DeBruijn a@ represents @a@ modulo alpha-renaming. This is achieved +-- by equipping the value with a 'CmEnv', which tracks an on-the-fly deBruijn +-- numbering. This allows us to define an 'Eq' instance for @DeBruijn a@, even +-- if this was not (easily) possible for @a@. Note: we purposely don't +-- export the constructor. Make a helper function if you find yourself +-- needing it. +data DeBruijn a = D CmEnv a + +-- | Synthesizes a @DeBruijn a@ from an @a@, by assuming that there are no +-- bound binders (an empty 'CmEnv'). This is usually what you want if there +-- isn't already a 'CmEnv' in scope. +deBruijnize :: a -> DeBruijn a +deBruijnize = D emptyCME + +instance Eq (DeBruijn a) => Eq (DeBruijn [a]) where + D _ [] == D _ [] = True + D env (x:xs) == D env' (x':xs') = D env x == D env' x' && + D env xs == D env' xs' + _ == _ = False + +--------- Variable binders ------------- + +-- | A 'BndrMap' is a 'TypeMapG' which allows us to distinguish between +-- binding forms whose binders have different types. For example, +-- if we are doing a 'TrieMap' lookup on @\(x :: Int) -> ()@, we should +-- not pick up an entry in the 'TrieMap' for @\(x :: Bool) -> ()@: +-- we can disambiguate this by matching on the type (or kind, if this +-- a binder in a type) of the binder. +type BndrMap = TypeMapG + +-- Note [Binders] +-- ~~~~~~~~~~~~~~ +-- We need to use 'BndrMap' for 'Coercion', 'CoreExpr' AND 'Type', since all +-- of these data types have binding forms. + +lkBndr :: CmEnv -> Var -> BndrMap a -> Maybe a +lkBndr env v m = lkG (D env (varType v)) m + +xtBndr :: CmEnv -> Var -> XT a -> BndrMap a -> BndrMap a +xtBndr env v f = xtG (D env (varType v)) f + +--------- Variable occurrence ------------- +data VarMap a = VM { vm_bvar :: BoundVarMap a -- Bound variable + , vm_fvar :: DVarEnv a } -- Free variable + +instance TrieMap VarMap where + type Key VarMap = Var + emptyTM = VM { vm_bvar = IntMap.empty, vm_fvar = emptyDVarEnv } + lookupTM = lkVar emptyCME + alterTM = xtVar emptyCME + foldTM = fdVar + mapTM = mapVar + +mapVar :: (a->b) -> VarMap a -> VarMap b +mapVar f (VM { vm_bvar = bv, vm_fvar = fv }) + = VM { vm_bvar = mapTM f bv, vm_fvar = mapTM f fv } + +lkVar :: CmEnv -> Var -> VarMap a -> Maybe a +lkVar env v + | Just bv <- lookupCME env v = vm_bvar >.> lookupTM bv + | otherwise = vm_fvar >.> lkDFreeVar v + +xtVar :: CmEnv -> Var -> XT a -> VarMap a -> VarMap a +xtVar env v f m + | Just bv <- lookupCME env v = m { vm_bvar = vm_bvar m |> alterTM bv f } + | otherwise = m { vm_fvar = vm_fvar m |> xtDFreeVar v f } + +fdVar :: (a -> b -> b) -> VarMap a -> b -> b +fdVar k m = foldTM k (vm_bvar m) + . foldTM k (vm_fvar m) + +lkDFreeVar :: Var -> DVarEnv a -> Maybe a +lkDFreeVar var env = lookupDVarEnv env var + +xtDFreeVar :: Var -> XT a -> DVarEnv a -> DVarEnv a +xtDFreeVar v f m = alterDVarEnv f m v diff --git a/compiler/coreSyn/CoreOpt.hs b/compiler/coreSyn/CoreOpt.hs new file mode 100644 --- /dev/null +++ b/compiler/coreSyn/CoreOpt.hs @@ -0,0 +1,1388 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE CPP #-} +module CoreOpt ( + -- ** Simple expression optimiser + simpleOptPgm, simpleOptExpr, simpleOptExprWith, + + -- ** Join points + joinPointBinding_maybe, joinPointBindings_maybe, + + -- ** Predicates on expressions + exprIsConApp_maybe, exprIsLiteral_maybe, exprIsLambda_maybe, + + -- ** Coercions and casts + pushCoArg, pushCoValArg, pushCoTyArg, collectBindersPushingCo + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import CoreArity( etaExpandToJoinPoint ) + +import CoreSyn +import CoreSubst +import CoreUtils +import CoreFVs +import MkCore ( FloatBind(..) ) +import PprCore ( pprCoreBindings, pprRules ) +import OccurAnal( occurAnalyseExpr, occurAnalysePgm ) +import Literal ( Literal(LitString) ) +import Id +import Var ( isNonCoVarId ) +import VarSet +import VarEnv +import DataCon +import Demand( etaExpandStrictSig ) +import OptCoercion ( optCoercion ) +import Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList + , isInScope, substTyVarBndr, cloneTyVarBndr ) +import Coercion hiding ( substCo, substCoVarBndr ) +import TyCon ( tyConArity ) +import TysWiredIn +import PrelNames +import BasicTypes +import Module ( Module ) +import ErrUtils +import DynFlags +import Outputable +import Pair +import Util +import Maybes ( orElse ) +import FastString +import Data.List +import qualified Data.ByteString as BS + +{- +************************************************************************ +* * + The Simple Optimiser +* * +************************************************************************ + +Note [The simple optimiser] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The simple optimiser is a lightweight, pure (non-monadic) function +that rapidly does a lot of simple optimisations, including + + - inlining things that occur just once, + or whose RHS turns out to be trivial + - beta reduction + - case of known constructor + - dead code elimination + +It does NOT do any call-site inlining; it only inlines a function if +it can do so unconditionally, dropping the binding. It thereby +guarantees to leave no un-reduced beta-redexes. + +It is careful to follow the guidance of "Secrets of the GHC inliner", +and in particular the pre-inline-unconditionally and +post-inline-unconditionally story, to do effective beta reduction on +functions called precisely once, without repeatedly optimising the same +expression. In fact, the simple optimiser is a good example of this +little dance in action; the full Simplifier is a lot more complicated. + +-} + +simpleOptExpr :: DynFlags -> CoreExpr -> CoreExpr +-- See Note [The simple optimiser] +-- Do simple optimisation on an expression +-- The optimisation is very straightforward: just +-- inline non-recursive bindings that are used only once, +-- or where the RHS is trivial +-- +-- We also inline bindings that bind a Eq# box: see +-- See Note [Getting the map/coerce RULE to work]. +-- +-- Also we convert functions to join points where possible (as +-- the occurrence analyser does most of the work anyway). +-- +-- The result is NOT guaranteed occurrence-analysed, because +-- in (let x = y in ....) we substitute for x; so y's occ-info +-- may change radically + +simpleOptExpr dflags expr + = -- pprTrace "simpleOptExpr" (ppr init_subst $$ ppr expr) + simpleOptExprWith dflags init_subst expr + where + init_subst = mkEmptySubst (mkInScopeSet (exprFreeVars expr)) + -- It's potentially important to make a proper in-scope set + -- Consider let x = ..y.. in \y. ...x... + -- Then we should remember to clone y before substituting + -- for x. It's very unlikely to occur, because we probably + -- won't *be* substituting for x if it occurs inside a + -- lambda. + -- + -- It's a bit painful to call exprFreeVars, because it makes + -- three passes instead of two (occ-anal, and go) + +simpleOptExprWith :: DynFlags -> Subst -> InExpr -> OutExpr +-- See Note [The simple optimiser] +simpleOptExprWith dflags subst expr + = simple_opt_expr init_env (occurAnalyseExpr expr) + where + init_env = SOE { soe_dflags = dflags + , soe_inl = emptyVarEnv + , soe_subst = subst } + +---------------------- +simpleOptPgm :: DynFlags -> Module + -> CoreProgram -> [CoreRule] + -> IO (CoreProgram, [CoreRule]) +-- See Note [The simple optimiser] +simpleOptPgm dflags this_mod binds rules + = do { dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis" + (pprCoreBindings occ_anald_binds $$ pprRules rules ); + + ; return (reverse binds', rules') } + where + occ_anald_binds = occurAnalysePgm this_mod + (\_ -> True) {- All unfoldings active -} + (\_ -> False) {- No rules active -} + rules binds + + (final_env, binds') = foldl' do_one (emptyEnv dflags, []) occ_anald_binds + final_subst = soe_subst final_env + + rules' = substRulesForImportedIds final_subst rules + -- We never unconditionally inline into rules, + -- hence paying just a substitution + + do_one (env, binds') bind + = case simple_opt_bind env bind of + (env', Nothing) -> (env', binds') + (env', Just bind') -> (env', bind':binds') + +-- In these functions the substitution maps InVar -> OutExpr + +---------------------- +type SimpleClo = (SimpleOptEnv, InExpr) + +data SimpleOptEnv + = SOE { soe_dflags :: DynFlags + , soe_inl :: IdEnv SimpleClo + -- Deals with preInlineUnconditionally; things + -- that occur exactly once and are inlined + -- without having first been simplified + + , soe_subst :: Subst + -- Deals with cloning; includes the InScopeSet + } + +instance Outputable SimpleOptEnv where + ppr (SOE { soe_inl = inl, soe_subst = subst }) + = text "SOE {" <+> vcat [ text "soe_inl =" <+> ppr inl + , text "soe_subst =" <+> ppr subst ] + <+> text "}" + +emptyEnv :: DynFlags -> SimpleOptEnv +emptyEnv dflags + = SOE { soe_dflags = dflags + , soe_inl = emptyVarEnv + , soe_subst = emptySubst } + +soeZapSubst :: SimpleOptEnv -> SimpleOptEnv +soeZapSubst env@(SOE { soe_subst = subst }) + = env { soe_inl = emptyVarEnv, soe_subst = zapSubstEnv subst } + +soeSetInScope :: SimpleOptEnv -> SimpleOptEnv -> SimpleOptEnv +-- Take in-scope set from env1, and the rest from env2 +soeSetInScope (SOE { soe_subst = subst1 }) + env2@(SOE { soe_subst = subst2 }) + = env2 { soe_subst = setInScope subst2 (substInScope subst1) } + +--------------- +simple_opt_clo :: SimpleOptEnv -> SimpleClo -> OutExpr +simple_opt_clo env (e_env, e) + = simple_opt_expr (soeSetInScope env e_env) e + +simple_opt_expr :: SimpleOptEnv -> InExpr -> OutExpr +simple_opt_expr env expr + = go expr + where + subst = soe_subst env + in_scope = substInScope subst + in_scope_env = (in_scope, simpleUnfoldingFun) + + go (Var v) + | Just clo <- lookupVarEnv (soe_inl env) v + = simple_opt_clo env clo + | otherwise + = lookupIdSubst (text "simpleOptExpr") (soe_subst env) v + + go (App e1 e2) = simple_app env e1 [(env,e2)] + go (Type ty) = Type (substTy subst ty) + go (Coercion co) = Coercion (optCoercion (soe_dflags env) (getTCvSubst subst) co) + go (Lit lit) = Lit lit + go (Tick tickish e) = mkTick (substTickish subst tickish) (go e) + go (Cast e co) | isReflCo co' = go e + | otherwise = Cast (go e) co' + where + co' = optCoercion (soe_dflags env) (getTCvSubst subst) co + + go (Let bind body) = case simple_opt_bind env bind of + (env', Nothing) -> simple_opt_expr env' body + (env', Just bind) -> Let bind (simple_opt_expr env' body) + + go lam@(Lam {}) = go_lam env [] lam + go (Case e b ty as) + -- See Note [Getting the map/coerce RULE to work] + | isDeadBinder b + , Just (_, [], con, _tys, es) <- exprIsConApp_maybe in_scope_env e' + -- We don't need to be concerned about floats when looking for coerce. + , Just (altcon, bs, rhs) <- findAlt (DataAlt con) as + = case altcon of + DEFAULT -> go rhs + _ -> foldr wrapLet (simple_opt_expr env' rhs) mb_prs + where + (env', mb_prs) = mapAccumL simple_out_bind env $ + zipEqual "simpleOptExpr" bs es + + -- Note [Getting the map/coerce RULE to work] + | isDeadBinder b + , [(DEFAULT, _, rhs)] <- as + , isCoVarType (varType b) + , (Var fun, _args) <- collectArgs e + , fun `hasKey` coercibleSCSelIdKey + -- without this last check, we get #11230 + = go rhs + + | otherwise + = Case e' b' (substTy subst ty) + (map (go_alt env') as) + where + e' = go e + (env', b') = subst_opt_bndr env b + + ---------------------- + go_alt env (con, bndrs, rhs) + = (con, bndrs', simple_opt_expr env' rhs) + where + (env', bndrs') = subst_opt_bndrs env bndrs + + ---------------------- + -- go_lam tries eta reduction + go_lam env bs' (Lam b e) + = go_lam env' (b':bs') e + where + (env', b') = subst_opt_bndr env b + go_lam env bs' e + | Just etad_e <- tryEtaReduce bs e' = etad_e + | otherwise = mkLams bs e' + where + bs = reverse bs' + e' = simple_opt_expr env e + +---------------------- +-- simple_app collects arguments for beta reduction +simple_app :: SimpleOptEnv -> InExpr -> [SimpleClo] -> CoreExpr + +simple_app env (Var v) as + | Just (env', e) <- lookupVarEnv (soe_inl env) v + = simple_app (soeSetInScope env env') e as + + | let unf = idUnfolding v + , isCompulsoryUnfolding (idUnfolding v) + , isAlwaysActive (idInlineActivation v) + -- See Note [Unfold compulsory unfoldings in LHSs] + = simple_app (soeZapSubst env) (unfoldingTemplate unf) as + + | otherwise + , let out_fn = lookupIdSubst (text "simple_app") (soe_subst env) v + = finish_app env out_fn as + +simple_app env (App e1 e2) as + = simple_app env e1 ((env, e2) : as) + +simple_app env (Lam b e) (a:as) + = wrapLet mb_pr (simple_app env' e as) + where + (env', mb_pr) = simple_bind_pair env b Nothing a + +simple_app env (Tick t e) as + -- Okay to do "(Tick t e) x ==> Tick t (e x)"? + | t `tickishScopesLike` SoftScope + = mkTick t $ simple_app env e as + +-- (let x = e in b) a1 .. an => let x = e in (b a1 .. an) +-- The let might appear there as a result of inlining +-- e.g. let f = let x = e in b +-- in f a1 a2 +-- (#13208) +simple_app env (Let bind body) as + = case simple_opt_bind env bind of + (env', Nothing) -> simple_app env' body as + (env', Just bind) -> Let bind (simple_app env' body as) + +simple_app env e as + = finish_app env (simple_opt_expr env e) as + +finish_app :: SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr +finish_app _ fun [] + = fun +finish_app env fun (arg:args) + = finish_app env (App fun (simple_opt_clo env arg)) args + +---------------------- +simple_opt_bind :: SimpleOptEnv -> InBind + -> (SimpleOptEnv, Maybe OutBind) +simple_opt_bind env (NonRec b r) + = (env', case mb_pr of + Nothing -> Nothing + Just (b,r) -> Just (NonRec b r)) + where + (b', r') = joinPointBinding_maybe b r `orElse` (b, r) + (env', mb_pr) = simple_bind_pair env b' Nothing (env,r') + +simple_opt_bind env (Rec prs) + = (env'', res_bind) + where + res_bind = Just (Rec (reverse rev_prs')) + prs' = joinPointBindings_maybe prs `orElse` prs + (env', bndrs') = subst_opt_bndrs env (map fst prs') + (env'', rev_prs') = foldl' do_pr (env', []) (prs' `zip` bndrs') + do_pr (env, prs) ((b,r), b') + = (env', case mb_pr of + Just pr -> pr : prs + Nothing -> prs) + where + (env', mb_pr) = simple_bind_pair env b (Just b') (env,r) + +---------------------- +simple_bind_pair :: SimpleOptEnv + -> InVar -> Maybe OutVar + -> SimpleClo + -> (SimpleOptEnv, Maybe (OutVar, OutExpr)) + -- (simple_bind_pair subst in_var out_rhs) + -- either extends subst with (in_var -> out_rhs) + -- or returns Nothing +simple_bind_pair env@(SOE { soe_inl = inl_env, soe_subst = subst }) + in_bndr mb_out_bndr clo@(rhs_env, in_rhs) + | Type ty <- in_rhs -- let a::* = TYPE ty in + , let out_ty = substTy (soe_subst rhs_env) ty + = ASSERT( isTyVar in_bndr ) + (env { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing) + + | Coercion co <- in_rhs + , let out_co = optCoercion (soe_dflags env) (getTCvSubst (soe_subst rhs_env)) co + = ASSERT( isCoVar in_bndr ) + (env { soe_subst = extendCvSubst subst in_bndr out_co }, Nothing) + + | ASSERT2( isNonCoVarId in_bndr, ppr in_bndr ) + -- The previous two guards got rid of tyvars and coercions + -- See Note [CoreSyn type and coercion invariant] in CoreSyn + pre_inline_unconditionally + = (env { soe_inl = extendVarEnv inl_env in_bndr clo }, Nothing) + + | otherwise + = simple_out_bind_pair env in_bndr mb_out_bndr out_rhs + occ active stable_unf + where + stable_unf = isStableUnfolding (idUnfolding in_bndr) + active = isAlwaysActive (idInlineActivation in_bndr) + occ = idOccInfo in_bndr + + out_rhs | Just join_arity <- isJoinId_maybe in_bndr + = simple_join_rhs join_arity + | otherwise + = simple_opt_clo env clo + + simple_join_rhs join_arity -- See Note [Preserve join-binding arity] + = mkLams join_bndrs' (simple_opt_expr env_body join_body) + where + env0 = soeSetInScope env rhs_env + (join_bndrs, join_body) = collectNBinders join_arity in_rhs + (env_body, join_bndrs') = subst_opt_bndrs env0 join_bndrs + + pre_inline_unconditionally :: Bool + pre_inline_unconditionally + | isExportedId in_bndr = False + | stable_unf = False + | not active = False -- Note [Inline prag in simplOpt] + | not (safe_to_inline occ) = False + | otherwise = True + + -- Unconditionally safe to inline + safe_to_inline :: OccInfo -> Bool + safe_to_inline (IAmALoopBreaker {}) = False + safe_to_inline IAmDead = True + safe_to_inline occ@(OneOcc {}) = not (occ_in_lam occ) + && occ_one_br occ + safe_to_inline (ManyOccs {}) = False + +------------------- +simple_out_bind :: SimpleOptEnv -> (InVar, OutExpr) + -> (SimpleOptEnv, Maybe (OutVar, OutExpr)) +simple_out_bind env@(SOE { soe_subst = subst }) (in_bndr, out_rhs) + | Type out_ty <- out_rhs + = ASSERT( isTyVar in_bndr ) + (env { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing) + + | Coercion out_co <- out_rhs + = ASSERT( isCoVar in_bndr ) + (env { soe_subst = extendCvSubst subst in_bndr out_co }, Nothing) + + | otherwise + = simple_out_bind_pair env in_bndr Nothing out_rhs + (idOccInfo in_bndr) True False + +------------------- +simple_out_bind_pair :: SimpleOptEnv + -> InId -> Maybe OutId -> OutExpr + -> OccInfo -> Bool -> Bool + -> (SimpleOptEnv, Maybe (OutVar, OutExpr)) +simple_out_bind_pair env in_bndr mb_out_bndr out_rhs + occ_info active stable_unf + | ASSERT2( isNonCoVarId in_bndr, ppr in_bndr ) + -- Type and coercion bindings are caught earlier + -- See Note [CoreSyn type and coercion invariant] + post_inline_unconditionally + = ( env' { soe_subst = extendIdSubst (soe_subst env) in_bndr out_rhs } + , Nothing) + + | otherwise + = ( env', Just (out_bndr, out_rhs) ) + where + (env', bndr1) = case mb_out_bndr of + Just out_bndr -> (env, out_bndr) + Nothing -> subst_opt_bndr env in_bndr + out_bndr = add_info env' in_bndr bndr1 + + post_inline_unconditionally :: Bool + post_inline_unconditionally + | isExportedId in_bndr = False -- Note [Exported Ids and trivial RHSs] + | stable_unf = False -- Note [Stable unfoldings and postInlineUnconditionally] + | not active = False -- in SimplUtils + | is_loop_breaker = False -- If it's a loop-breaker of any kind, don't inline + -- because it might be referred to "earlier" + | exprIsTrivial out_rhs = True + | coercible_hack = True + | otherwise = False + + is_loop_breaker = isWeakLoopBreaker occ_info + + -- See Note [Getting the map/coerce RULE to work] + coercible_hack | (Var fun, args) <- collectArgs out_rhs + , Just dc <- isDataConWorkId_maybe fun + , dc `hasKey` heqDataConKey || dc `hasKey` coercibleDataConKey + = all exprIsTrivial args + | otherwise + = False + +{- Note [Exported Ids and trivial RHSs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We obviously do not want to unconditionally inline an Id that is exported. +In SimplUtils, Note [Top level and postInlineUnconditionally], we +explain why we don't inline /any/ top-level things unconditionally, even +trivial ones. But we do here! Why? In the simple optimiser + + * We do no rule rewrites + * We do no call-site inlining + +Those differences obviate the reasons for not inlining a trivial rhs, +and increase the benefit for doing so. So we unconditionally inline trivial +rhss here. + +Note [Preserve join-binding arity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Be careful /not/ to eta-reduce the RHS of a join point, lest we lose +the join-point arity invariant. #15108 was caused by simplifying +the RHS with simple_opt_expr, which does eta-reduction. Solution: +simplify the RHS of a join point by simplifying under the lambdas +(which of course should be there). +-} + +---------------------- +subst_opt_bndrs :: SimpleOptEnv -> [InVar] -> (SimpleOptEnv, [OutVar]) +subst_opt_bndrs env bndrs = mapAccumL subst_opt_bndr env bndrs + +subst_opt_bndr :: SimpleOptEnv -> InVar -> (SimpleOptEnv, OutVar) +subst_opt_bndr env bndr + | isTyVar bndr = (env { soe_subst = subst_tv }, tv') + | isCoVar bndr = (env { soe_subst = subst_cv }, cv') + | otherwise = subst_opt_id_bndr env bndr + where + subst = soe_subst env + (subst_tv, tv') = substTyVarBndr subst bndr + (subst_cv, cv') = substCoVarBndr subst bndr + +subst_opt_id_bndr :: SimpleOptEnv -> InId -> (SimpleOptEnv, OutId) +-- Nuke all fragile IdInfo, unfolding, and RULES; +-- it gets added back later by add_info +-- Rather like SimplEnv.substIdBndr +-- +-- It's important to zap fragile OccInfo (which CoreSubst.substIdBndr +-- carefully does not do) because simplOptExpr invalidates it + +subst_opt_id_bndr env@(SOE { soe_subst = subst, soe_inl = inl }) old_id + = (env { soe_subst = new_subst, soe_inl = new_inl }, new_id) + where + Subst in_scope id_subst tv_subst cv_subst = subst + + id1 = uniqAway in_scope old_id + id2 = setIdType id1 (substTy subst (idType old_id)) + new_id = zapFragileIdInfo id2 + -- Zaps rules, unfolding, and fragile OccInfo + -- The unfolding and rules will get added back later, by add_info + + new_in_scope = in_scope `extendInScopeSet` new_id + + no_change = new_id == old_id + + -- Extend the substitution if the unique has changed, + -- See the notes with substTyVarBndr for the delSubstEnv + new_id_subst + | no_change = delVarEnv id_subst old_id + | otherwise = extendVarEnv id_subst old_id (Var new_id) + + new_subst = Subst new_in_scope new_id_subst tv_subst cv_subst + new_inl = delVarEnv inl old_id + +---------------------- +add_info :: SimpleOptEnv -> InVar -> OutVar -> OutVar +add_info env old_bndr new_bndr + | isTyVar old_bndr = new_bndr + | otherwise = maybeModifyIdInfo mb_new_info new_bndr + where + subst = soe_subst env + mb_new_info = substIdInfo subst new_bndr (idInfo old_bndr) + +simpleUnfoldingFun :: IdUnfoldingFun +simpleUnfoldingFun id + | isAlwaysActive (idInlineActivation id) = idUnfolding id + | otherwise = noUnfolding + +wrapLet :: Maybe (Id,CoreExpr) -> CoreExpr -> CoreExpr +wrapLet Nothing body = body +wrapLet (Just (b,r)) body = Let (NonRec b r) body + +{- +Note [Inline prag in simplOpt] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If there's an INLINE/NOINLINE pragma that restricts the phase in +which the binder can be inlined, we don't inline here; after all, +we don't know what phase we're in. Here's an example + + foo :: Int -> Int -> Int + {-# INLINE foo #-} + foo m n = inner m + where + {-# INLINE [1] inner #-} + inner m = m+n + + bar :: Int -> Int + bar n = foo n 1 + +When inlining 'foo' in 'bar' we want the let-binding for 'inner' +to remain visible until Phase 1 + +Note [Unfold compulsory unfoldings in LHSs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When the user writes `RULES map coerce = coerce` as a rule, the rule +will only ever match if simpleOptExpr replaces coerce by its unfolding +on the LHS, because that is the core that the rule matching engine +will find. So do that for everything that has a compulsory +unfolding. Also see Note [Desugaring coerce as cast] in Desugar. + +However, we don't want to inline 'seq', which happens to also have a +compulsory unfolding, so we only do this unfolding only for things +that are always-active. See Note [User-defined RULES for seq] in MkId. + +Note [Getting the map/coerce RULE to work] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We wish to allow the "map/coerce" RULE to fire: + + {-# RULES "map/coerce" map coerce = coerce #-} + +The naive core produced for this is + + forall a b (dict :: Coercible * a b). + map @a @b (coerce @a @b @dict) = coerce @[a] @[b] @dict' + + where dict' :: Coercible [a] [b] + dict' = ... + +This matches literal uses of `map coerce` in code, but that's not what we +want. We want it to match, say, `map MkAge` (where newtype Age = MkAge Int) +too. Some of this is addressed by compulsorily unfolding coerce on the LHS, +yielding + + forall a b (dict :: Coercible * a b). + map @a @b (\(x :: a) -> case dict of + MkCoercible (co :: a ~R# b) -> x |> co) = ... + +Getting better. But this isn't exactly what gets produced. This is because +Coercible essentially has ~R# as a superclass, and superclasses get eagerly +extracted during solving. So we get this: + + forall a b (dict :: Coercible * a b). + case Coercible_SCSel @* @a @b dict of + _ [Dead] -> map @a @b (\(x :: a) -> case dict of + MkCoercible (co :: a ~R# b) -> x |> co) = ... + +Unfortunately, this still abstracts over a Coercible dictionary. We really +want it to abstract over the ~R# evidence. So, we have Desugar.unfold_coerce, +which transforms the above to (see also Note [Desugaring coerce as cast] in +Desugar) + + forall a b (co :: a ~R# b). + let dict = MkCoercible @* @a @b co in + case Coercible_SCSel @* @a @b dict of + _ [Dead] -> map @a @b (\(x :: a) -> case dict of + MkCoercible (co :: a ~R# b) -> x |> co) = let dict = ... in ... + +Now, we need simpleOptExpr to fix this up. It does so by taking three +separate actions: + 1. Inline certain non-recursive bindings. The choice whether to inline + is made in simple_bind_pair. Note the rather specific check for + MkCoercible in there. + + 2. Stripping case expressions like the Coercible_SCSel one. + See the `Case` case of simple_opt_expr's `go` function. + + 3. Look for case expressions that unpack something that was + just packed and inline them. This is also done in simple_opt_expr's + `go` function. + +This is all a fair amount of special-purpose hackery, but it's for +a good cause. And it won't hurt other RULES and such that it comes across. + + +************************************************************************ +* * + Join points +* * +************************************************************************ +-} + +-- | Returns Just (bndr,rhs) if the binding is a join point: +-- If it's a JoinId, just return it +-- If it's not yet a JoinId but is always tail-called, +-- make it into a JoinId and return it. +-- In the latter case, eta-expand the RHS if necessary, to make the +-- lambdas explicit, as is required for join points +-- +-- Precondition: the InBndr has been occurrence-analysed, +-- so its OccInfo is valid +joinPointBinding_maybe :: InBndr -> InExpr -> Maybe (InBndr, InExpr) +joinPointBinding_maybe bndr rhs + | not (isId bndr) + = Nothing + + | isJoinId bndr + = Just (bndr, rhs) + + | AlwaysTailCalled join_arity <- tailCallInfo (idOccInfo bndr) + , (bndrs, body) <- etaExpandToJoinPoint join_arity rhs + , let str_sig = idStrictness bndr + str_arity = count isId bndrs -- Strictness demands are for Ids only + join_bndr = bndr `asJoinId` join_arity + `setIdStrictness` etaExpandStrictSig str_arity str_sig + = Just (join_bndr, mkLams bndrs body) + + | otherwise + = Nothing + +joinPointBindings_maybe :: [(InBndr, InExpr)] -> Maybe [(InBndr, InExpr)] +joinPointBindings_maybe bndrs + = mapM (uncurry joinPointBinding_maybe) bndrs + + +{- Note [Strictness and join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + + let f = \x. if x>200 then e1 else e1 + +and we know that f is strict in x. Then if we subsequently +discover that f is an arity-2 join point, we'll eta-expand it to + + let f = \x y. if x>200 then e1 else e1 + +and now it's only strict if applied to two arguments. So we should +adjust the strictness info. + +A more common case is when + + f = \x. error ".." + +and again its arity increases (#15517) +-} + +{- ********************************************************************* +* * + exprIsConApp_maybe +* * +************************************************************************ + +Note [exprIsConApp_maybe] +~~~~~~~~~~~~~~~~~~~~~~~~~ +exprIsConApp_maybe is a very important function. There are two principal +uses: + * case e of { .... } + * cls_op e, where cls_op is a class operation + +In both cases you want to know if e is of form (C e1..en) where C is +a data constructor. + +However e might not *look* as if + + +Note [exprIsConApp_maybe on literal strings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See #9400 and #13317. + +Conceptually, a string literal "abc" is just ('a':'b':'c':[]), but in Core +they are represented as unpackCString# "abc"# by MkCore.mkStringExprFS, or +unpackCStringUtf8# when the literal contains multi-byte UTF8 characters. + +For optimizations we want to be able to treat it as a list, so they can be +decomposed when used in a case-statement. exprIsConApp_maybe detects those +calls to unpackCString# and returns: + +Just (':', [Char], ['a', unpackCString# "bc"]). + +We need to be careful about UTF8 strings here. ""# contains a ByteString, so +we must parse it back into a FastString to split off the first character. +That way we can treat unpackCString# and unpackCStringUtf8# in the same way. + +We must also be caeful about + lvl = "foo"# + ...(unpackCString# lvl)... +to ensure that we see through the let-binding for 'lvl'. Hence the +(exprIsLiteral_maybe .. arg) in the guard before the call to +dealWithStringLiteral. + +Note [Push coercions in exprIsConApp_maybe] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In #13025 I found a case where we had + op (df @t1 @t2) -- op is a ClassOp +where + df = (/\a b. K e1 e2) |> g + +To get this to come out we need to simplify on the fly + ((/\a b. K e1 e2) |> g) @t1 @t2 + +Hence the use of pushCoArgs. + +Note [exprIsConApp_maybe on data constructors with wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Problem: +- some data constructors have wrappers +- these wrappers inline late (see MkId Note [Activation for data constructor wrappers]) +- but we still want case-of-known-constructor to fire early. + +Example: + data T = MkT !Int + $WMkT n = case n of n' -> MkT n' -- Wrapper for MkT + foo x = case $WMkT e of MkT y -> blah + +Here we want the case-of-known-constructor transformation to fire, giving + foo x = case e of x' -> let y = x' in blah + +Here's how exprIsConApp_maybe achieves this: + +0. Start with scrutinee = $WMkT e + +1. Inline $WMkT on-the-fly. That's why data-constructor wrappers are marked + as expandable. (See CoreUtils.isExpandableApp.) Now we have + scrutinee = (\n. case n of n' -> MkT n') e + +2. Beta-reduce the application, generating a floated 'let'. + See Note [beta-reduction in exprIsConApp_maybe] below. Now we have + scrutinee = case n of n' -> MkT n' + with floats {Let n = e} + +3. Float the "case x of x' ->" binding out. Now we have + scrutinee = MkT n' + with floats {Let n = e; case n of n' ->} + +And now we have a known-constructor MkT that we can return. + +Notice that both (2) and (3) require exprIsConApp_maybe to gather and return +a bunch of floats, both let and case bindings. + +Note [beta-reduction in exprIsConApp_maybe] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The unfolding a definition (_e.g._ a let-bound variable or a datacon wrapper) is +typically a function. For instance, take the wrapper for MkT in Note +[exprIsConApp_maybe on data constructors with wrappers]: + + $WMkT n = case n of { n' -> T n' } + +If `exprIsConApp_maybe` is trying to analyse `$MkT arg`, upon unfolding of $MkT, +it will see + + (\n -> case n of { n' -> T n' }) arg + +In order to go progress, `exprIsConApp_maybe` must perform a beta-reduction. + +We don't want to blindly substitute `arg` in the body of the function, because +it duplicates work. We can (and, in fact, used to) substitute `arg` in the body, +but only when `arg` is a variable (or something equally work-free). + +But, because of Note [exprIsConApp_maybe on data constructors with wrappers], +'exprIsConApp_maybe' now returns floats. So, instead, we can beta-reduce +_always_: + + (\x -> body) arg + +Is transformed into + + let x = arg in body + +Which, effectively, means emitting a float `let x = arg` and recursively +analysing the body. + +For newtypes, this strategy requires that their wrappers have compulsory unfoldings. +Suppose we have + newtype T a b where + MkT :: a -> T b a -- Note args swapped + +This defines a worker function MkT, a wrapper function $WMkT, and an axT: + $WMkT :: forall a b. a -> T b a + $WMkT = /\b a. \(x:a). MkT a b x -- A real binding + + MkT :: forall a b. a -> T a b + MkT = /\a b. \(x:a). x |> (ax a b) -- A compulsory unfolding + + axiom axT :: a ~R# T a b + +Now we are optimising + case $WMkT (I# 3) |> sym axT of I# y -> ... +we clearly want to simplify this. If $WMkT did not have a compulsory +unfolding, we would end up with + let a = I#3 in case a of I# y -> ... +because in general, we do this on-the-fly beta-reduction + (\x. e) blah --> let x = blah in e +and then float the the let. (Substitution would risk duplicating 'blah'.) + +But if the case-of-known-constructor doesn't actually fire (i.e. +exprIsConApp_maybe does not return Just) then nothing happens, and nothing +will happen the next time either. + +See test T16254, which checks the behavior of newtypes. +-} + +data ConCont = CC [CoreExpr] Coercion + -- Substitution already applied + +-- | Returns @Just ([b1..bp], dc, [t1..tk], [x1..xn])@ if the argument +-- expression is a *saturated* constructor application of the form @let b1 in +-- .. let bp in dc t1..tk x1 .. xn@, where t1..tk are the +-- *universally-quantified* type args of 'dc'. Floats can also be (and most +-- likely are) single-alternative case expressions. Why does +-- 'exprIsConApp_maybe' return floats? We may have to look through lets and +-- cases to detect that we are in the presence of a data constructor wrapper. In +-- this case, we need to return the lets and cases that we traversed. See Note +-- [exprIsConApp_maybe on data constructors with wrappers]. Data constructor wrappers +-- are unfolded late, but we really want to trigger case-of-known-constructor as +-- early as possible. See also Note [Activation for data constructor wrappers] +-- in MkId. +-- +-- We also return the incoming InScopeSet, augmented with +-- the binders from any [FloatBind] that we return +exprIsConApp_maybe :: InScopeEnv -> CoreExpr + -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr]) +exprIsConApp_maybe (in_scope, id_unf) expr + = go (Left in_scope) [] expr (CC [] (mkRepReflCo (exprType expr))) + where + go :: Either InScopeSet Subst + -- Left in-scope means "empty substitution" + -- Right subst means "apply this substitution to the CoreExpr" + -- NB: in the call (go subst floats expr cont) + -- the substitution applies to 'expr', but /not/ to 'floats' or 'cont' + -> [FloatBind] -> CoreExpr -> ConCont + -- Notice that the floats here are in reverse order + -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr]) + go subst floats (Tick t expr) cont + | not (tickishIsCode t) = go subst floats expr cont + + go subst floats (Cast expr co1) (CC args co2) + | Just (args', m_co1') <- pushCoArgs (subst_co subst co1) args + -- See Note [Push coercions in exprIsConApp_maybe] + = case m_co1' of + MCo co1' -> go subst floats expr (CC args' (co1' `mkTransCo` co2)) + MRefl -> go subst floats expr (CC args' co2) + + go subst floats (App fun arg) (CC args co) + = go subst floats fun (CC (subst_expr subst arg : args) co) + + go subst floats (Lam bndr body) (CC (arg:args) co) + | exprIsTrivial arg -- Don't duplicate stuff! + = go (extend subst bndr arg) floats body (CC args co) + | otherwise + = let (subst', bndr') = subst_bndr subst bndr + float = FloatLet (NonRec bndr' arg) + in go subst' (float:floats) body (CC args co) + + go subst floats (Let (NonRec bndr rhs) expr) cont + = let rhs' = subst_expr subst rhs + (subst', bndr') = subst_bndr subst bndr + float = FloatLet (NonRec bndr' rhs') + in go subst' (float:floats) expr cont + + go subst floats (Case scrut b _ [(con, vars, expr)]) cont + = let + scrut' = subst_expr subst scrut + (subst', b') = subst_bndr subst b + (subst'', vars') = subst_bndrs subst' vars + float = FloatCase scrut' b' con vars' + in + go subst'' (float:floats) expr cont + + go (Right sub) floats (Var v) cont + = go (Left (substInScope sub)) + floats + (lookupIdSubst (text "exprIsConApp" <+> ppr expr) sub v) + cont + + go (Left in_scope) floats (Var fun) cont@(CC args co) + + | Just con <- isDataConWorkId_maybe fun + , count isValArg args == idArity fun + = succeedWith in_scope floats $ + pushCoDataCon con args co + + -- Look through data constructor wrappers: they inline late (See Note + -- [Activation for data constructor wrappers]) but we want to do + -- case-of-known-constructor optimisation eagerly. + | isDataConWrapId fun + , let rhs = uf_tmpl (realIdUnfolding fun) + = go (Left in_scope) floats rhs cont + + -- Look through dictionary functions; see Note [Unfolding DFuns] + | DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = dfun_args } <- unfolding + , bndrs `equalLength` args -- See Note [DFun arity check] + , let subst = mkOpenSubst in_scope (bndrs `zip` args) + = succeedWith in_scope floats $ + pushCoDataCon con (map (substExpr (text "exprIsConApp1") subst) dfun_args) co + + -- Look through unfoldings, but only arity-zero one; + -- if arity > 0 we are effectively inlining a function call, + -- and that is the business of callSiteInline. + -- In practice, without this test, most of the "hits" were + -- CPR'd workers getting inlined back into their wrappers, + | idArity fun == 0 + , Just rhs <- expandUnfolding_maybe unfolding + , let in_scope' = extendInScopeSetSet in_scope (exprFreeVars rhs) + = go (Left in_scope') floats rhs cont + + -- See Note [exprIsConApp_maybe on literal strings] + | (fun `hasKey` unpackCStringIdKey) || + (fun `hasKey` unpackCStringUtf8IdKey) + , [arg] <- args + , Just (LitString str) <- exprIsLiteral_maybe (in_scope, id_unf) arg + = succeedWith in_scope floats $ + dealWithStringLiteral fun str co + where + unfolding = id_unf fun + + go _ _ _ _ = Nothing + + succeedWith :: InScopeSet -> [FloatBind] + -> Maybe (DataCon, [Type], [CoreExpr]) + -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr]) + succeedWith in_scope rev_floats x + = do { (con, tys, args) <- x + ; let floats = reverse rev_floats + ; return (in_scope, floats, con, tys, args) } + + ---------------------------- + -- Operations on the (Either InScopeSet CoreSubst) + -- The Left case is wildly dominant + subst_co (Left {}) co = co + subst_co (Right s) co = CoreSubst.substCo s co + + subst_expr (Left {}) e = e + subst_expr (Right s) e = substExpr (text "exprIsConApp2") s e + + subst_bndr msubst bndr + = (Right subst', bndr') + where + (subst', bndr') = substBndr subst bndr + subst = case msubst of + Left in_scope -> mkEmptySubst in_scope + Right subst -> subst + + subst_bndrs subst bs = mapAccumL subst_bndr subst bs + + extend (Left in_scope) v e = Right (extendSubst (mkEmptySubst in_scope) v e) + extend (Right s) v e = Right (extendSubst s v e) + + +-- See Note [exprIsConApp_maybe on literal strings] +dealWithStringLiteral :: Var -> BS.ByteString -> Coercion + -> Maybe (DataCon, [Type], [CoreExpr]) + +-- This is not possible with user-supplied empty literals, MkCore.mkStringExprFS +-- turns those into [] automatically, but just in case something else in GHC +-- generates a string literal directly. +dealWithStringLiteral _ str co + | BS.null str + = pushCoDataCon nilDataCon [Type charTy] co + +dealWithStringLiteral fun str co + = let strFS = mkFastStringByteString str + + char = mkConApp charDataCon [mkCharLit (headFS strFS)] + charTail = bytesFS (tailFS strFS) + + -- In singleton strings, just add [] instead of unpackCstring# ""#. + rest = if BS.null charTail + then mkConApp nilDataCon [Type charTy] + else App (Var fun) + (Lit (LitString charTail)) + + in pushCoDataCon consDataCon [Type charTy, char, rest] co + +{- +Note [Unfolding DFuns] +~~~~~~~~~~~~~~~~~~~~~~ +DFuns look like + + df :: forall a b. (Eq a, Eq b) -> Eq (a,b) + df a b d_a d_b = MkEqD (a,b) ($c1 a b d_a d_b) + ($c2 a b d_a d_b) + +So to split it up we just need to apply the ops $c1, $c2 etc +to the very same args as the dfun. It takes a little more work +to compute the type arguments to the dictionary constructor. + +Note [DFun arity check] +~~~~~~~~~~~~~~~~~~~~~~~ +Here we check that the total number of supplied arguments (inclding +type args) matches what the dfun is expecting. This may be *less* +than the ordinary arity of the dfun: see Note [DFun unfoldings] in CoreSyn +-} + +exprIsLiteral_maybe :: InScopeEnv -> CoreExpr -> Maybe Literal +-- Same deal as exprIsConApp_maybe, but much simpler +-- Nevertheless we do need to look through unfoldings for +-- Integer and string literals, which are vigorously hoisted to top level +-- and not subsequently inlined +exprIsLiteral_maybe env@(_, id_unf) e + = case e of + Lit l -> Just l + Tick _ e' -> exprIsLiteral_maybe env e' -- dubious? + Var v | Just rhs <- expandUnfolding_maybe (id_unf v) + -> exprIsLiteral_maybe env rhs + _ -> Nothing + +{- +Note [exprIsLambda_maybe] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +exprIsLambda_maybe will, given an expression `e`, try to turn it into the form +`Lam v e'` (returned as `Just (v,e')`). Besides using lambdas, it looks through +casts (using the Push rule), and it unfolds function calls if the unfolding +has a greater arity than arguments are present. + +Currently, it is used in Rules.match, and is required to make +"map coerce = coerce" match. +-} + +exprIsLambda_maybe :: InScopeEnv -> CoreExpr + -> Maybe (Var, CoreExpr,[Tickish Id]) + -- See Note [exprIsLambda_maybe] + +-- The simple case: It is a lambda already +exprIsLambda_maybe _ (Lam x e) + = Just (x, e, []) + +-- Still straightforward: Ticks that we can float out of the way +exprIsLambda_maybe (in_scope_set, id_unf) (Tick t e) + | tickishFloatable t + , Just (x, e, ts) <- exprIsLambda_maybe (in_scope_set, id_unf) e + = Just (x, e, t:ts) + +-- Also possible: A casted lambda. Push the coercion inside +exprIsLambda_maybe (in_scope_set, id_unf) (Cast casted_e co) + | Just (x, e,ts) <- exprIsLambda_maybe (in_scope_set, id_unf) casted_e + -- Only do value lambdas. + -- this implies that x is not in scope in gamma (makes this code simpler) + , not (isTyVar x) && not (isCoVar x) + , ASSERT( not $ x `elemVarSet` tyCoVarsOfCo co) True + , Just (x',e') <- pushCoercionIntoLambda in_scope_set x e co + , let res = Just (x',e',ts) + = --pprTrace "exprIsLambda_maybe:Cast" (vcat [ppr casted_e,ppr co,ppr res)]) + res + +-- Another attempt: See if we find a partial unfolding +exprIsLambda_maybe (in_scope_set, id_unf) e + | (Var f, as, ts) <- collectArgsTicks tickishFloatable e + , idArity f > count isValArg as + -- Make sure there is hope to get a lambda + , Just rhs <- expandUnfolding_maybe (id_unf f) + -- Optimize, for beta-reduction + , let e' = simpleOptExprWith unsafeGlobalDynFlags (mkEmptySubst in_scope_set) (rhs `mkApps` as) + -- Recurse, because of possible casts + , Just (x', e'', ts') <- exprIsLambda_maybe (in_scope_set, id_unf) e' + , let res = Just (x', e'', ts++ts') + = -- pprTrace "exprIsLambda_maybe:Unfold" (vcat [ppr e, ppr (x',e'')]) + res + +exprIsLambda_maybe _ _e + = -- pprTrace "exprIsLambda_maybe:Fail" (vcat [ppr _e]) + Nothing + + +{- ********************************************************************* +* * + The "push rules" +* * +************************************************************************ + +Here we implement the "push rules" from FC papers: + +* The push-argument rules, where we can move a coercion past an argument. + We have + (fun |> co) arg + and we want to transform it to + (fun arg') |> co' + for some suitable co' and tranformed arg'. + +* The PushK rule for data constructors. We have + (K e1 .. en) |> co + and we want to tranform to + (K e1' .. en') + by pushing the coercion into the arguments +-} + +pushCoArgs :: CoercionR -> [CoreArg] -> Maybe ([CoreArg], MCoercion) +pushCoArgs co [] = return ([], MCo co) +pushCoArgs co (arg:args) = do { (arg', m_co1) <- pushCoArg co arg + ; case m_co1 of + MCo co1 -> do { (args', m_co2) <- pushCoArgs co1 args + ; return (arg':args', m_co2) } + MRefl -> return (arg':args, MRefl) } + +pushCoArg :: CoercionR -> CoreArg -> Maybe (CoreArg, MCoercion) +-- We have (fun |> co) arg, and we want to transform it to +-- (fun arg) |> co +-- This may fail, e.g. if (fun :: N) where N is a newtype +-- C.f. simplCast in Simplify.hs +-- 'co' is always Representational +-- If the returned coercion is Nothing, then it would have been reflexive +pushCoArg co (Type ty) = do { (ty', m_co') <- pushCoTyArg co ty + ; return (Type ty', m_co') } +pushCoArg co val_arg = do { (arg_co, m_co') <- pushCoValArg co + ; return (val_arg `mkCast` arg_co, m_co') } + +pushCoTyArg :: CoercionR -> Type -> Maybe (Type, MCoercionR) +-- We have (fun |> co) @ty +-- Push the coercion through to return +-- (fun @ty') |> co' +-- 'co' is always Representational +-- If the returned coercion is Nothing, then it would have been reflexive; +-- it's faster not to compute it, though. +pushCoTyArg co ty + -- The following is inefficient - don't do `eqType` here, the coercion + -- optimizer will take care of it. See #14737. + -- -- | tyL `eqType` tyR + -- -- = Just (ty, Nothing) + + | isReflCo co + = Just (ty, MRefl) + + | isForAllTy_ty tyL + = ASSERT2( isForAllTy_ty tyR, ppr co $$ ppr ty ) + Just (ty `mkCastTy` co1, MCo co2) + + | otherwise + = Nothing + where + Pair tyL tyR = coercionKind co + -- co :: tyL ~ tyR + -- tyL = forall (a1 :: k1). ty1 + -- tyR = forall (a2 :: k2). ty2 + + co1 = mkSymCo (mkNthCo Nominal 0 co) + -- co1 :: k2 ~N k1 + -- Note that NthCo can extract a Nominal equality between the + -- kinds of the types related by a coercion between forall-types. + -- See the NthCo case in CoreLint. + + co2 = mkInstCo co (mkGReflLeftCo Nominal ty co1) + -- co2 :: ty1[ (ty|>co1)/a1 ] ~ ty2[ ty/a2 ] + -- Arg of mkInstCo is always nominal, hence mkNomReflCo + +pushCoValArg :: CoercionR -> Maybe (Coercion, MCoercion) +-- We have (fun |> co) arg +-- Push the coercion through to return +-- (fun (arg |> co_arg)) |> co_res +-- 'co' is always Representational +-- If the second returned Coercion is actually Nothing, then no cast is necessary; +-- the returned coercion would have been reflexive. +pushCoValArg co + -- The following is inefficient - don't do `eqType` here, the coercion + -- optimizer will take care of it. See #14737. + -- -- | tyL `eqType` tyR + -- -- = Just (mkRepReflCo arg, Nothing) + + | isReflCo co + = Just (mkRepReflCo arg, MRefl) + + | isFunTy tyL + , (co1, co2) <- decomposeFunCo Representational co + -- If co :: (tyL1 -> tyL2) ~ (tyR1 -> tyR2) + -- then co1 :: tyL1 ~ tyR1 + -- co2 :: tyL2 ~ tyR2 + = ASSERT2( isFunTy tyR, ppr co $$ ppr arg ) + Just (mkSymCo co1, MCo co2) + + | otherwise + = Nothing + where + arg = funArgTy tyR + Pair tyL tyR = coercionKind co + +pushCoercionIntoLambda + :: InScopeSet -> Var -> CoreExpr -> CoercionR -> Maybe (Var, CoreExpr) +-- This implements the Push rule from the paper on coercions +-- (\x. e) |> co +-- ===> +-- (\x'. e |> co') +pushCoercionIntoLambda in_scope x e co + | ASSERT(not (isTyVar x) && not (isCoVar x)) True + , Pair s1s2 t1t2 <- coercionKind co + , Just (_s1,_s2) <- splitFunTy_maybe s1s2 + , Just (t1,_t2) <- splitFunTy_maybe t1t2 + = let (co1, co2) = decomposeFunCo Representational co + -- Should we optimize the coercions here? + -- Otherwise they might not match too well + x' = x `setIdType` t1 + in_scope' = in_scope `extendInScopeSet` x' + subst = extendIdSubst (mkEmptySubst in_scope') + x + (mkCast (Var x') co1) + in Just (x', substExpr (text "pushCoercionIntoLambda") subst e `mkCast` co2) + | otherwise + = pprTrace "exprIsLambda_maybe: Unexpected lambda in case" (ppr (Lam x e)) + Nothing + +pushCoDataCon :: DataCon -> [CoreExpr] -> Coercion + -> Maybe (DataCon + , [Type] -- Universal type args + , [CoreExpr]) -- All other args incl existentials +-- Implement the KPush reduction rule as described in "Down with kinds" +-- The transformation applies iff we have +-- (C e1 ... en) `cast` co +-- where co :: (T t1 .. tn) ~ to_ty +-- The left-hand one must be a T, because exprIsConApp returned True +-- but the right-hand one might not be. (Though it usually will.) +pushCoDataCon dc dc_args co + | isReflCo co || from_ty `eqType` to_ty -- try cheap test first + , let (univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) dc_args + = Just (dc, map exprToType univ_ty_args, rest_args) + + | Just (to_tc, to_tc_arg_tys) <- splitTyConApp_maybe to_ty + , to_tc == dataConTyCon dc + -- These two tests can fail; we might see + -- (C x y) `cast` (g :: T a ~ S [a]), + -- where S is a type function. In fact, exprIsConApp + -- will probably not be called in such circumstances, + -- but there's nothing wrong with it + + = let + tc_arity = tyConArity to_tc + dc_univ_tyvars = dataConUnivTyVars dc + dc_ex_tcvars = dataConExTyCoVars dc + arg_tys = dataConRepArgTys dc + + non_univ_args = dropList dc_univ_tyvars dc_args + (ex_args, val_args) = splitAtList dc_ex_tcvars non_univ_args + + -- Make the "Psi" from the paper + omegas = decomposeCo tc_arity co (tyConRolesRepresentational to_tc) + (psi_subst, to_ex_arg_tys) + = liftCoSubstWithEx Representational + dc_univ_tyvars + omegas + dc_ex_tcvars + (map exprToType ex_args) + + -- Cast the value arguments (which include dictionaries) + new_val_args = zipWith cast_arg arg_tys val_args + cast_arg arg_ty arg = mkCast arg (psi_subst arg_ty) + + to_ex_args = map Type to_ex_arg_tys + + dump_doc = vcat [ppr dc, ppr dc_univ_tyvars, ppr dc_ex_tcvars, + ppr arg_tys, ppr dc_args, + ppr ex_args, ppr val_args, ppr co, ppr from_ty, ppr to_ty, ppr to_tc ] + in + ASSERT2( eqType from_ty (mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args)), dump_doc ) + ASSERT2( equalLength val_args arg_tys, dump_doc ) + Just (dc, to_tc_arg_tys, to_ex_args ++ new_val_args) + + | otherwise + = Nothing + + where + Pair from_ty to_ty = coercionKind co + +collectBindersPushingCo :: CoreExpr -> ([Var], CoreExpr) +-- Collect lambda binders, pushing coercions inside if possible +-- E.g. (\x.e) |> g g :: -> blah +-- = (\x. e |> Nth 1 g) +-- +-- That is, +-- +-- collectBindersPushingCo ((\x.e) |> g) === ([x], e |> Nth 1 g) +collectBindersPushingCo e + = go [] e + where + -- Peel off lambdas until we hit a cast. + go :: [Var] -> CoreExpr -> ([Var], CoreExpr) + -- The accumulator is in reverse order + go bs (Lam b e) = go (b:bs) e + go bs (Cast e co) = go_c bs e co + go bs e = (reverse bs, e) + + -- We are in a cast; peel off casts until we hit a lambda. + go_c :: [Var] -> CoreExpr -> CoercionR -> ([Var], CoreExpr) + -- (go_c bs e c) is same as (go bs e (e |> c)) + go_c bs (Cast e co1) co2 = go_c bs e (co1 `mkTransCo` co2) + go_c bs (Lam b e) co = go_lam bs b e co + go_c bs e co = (reverse bs, mkCast e co) + + -- We are in a lambda under a cast; peel off lambdas and build a + -- new coercion for the body. + go_lam :: [Var] -> Var -> CoreExpr -> CoercionR -> ([Var], CoreExpr) + -- (go_lam bs b e c) is same as (go_c bs (\b.e) c) + go_lam bs b e co + | isTyVar b + , let Pair tyL tyR = coercionKind co + , ASSERT( isForAllTy_ty tyL ) + isForAllTy_ty tyR + , isReflCo (mkNthCo Nominal 0 co) -- See Note [collectBindersPushingCo] + = go_c (b:bs) e (mkInstCo co (mkNomReflCo (mkTyVarTy b))) + + | isCoVar b + , let Pair tyL tyR = coercionKind co + , ASSERT( isForAllTy_co tyL ) + isForAllTy_co tyR + , isReflCo (mkNthCo Nominal 0 co) -- See Note [collectBindersPushingCo] + , let cov = mkCoVarCo b + = go_c (b:bs) e (mkInstCo co (mkNomReflCo (mkCoercionTy cov))) + + | isId b + , let Pair tyL tyR = coercionKind co + , ASSERT( isFunTy tyL) isFunTy tyR + , (co_arg, co_res) <- decomposeFunCo Representational co + , isReflCo co_arg -- See Note [collectBindersPushingCo] + = go_c (b:bs) e co_res + + | otherwise = (reverse bs, mkCast (Lam b e) co) + +{- Note [collectBindersPushingCo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We just look for coercions of form + -> blah +(and similarly for foralls) to keep this function simple. We could do +more elaborate stuff, but it'd involve substitution etc. +-} diff --git a/compiler/coreSyn/CoreSeq.hs b/compiler/coreSyn/CoreSeq.hs new file mode 100644 --- /dev/null +++ b/compiler/coreSyn/CoreSeq.hs @@ -0,0 +1,113 @@ +-- | +-- Various utilities for forcing Core structures +-- +-- It can often be useful to force various parts of the AST. This module +-- provides a number of @seq@-like functions to accomplish this. + +module CoreSeq ( + -- * Utilities for forcing Core structures + seqExpr, seqExprs, seqUnfolding, seqRules, + megaSeqIdInfo, seqRuleInfo, seqBinds, + ) where + +import GhcPrelude + +import CoreSyn +import IdInfo +import Demand( seqDemand, seqStrictSig ) +import BasicTypes( seqOccInfo ) +import VarSet( seqDVarSet ) +import Var( varType, tyVarKind ) +import Type( seqType, isTyVar ) +import Coercion( seqCo ) +import Id( Id, idInfo ) + +-- | Evaluate all the fields of the 'IdInfo' that are generally demanded by the +-- compiler +megaSeqIdInfo :: IdInfo -> () +megaSeqIdInfo info + = seqRuleInfo (ruleInfo info) `seq` + +-- Omitting this improves runtimes a little, presumably because +-- some unfoldings are not calculated at all +-- seqUnfolding (unfoldingInfo info) `seq` + + seqDemand (demandInfo info) `seq` + seqStrictSig (strictnessInfo info) `seq` + seqCaf (cafInfo info) `seq` + seqOneShot (oneShotInfo info) `seq` + seqOccInfo (occInfo info) + +seqOneShot :: OneShotInfo -> () +seqOneShot l = l `seq` () + +seqRuleInfo :: RuleInfo -> () +seqRuleInfo (RuleInfo rules fvs) = seqRules rules `seq` seqDVarSet fvs + +seqCaf :: CafInfo -> () +seqCaf c = c `seq` () + +seqRules :: [CoreRule] -> () +seqRules [] = () +seqRules (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs } : rules) + = seqBndrs bndrs `seq` seqExprs (rhs:args) `seq` seqRules rules +seqRules (BuiltinRule {} : rules) = seqRules rules + +seqExpr :: CoreExpr -> () +seqExpr (Var v) = v `seq` () +seqExpr (Lit lit) = lit `seq` () +seqExpr (App f a) = seqExpr f `seq` seqExpr a +seqExpr (Lam b e) = seqBndr b `seq` seqExpr e +seqExpr (Let b e) = seqBind b `seq` seqExpr e +seqExpr (Case e b t as) = seqExpr e `seq` seqBndr b `seq` seqType t `seq` seqAlts as +seqExpr (Cast e co) = seqExpr e `seq` seqCo co +seqExpr (Tick n e) = seqTickish n `seq` seqExpr e +seqExpr (Type t) = seqType t +seqExpr (Coercion co) = seqCo co + +seqExprs :: [CoreExpr] -> () +seqExprs [] = () +seqExprs (e:es) = seqExpr e `seq` seqExprs es + +seqTickish :: Tickish Id -> () +seqTickish ProfNote{ profNoteCC = cc } = cc `seq` () +seqTickish HpcTick{} = () +seqTickish Breakpoint{ breakpointFVs = ids } = seqBndrs ids +seqTickish SourceNote{} = () + +seqBndr :: CoreBndr -> () +seqBndr b | isTyVar b = seqType (tyVarKind b) + | otherwise = seqType (varType b) `seq` + megaSeqIdInfo (idInfo b) + +seqBndrs :: [CoreBndr] -> () +seqBndrs [] = () +seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs + +seqBinds :: [Bind CoreBndr] -> () +seqBinds bs = foldr (seq . seqBind) () bs + +seqBind :: Bind CoreBndr -> () +seqBind (NonRec b e) = seqBndr b `seq` seqExpr e +seqBind (Rec prs) = seqPairs prs + +seqPairs :: [(CoreBndr, CoreExpr)] -> () +seqPairs [] = () +seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs + +seqAlts :: [CoreAlt] -> () +seqAlts [] = () +seqAlts ((c,bs,e):alts) = c `seq` seqBndrs bs `seq` seqExpr e `seq` seqAlts alts + +seqUnfolding :: Unfolding -> () +seqUnfolding (CoreUnfolding { uf_tmpl = e, uf_is_top = top, + uf_is_value = b1, uf_is_work_free = b2, + uf_expandable = b3, uf_is_conlike = b4, + uf_guidance = g}) + = seqExpr e `seq` top `seq` b1 `seq` b2 `seq` b3 `seq` b4 `seq` seqGuidance g + +seqUnfolding _ = () + +seqGuidance :: UnfoldingGuidance -> () +seqGuidance (UnfIfGoodArgs ns n b) = n `seq` sum ns `seq` b `seq` () +seqGuidance _ = () diff --git a/compiler/coreSyn/CoreStats.hs b/compiler/coreSyn/CoreStats.hs new file mode 100644 --- /dev/null +++ b/compiler/coreSyn/CoreStats.hs @@ -0,0 +1,137 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-2015 +-} + +-- | Functions to computing the statistics reflective of the "size" +-- of a Core expression +module CoreStats ( + -- * Expression and bindings size + coreBindsSize, exprSize, + CoreStats(..), coreBindsStats, exprStats, + ) where + +import GhcPrelude + +import BasicTypes +import CoreSyn +import Outputable +import Coercion +import Var +import Type (Type, typeSize) +import Id (isJoinId) + +data CoreStats = CS { cs_tm :: !Int -- Terms + , cs_ty :: !Int -- Types + , cs_co :: !Int -- Coercions + , cs_vb :: !Int -- Local value bindings + , cs_jb :: !Int } -- Local join bindings + + +instance Outputable CoreStats where + ppr (CS { cs_tm = i1, cs_ty = i2, cs_co = i3, cs_vb = i4, cs_jb = i5 }) + = braces (sep [text "terms:" <+> intWithCommas i1 <> comma, + text "types:" <+> intWithCommas i2 <> comma, + text "coercions:" <+> intWithCommas i3 <> comma, + text "joins:" <+> intWithCommas i5 <> char '/' <> + intWithCommas (i4 + i5) ]) + +plusCS :: CoreStats -> CoreStats -> CoreStats +plusCS (CS { cs_tm = p1, cs_ty = q1, cs_co = r1, cs_vb = v1, cs_jb = j1 }) + (CS { cs_tm = p2, cs_ty = q2, cs_co = r2, cs_vb = v2, cs_jb = j2 }) + = CS { cs_tm = p1+p2, cs_ty = q1+q2, cs_co = r1+r2, cs_vb = v1+v2 + , cs_jb = j1+j2 } + +zeroCS, oneTM :: CoreStats +zeroCS = CS { cs_tm = 0, cs_ty = 0, cs_co = 0, cs_vb = 0, cs_jb = 0 } +oneTM = zeroCS { cs_tm = 1 } + +sumCS :: (a -> CoreStats) -> [a] -> CoreStats +sumCS f = foldl' (\s a -> plusCS s (f a)) zeroCS + +coreBindsStats :: [CoreBind] -> CoreStats +coreBindsStats = sumCS (bindStats TopLevel) + +bindStats :: TopLevelFlag -> CoreBind -> CoreStats +bindStats top_lvl (NonRec v r) = bindingStats top_lvl v r +bindStats top_lvl (Rec prs) = sumCS (\(v,r) -> bindingStats top_lvl v r) prs + +bindingStats :: TopLevelFlag -> Var -> CoreExpr -> CoreStats +bindingStats top_lvl v r = letBndrStats top_lvl v `plusCS` exprStats r + +bndrStats :: Var -> CoreStats +bndrStats v = oneTM `plusCS` tyStats (varType v) + +letBndrStats :: TopLevelFlag -> Var -> CoreStats +letBndrStats top_lvl v + | isTyVar v || isTopLevel top_lvl = bndrStats v + | isJoinId v = oneTM { cs_jb = 1 } `plusCS` ty_stats + | otherwise = oneTM { cs_vb = 1 } `plusCS` ty_stats + where + ty_stats = tyStats (varType v) + +exprStats :: CoreExpr -> CoreStats +exprStats (Var {}) = oneTM +exprStats (Lit {}) = oneTM +exprStats (Type t) = tyStats t +exprStats (Coercion c) = coStats c +exprStats (App f a) = exprStats f `plusCS` exprStats a +exprStats (Lam b e) = bndrStats b `plusCS` exprStats e +exprStats (Let b e) = bindStats NotTopLevel b `plusCS` exprStats e +exprStats (Case e b _ as) = exprStats e `plusCS` bndrStats b + `plusCS` sumCS altStats as +exprStats (Cast e co) = coStats co `plusCS` exprStats e +exprStats (Tick _ e) = exprStats e + +altStats :: CoreAlt -> CoreStats +altStats (_, bs, r) = altBndrStats bs `plusCS` exprStats r + +altBndrStats :: [Var] -> CoreStats +-- Charge one for the alternative, not for each binder +altBndrStats vs = oneTM `plusCS` sumCS (tyStats . varType) vs + +tyStats :: Type -> CoreStats +tyStats ty = zeroCS { cs_ty = typeSize ty } + +coStats :: Coercion -> CoreStats +coStats co = zeroCS { cs_co = coercionSize co } + +coreBindsSize :: [CoreBind] -> Int +-- We use coreBindStats for user printout +-- but this one is a quick and dirty basis for +-- the simplifier's tick limit +coreBindsSize bs = sum (map bindSize bs) + +exprSize :: CoreExpr -> Int +-- ^ A measure of the size of the expressions, strictly greater than 0 +-- Counts *leaves*, not internal nodes. Types and coercions are not counted. +exprSize (Var _) = 1 +exprSize (Lit _) = 1 +exprSize (App f a) = exprSize f + exprSize a +exprSize (Lam b e) = bndrSize b + exprSize e +exprSize (Let b e) = bindSize b + exprSize e +exprSize (Case e b _ as) = exprSize e + bndrSize b + 1 + sum (map altSize as) +exprSize (Cast e _) = 1 + exprSize e +exprSize (Tick n e) = tickSize n + exprSize e +exprSize (Type _) = 1 +exprSize (Coercion _) = 1 + +tickSize :: Tickish Id -> Int +tickSize (ProfNote _ _ _) = 1 +tickSize _ = 1 + +bndrSize :: Var -> Int +bndrSize _ = 1 + +bndrsSize :: [Var] -> Int +bndrsSize = sum . map bndrSize + +bindSize :: CoreBind -> Int +bindSize (NonRec b e) = bndrSize b + exprSize e +bindSize (Rec prs) = sum (map pairSize prs) + +pairSize :: (Var, CoreExpr) -> Int +pairSize (b,e) = bndrSize b + exprSize e + +altSize :: CoreAlt -> Int +altSize (_,bs,e) = bndrsSize bs + exprSize e diff --git a/compiler/coreSyn/CoreSubst.hs b/compiler/coreSyn/CoreSubst.hs new file mode 100644 --- /dev/null +++ b/compiler/coreSyn/CoreSubst.hs @@ -0,0 +1,758 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Utility functions on @Core@ syntax +-} + +{-# LANGUAGE CPP #-} +module CoreSubst ( + -- * Main data types + Subst(..), -- Implementation exported for supercompiler's Renaming.hs only + TvSubstEnv, IdSubstEnv, InScopeSet, + + -- ** Substituting into expressions and related types + deShadowBinds, substSpec, substRulesForImportedIds, + substTy, substCo, substExpr, substExprSC, substBind, substBindSC, + substUnfolding, substUnfoldingSC, + lookupIdSubst, lookupTCvSubst, substIdOcc, + substTickish, substDVarSet, substIdInfo, + + -- ** Operations on substitutions + emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, substInScope, isEmptySubst, + extendIdSubst, extendIdSubstList, extendTCvSubst, extendTvSubstList, + extendSubst, extendSubstList, extendSubstWithVar, zapSubstEnv, + addInScopeSet, extendInScope, extendInScopeList, extendInScopeIds, + isInScope, setInScope, getTCvSubst, extendTvSubst, extendCvSubst, + delBndr, delBndrs, + + -- ** Substituting and cloning binders + substBndr, substBndrs, substRecBndrs, substTyVarBndr, substCoVarBndr, + cloneBndr, cloneBndrs, cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs, + + ) where + +#include "HsVersions.h" + + +import GhcPrelude + +import CoreSyn +import CoreFVs +import CoreSeq +import CoreUtils +import qualified Type +import qualified Coercion + + -- We are defining local versions +import Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList + , isInScope, substTyVarBndr, cloneTyVarBndr ) +import Coercion hiding ( substCo, substCoVarBndr ) + +import PrelNames +import VarSet +import VarEnv +import Id +import Name ( Name ) +import Var +import IdInfo +import UniqSupply +import Maybes +import Util +import Outputable +import PprCore () -- Instances +import Data.List + + + +{- +************************************************************************ +* * +\subsection{Substitutions} +* * +************************************************************************ +-} + +-- | A substitution environment, containing 'Id', 'TyVar', and 'CoVar' +-- substitutions. +-- +-- Some invariants apply to how you use the substitution: +-- +-- 1. Note [The substitution invariant] in TyCoRep +-- +-- 2. Note [Substitutions apply only once] in TyCoRep +data Subst + = Subst InScopeSet -- Variables in in scope (both Ids and TyVars) /after/ + -- applying the substitution + IdSubstEnv -- Substitution from NcIds to CoreExprs + TvSubstEnv -- Substitution from TyVars to Types + CvSubstEnv -- Substitution from CoVars to Coercions + + -- INVARIANT 1: See TyCoRep Note [The substitution invariant] + -- This is what lets us deal with name capture properly + -- It's a hard invariant to check... + -- + -- INVARIANT 2: The substitution is apply-once; see Note [Apply once] with + -- Types.TvSubstEnv + -- + -- INVARIANT 3: See Note [Extending the Subst] + +{- +Note [Extending the Subst] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +For a core Subst, which binds Ids as well, we make a different choice for Ids +than we do for TyVars. + +For TyVars, see Note [Extending the TCvSubst] with Type.TvSubstEnv + +For Ids, we have a different invariant + The IdSubstEnv is extended *only* when the Unique on an Id changes + Otherwise, we just extend the InScopeSet + +In consequence: + +* If all subst envs are empty, substExpr would be a + no-op, so substExprSC ("short cut") does nothing. + + However, substExpr still goes ahead and substitutes. Reason: we may + want to replace existing Ids with new ones from the in-scope set, to + avoid space leaks. + +* In substIdBndr, we extend the IdSubstEnv only when the unique changes + +* If the CvSubstEnv, TvSubstEnv and IdSubstEnv are all empty, + substExpr does nothing (Note that the above rule for substIdBndr + maintains this property. If the incoming envts are both empty, then + substituting the type and IdInfo can't change anything.) + +* In lookupIdSubst, we *must* look up the Id in the in-scope set, because + it may contain non-trivial changes. Example: + (/\a. \x:a. ...x...) Int + We extend the TvSubstEnv with [a |-> Int]; but x's unique does not change + so we only extend the in-scope set. Then we must look up in the in-scope + set when we find the occurrence of x. + +* The requirement to look up the Id in the in-scope set means that we + must NOT take no-op short cut when the IdSubst is empty. + We must still look up every Id in the in-scope set. + +* (However, we don't need to do so for expressions found in the IdSubst + itself, whose range is assumed to be correct wrt the in-scope set.) + +Why do we make a different choice for the IdSubstEnv than the +TvSubstEnv and CvSubstEnv? + +* For Ids, we change the IdInfo all the time (e.g. deleting the + unfolding), and adding it back later, so using the TyVar convention + would entail extending the substitution almost all the time + +* The simplifier wants to look up in the in-scope set anyway, in case it + can see a better unfolding from an enclosing case expression + +* For TyVars, only coercion variables can possibly change, and they are + easy to spot +-} + +-- | An environment for substituting for 'Id's +type IdSubstEnv = IdEnv CoreExpr -- Domain is NcIds, i.e. not coercions + +---------------------------- +isEmptySubst :: Subst -> Bool +isEmptySubst (Subst _ id_env tv_env cv_env) + = isEmptyVarEnv id_env && isEmptyVarEnv tv_env && isEmptyVarEnv cv_env + +emptySubst :: Subst +emptySubst = Subst emptyInScopeSet emptyVarEnv emptyVarEnv emptyVarEnv + +mkEmptySubst :: InScopeSet -> Subst +mkEmptySubst in_scope = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv + +mkSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> IdSubstEnv -> Subst +mkSubst in_scope tvs cvs ids = Subst in_scope ids tvs cvs + +-- | Find the in-scope set: see TyCoRep Note [The substitution invariant] +substInScope :: Subst -> InScopeSet +substInScope (Subst in_scope _ _ _) = in_scope + +-- | Remove all substitutions for 'Id's and 'Var's that might have been built up +-- while preserving the in-scope set +zapSubstEnv :: Subst -> Subst +zapSubstEnv (Subst in_scope _ _ _) = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv + +-- | Add a substitution for an 'Id' to the 'Subst': you must ensure that the in-scope set is +-- such that TyCoRep Note [The substitution invariant] +-- holds after extending the substitution like this +extendIdSubst :: Subst -> Id -> CoreExpr -> Subst +-- ToDo: add an ASSERT that fvs(subst-result) is already in the in-scope set +extendIdSubst (Subst in_scope ids tvs cvs) v r + = ASSERT2( isNonCoVarId v, ppr v $$ ppr r ) + Subst in_scope (extendVarEnv ids v r) tvs cvs + +-- | Adds multiple 'Id' substitutions to the 'Subst': see also 'extendIdSubst' +extendIdSubstList :: Subst -> [(Id, CoreExpr)] -> Subst +extendIdSubstList (Subst in_scope ids tvs cvs) prs + = ASSERT( all (isNonCoVarId . fst) prs ) + Subst in_scope (extendVarEnvList ids prs) tvs cvs + +-- | Add a substitution for a 'TyVar' to the 'Subst' +-- The 'TyVar' *must* be a real TyVar, and not a CoVar +-- You must ensure that the in-scope set is such that +-- TyCoRep Note [The substitution invariant] holds +-- after extending the substitution like this. +extendTvSubst :: Subst -> TyVar -> Type -> Subst +extendTvSubst (Subst in_scope ids tvs cvs) tv ty + = ASSERT( isTyVar tv ) + Subst in_scope ids (extendVarEnv tvs tv ty) cvs + +-- | Adds multiple 'TyVar' substitutions to the 'Subst': see also 'extendTvSubst' +extendTvSubstList :: Subst -> [(TyVar,Type)] -> Subst +extendTvSubstList subst vrs + = foldl' extend subst vrs + where + extend subst (v, r) = extendTvSubst subst v r + +-- | Add a substitution from a 'CoVar' to a 'Coercion' to the 'Subst': +-- you must ensure that the in-scope set satisfies +-- TyCoRep Note [The substitution invariant] +-- after extending the substitution like this +extendCvSubst :: Subst -> CoVar -> Coercion -> Subst +extendCvSubst (Subst in_scope ids tvs cvs) v r + = ASSERT( isCoVar v ) + Subst in_scope ids tvs (extendVarEnv cvs v r) + +-- | Add a substitution appropriate to the thing being substituted +-- (whether an expression, type, or coercion). See also +-- 'extendIdSubst', 'extendTvSubst', 'extendCvSubst' +extendSubst :: Subst -> Var -> CoreArg -> Subst +extendSubst subst var arg + = case arg of + Type ty -> ASSERT( isTyVar var ) extendTvSubst subst var ty + Coercion co -> ASSERT( isCoVar var ) extendCvSubst subst var co + _ -> ASSERT( isId var ) extendIdSubst subst var arg + +extendSubstWithVar :: Subst -> Var -> Var -> Subst +extendSubstWithVar subst v1 v2 + | isTyVar v1 = ASSERT( isTyVar v2 ) extendTvSubst subst v1 (mkTyVarTy v2) + | isCoVar v1 = ASSERT( isCoVar v2 ) extendCvSubst subst v1 (mkCoVarCo v2) + | otherwise = ASSERT( isId v2 ) extendIdSubst subst v1 (Var v2) + +-- | Add a substitution as appropriate to each of the terms being +-- substituted (whether expressions, types, or coercions). See also +-- 'extendSubst'. +extendSubstList :: Subst -> [(Var,CoreArg)] -> Subst +extendSubstList subst [] = subst +extendSubstList subst ((var,rhs):prs) = extendSubstList (extendSubst subst var rhs) prs + +-- | Find the substitution for an 'Id' in the 'Subst' +lookupIdSubst :: SDoc -> Subst -> Id -> CoreExpr +lookupIdSubst doc (Subst in_scope ids _ _) v + | not (isLocalId v) = Var v + | Just e <- lookupVarEnv ids v = e + | Just v' <- lookupInScope in_scope v = Var v' + -- Vital! See Note [Extending the Subst] + | otherwise = WARN( True, text "CoreSubst.lookupIdSubst" <+> doc <+> ppr v + $$ ppr in_scope) + Var v + +-- | Find the substitution for a 'TyVar' in the 'Subst' +lookupTCvSubst :: Subst -> TyVar -> Type +lookupTCvSubst (Subst _ _ tvs cvs) v + | isTyVar v + = lookupVarEnv tvs v `orElse` Type.mkTyVarTy v + | otherwise + = mkCoercionTy $ lookupVarEnv cvs v `orElse` mkCoVarCo v + +delBndr :: Subst -> Var -> Subst +delBndr (Subst in_scope ids tvs cvs) v + | isCoVar v = Subst in_scope ids tvs (delVarEnv cvs v) + | isTyVar v = Subst in_scope ids (delVarEnv tvs v) cvs + | otherwise = Subst in_scope (delVarEnv ids v) tvs cvs + +delBndrs :: Subst -> [Var] -> Subst +delBndrs (Subst in_scope ids tvs cvs) vs + = Subst in_scope (delVarEnvList ids vs) (delVarEnvList tvs vs) (delVarEnvList cvs vs) + -- Easiest thing is just delete all from all! + +-- | Simultaneously substitute for a bunch of variables +-- No left-right shadowing +-- ie the substitution for (\x \y. e) a1 a2 +-- so neither x nor y scope over a1 a2 +mkOpenSubst :: InScopeSet -> [(Var,CoreArg)] -> Subst +mkOpenSubst in_scope pairs = Subst in_scope + (mkVarEnv [(id,e) | (id, e) <- pairs, isId id]) + (mkVarEnv [(tv,ty) | (tv, Type ty) <- pairs]) + (mkVarEnv [(v,co) | (v, Coercion co) <- pairs]) + +------------------------------ +isInScope :: Var -> Subst -> Bool +isInScope v (Subst in_scope _ _ _) = v `elemInScopeSet` in_scope + +-- | Add the 'Var' to the in-scope set, but do not remove +-- any existing substitutions for it +addInScopeSet :: Subst -> VarSet -> Subst +addInScopeSet (Subst in_scope ids tvs cvs) vs + = Subst (in_scope `extendInScopeSetSet` vs) ids tvs cvs + +-- | Add the 'Var' to the in-scope set: as a side effect, +-- and remove any existing substitutions for it +extendInScope :: Subst -> Var -> Subst +extendInScope (Subst in_scope ids tvs cvs) v + = Subst (in_scope `extendInScopeSet` v) + (ids `delVarEnv` v) (tvs `delVarEnv` v) (cvs `delVarEnv` v) + +-- | Add the 'Var's to the in-scope set: see also 'extendInScope' +extendInScopeList :: Subst -> [Var] -> Subst +extendInScopeList (Subst in_scope ids tvs cvs) vs + = Subst (in_scope `extendInScopeSetList` vs) + (ids `delVarEnvList` vs) (tvs `delVarEnvList` vs) (cvs `delVarEnvList` vs) + +-- | Optimized version of 'extendInScopeList' that can be used if you are certain +-- all the things being added are 'Id's and hence none are 'TyVar's or 'CoVar's +extendInScopeIds :: Subst -> [Id] -> Subst +extendInScopeIds (Subst in_scope ids tvs cvs) vs + = Subst (in_scope `extendInScopeSetList` vs) + (ids `delVarEnvList` vs) tvs cvs + +setInScope :: Subst -> InScopeSet -> Subst +setInScope (Subst _ ids tvs cvs) in_scope = Subst in_scope ids tvs cvs + +-- Pretty printing, for debugging only + +instance Outputable Subst where + ppr (Subst in_scope ids tvs cvs) + = text " in_scope_doc + $$ text " IdSubst =" <+> ppr ids + $$ text " TvSubst =" <+> ppr tvs + $$ text " CvSubst =" <+> ppr cvs + <> char '>' + where + in_scope_doc = pprVarSet (getInScopeVars in_scope) (braces . fsep . map ppr) + +{- +************************************************************************ +* * + Substituting expressions +* * +************************************************************************ +-} + +-- | Apply a substitution to an entire 'CoreExpr'. Remember, you may only +-- apply the substitution /once/: +-- see Note [Substitutions apply only once] in TyCoRep +-- +-- Do *not* attempt to short-cut in the case of an empty substitution! +-- See Note [Extending the Subst] +substExprSC :: SDoc -> Subst -> CoreExpr -> CoreExpr +substExprSC doc subst orig_expr + | isEmptySubst subst = orig_expr + | otherwise = -- pprTrace "enter subst-expr" (doc $$ ppr orig_expr) $ + subst_expr doc subst orig_expr + +substExpr :: SDoc -> Subst -> CoreExpr -> CoreExpr +substExpr doc subst orig_expr = subst_expr doc subst orig_expr + +subst_expr :: SDoc -> Subst -> CoreExpr -> CoreExpr +subst_expr doc subst expr + = go expr + where + go (Var v) = lookupIdSubst (doc $$ text "subst_expr") subst v + go (Type ty) = Type (substTy subst ty) + go (Coercion co) = Coercion (substCo subst co) + go (Lit lit) = Lit lit + go (App fun arg) = App (go fun) (go arg) + go (Tick tickish e) = mkTick (substTickish subst tickish) (go e) + go (Cast e co) = Cast (go e) (substCo subst co) + -- Do not optimise even identity coercions + -- Reason: substitution applies to the LHS of RULES, and + -- if you "optimise" an identity coercion, you may + -- lose a binder. We optimise the LHS of rules at + -- construction time + + go (Lam bndr body) = Lam bndr' (subst_expr doc subst' body) + where + (subst', bndr') = substBndr subst bndr + + go (Let bind body) = Let bind' (subst_expr doc subst' body) + where + (subst', bind') = substBind subst bind + + go (Case scrut bndr ty alts) = Case (go scrut) bndr' (substTy subst ty) (map (go_alt subst') alts) + where + (subst', bndr') = substBndr subst bndr + + go_alt subst (con, bndrs, rhs) = (con, bndrs', subst_expr doc subst' rhs) + where + (subst', bndrs') = substBndrs subst bndrs + +-- | Apply a substitution to an entire 'CoreBind', additionally returning an updated 'Subst' +-- that should be used by subsequent substitutions. +substBind, substBindSC :: Subst -> CoreBind -> (Subst, CoreBind) + +substBindSC subst bind -- Short-cut if the substitution is empty + | not (isEmptySubst subst) + = substBind subst bind + | otherwise + = case bind of + NonRec bndr rhs -> (subst', NonRec bndr' rhs) + where + (subst', bndr') = substBndr subst bndr + Rec pairs -> (subst', Rec (bndrs' `zip` rhss')) + where + (bndrs, rhss) = unzip pairs + (subst', bndrs') = substRecBndrs subst bndrs + rhss' | isEmptySubst subst' + = rhss + | otherwise + = map (subst_expr (text "substBindSC") subst') rhss + +substBind subst (NonRec bndr rhs) + = (subst', NonRec bndr' (subst_expr (text "substBind") subst rhs)) + where + (subst', bndr') = substBndr subst bndr + +substBind subst (Rec pairs) + = (subst', Rec (bndrs' `zip` rhss')) + where + (bndrs, rhss) = unzip pairs + (subst', bndrs') = substRecBndrs subst bndrs + rhss' = map (subst_expr (text "substBind") subst') rhss + +-- | De-shadowing the program is sometimes a useful pre-pass. It can be done simply +-- by running over the bindings with an empty substitution, because substitution +-- returns a result that has no-shadowing guaranteed. +-- +-- (Actually, within a single /type/ there might still be shadowing, because +-- 'substTy' is a no-op for the empty substitution, but that's probably OK.) +-- +-- [Aug 09] This function is not used in GHC at the moment, but seems so +-- short and simple that I'm going to leave it here +deShadowBinds :: CoreProgram -> CoreProgram +deShadowBinds binds = snd (mapAccumL substBind emptySubst binds) + +{- +************************************************************************ +* * + Substituting binders +* * +************************************************************************ + +Remember that substBndr and friends are used when doing expression +substitution only. Their only business is substitution, so they +preserve all IdInfo (suitably substituted). For example, we *want* to +preserve occ info in rules. +-} + +-- | Substitutes a 'Var' for another one according to the 'Subst' given, returning +-- the result and an updated 'Subst' that should be used by subsequent substitutions. +-- 'IdInfo' is preserved by this process, although it is substituted into appropriately. +substBndr :: Subst -> Var -> (Subst, Var) +substBndr subst bndr + | isTyVar bndr = substTyVarBndr subst bndr + | isCoVar bndr = substCoVarBndr subst bndr + | otherwise = substIdBndr (text "var-bndr") subst subst bndr + +-- | Applies 'substBndr' to a number of 'Var's, accumulating a new 'Subst' left-to-right +substBndrs :: Subst -> [Var] -> (Subst, [Var]) +substBndrs subst bndrs = mapAccumL substBndr subst bndrs + +-- | Substitute in a mutually recursive group of 'Id's +substRecBndrs :: Subst -> [Id] -> (Subst, [Id]) +substRecBndrs subst bndrs + = (new_subst, new_bndrs) + where -- Here's the reason we need to pass rec_subst to subst_id + (new_subst, new_bndrs) = mapAccumL (substIdBndr (text "rec-bndr") new_subst) subst bndrs + +substIdBndr :: SDoc + -> Subst -- ^ Substitution to use for the IdInfo + -> Subst -> Id -- ^ Substitution and Id to transform + -> (Subst, Id) -- ^ Transformed pair + -- NB: unfolding may be zapped + +substIdBndr _doc rec_subst subst@(Subst in_scope env tvs cvs) old_id + = -- pprTrace "substIdBndr" (doc $$ ppr old_id $$ ppr in_scope) $ + (Subst (in_scope `extendInScopeSet` new_id) new_env tvs cvs, new_id) + where + id1 = uniqAway in_scope old_id -- id1 is cloned if necessary + id2 | no_type_change = id1 + | otherwise = setIdType id1 (substTy subst old_ty) + + old_ty = idType old_id + no_type_change = (isEmptyVarEnv tvs && isEmptyVarEnv cvs) || + noFreeVarsOfType old_ty + + -- new_id has the right IdInfo + -- The lazy-set is because we're in a loop here, with + -- rec_subst, when dealing with a mutually-recursive group + new_id = maybeModifyIdInfo mb_new_info id2 + mb_new_info = substIdInfo rec_subst id2 (idInfo id2) + -- NB: unfolding info may be zapped + + -- Extend the substitution if the unique has changed + -- See the notes with substTyVarBndr for the delVarEnv + new_env | no_change = delVarEnv env old_id + | otherwise = extendVarEnv env old_id (Var new_id) + + no_change = id1 == old_id + -- See Note [Extending the Subst] + -- it's /not/ necessary to check mb_new_info and no_type_change + +{- +Now a variant that unconditionally allocates a new unique. +It also unconditionally zaps the OccInfo. +-} + +-- | Very similar to 'substBndr', but it always allocates a new 'Unique' for +-- each variable in its output. It substitutes the IdInfo though. +cloneIdBndr :: Subst -> UniqSupply -> Id -> (Subst, Id) +cloneIdBndr subst us old_id + = clone_id subst subst (old_id, uniqFromSupply us) + +-- | Applies 'cloneIdBndr' to a number of 'Id's, accumulating a final +-- substitution from left to right +cloneIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id]) +cloneIdBndrs subst us ids + = mapAccumL (clone_id subst) subst (ids `zip` uniqsFromSupply us) + +cloneBndrs :: Subst -> UniqSupply -> [Var] -> (Subst, [Var]) +-- Works for all kinds of variables (typically case binders) +-- not just Ids +cloneBndrs subst us vs + = mapAccumL (\subst (v, u) -> cloneBndr subst u v) subst (vs `zip` uniqsFromSupply us) + +cloneBndr :: Subst -> Unique -> Var -> (Subst, Var) +cloneBndr subst uniq v + | isTyVar v = cloneTyVarBndr subst v uniq + | otherwise = clone_id subst subst (v,uniq) -- Works for coercion variables too + +-- | Clone a mutually recursive group of 'Id's +cloneRecIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id]) +cloneRecIdBndrs subst us ids + = (subst', ids') + where + (subst', ids') = mapAccumL (clone_id subst') subst + (ids `zip` uniqsFromSupply us) + +-- Just like substIdBndr, except that it always makes a new unique +-- It is given the unique to use +clone_id :: Subst -- Substitution for the IdInfo + -> Subst -> (Id, Unique) -- Substitution and Id to transform + -> (Subst, Id) -- Transformed pair + +clone_id rec_subst subst@(Subst in_scope idvs tvs cvs) (old_id, uniq) + = (Subst (in_scope `extendInScopeSet` new_id) new_idvs tvs new_cvs, new_id) + where + id1 = setVarUnique old_id uniq + id2 = substIdType subst id1 + new_id = maybeModifyIdInfo (substIdInfo rec_subst id2 (idInfo old_id)) id2 + (new_idvs, new_cvs) | isCoVar old_id = (idvs, extendVarEnv cvs old_id (mkCoVarCo new_id)) + | otherwise = (extendVarEnv idvs old_id (Var new_id), cvs) + +{- +************************************************************************ +* * + Types and Coercions +* * +************************************************************************ + +For types and coercions we just call the corresponding functions in +Type and Coercion, but we have to repackage the substitution, from a +Subst to a TCvSubst. +-} + +substTyVarBndr :: Subst -> TyVar -> (Subst, TyVar) +substTyVarBndr (Subst in_scope id_env tv_env cv_env) tv + = case Type.substTyVarBndr (TCvSubst in_scope tv_env cv_env) tv of + (TCvSubst in_scope' tv_env' cv_env', tv') + -> (Subst in_scope' id_env tv_env' cv_env', tv') + +cloneTyVarBndr :: Subst -> TyVar -> Unique -> (Subst, TyVar) +cloneTyVarBndr (Subst in_scope id_env tv_env cv_env) tv uniq + = case Type.cloneTyVarBndr (TCvSubst in_scope tv_env cv_env) tv uniq of + (TCvSubst in_scope' tv_env' cv_env', tv') + -> (Subst in_scope' id_env tv_env' cv_env', tv') + +substCoVarBndr :: Subst -> TyVar -> (Subst, TyVar) +substCoVarBndr (Subst in_scope id_env tv_env cv_env) cv + = case Coercion.substCoVarBndr (TCvSubst in_scope tv_env cv_env) cv of + (TCvSubst in_scope' tv_env' cv_env', cv') + -> (Subst in_scope' id_env tv_env' cv_env', cv') + +-- | See 'Type.substTy' +substTy :: Subst -> Type -> Type +substTy subst ty = Type.substTyUnchecked (getTCvSubst subst) ty + +getTCvSubst :: Subst -> TCvSubst +getTCvSubst (Subst in_scope _ tenv cenv) = TCvSubst in_scope tenv cenv + +-- | See 'Coercion.substCo' +substCo :: Subst -> Coercion -> Coercion +substCo subst co = Coercion.substCo (getTCvSubst subst) co + +{- +************************************************************************ +* * +\section{IdInfo substitution} +* * +************************************************************************ +-} + +substIdType :: Subst -> Id -> Id +substIdType subst@(Subst _ _ tv_env cv_env) id + | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env) || noFreeVarsOfType old_ty = id + | otherwise = setIdType id (substTy subst old_ty) + -- The tyCoVarsOfType is cheaper than it looks + -- because we cache the free tyvars of the type + -- in a Note in the id's type itself + where + old_ty = idType id + +------------------ +-- | Substitute into some 'IdInfo' with regard to the supplied new 'Id'. +substIdInfo :: Subst -> Id -> IdInfo -> Maybe IdInfo +substIdInfo subst new_id info + | nothing_to_do = Nothing + | otherwise = Just (info `setRuleInfo` substSpec subst new_id old_rules + `setUnfoldingInfo` substUnfolding subst old_unf) + where + old_rules = ruleInfo info + old_unf = unfoldingInfo info + nothing_to_do = isEmptyRuleInfo old_rules && not (isFragileUnfolding old_unf) + +------------------ +-- | Substitutes for the 'Id's within an unfolding +substUnfolding, substUnfoldingSC :: Subst -> Unfolding -> Unfolding + -- Seq'ing on the returned Unfolding is enough to cause + -- all the substitutions to happen completely + +substUnfoldingSC subst unf -- Short-cut version + | isEmptySubst subst = unf + | otherwise = substUnfolding subst unf + +substUnfolding subst df@(DFunUnfolding { df_bndrs = bndrs, df_args = args }) + = df { df_bndrs = bndrs', df_args = args' } + where + (subst',bndrs') = substBndrs subst bndrs + args' = map (substExpr (text "subst-unf:dfun") subst') args + +substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src }) + -- Retain an InlineRule! + | not (isStableSource src) -- Zap an unstable unfolding, to save substitution work + = NoUnfolding + | otherwise -- But keep a stable one! + = seqExpr new_tmpl `seq` + unf { uf_tmpl = new_tmpl } + where + new_tmpl = substExpr (text "subst-unf") subst tmpl + +substUnfolding _ unf = unf -- NoUnfolding, OtherCon + +------------------ +substIdOcc :: Subst -> Id -> Id +-- These Ids should not be substituted to non-Ids +substIdOcc subst v = case lookupIdSubst (text "substIdOcc") subst v of + Var v' -> v' + other -> pprPanic "substIdOcc" (vcat [ppr v <+> ppr other, ppr subst]) + +------------------ +-- | Substitutes for the 'Id's within the 'WorkerInfo' given the new function 'Id' +substSpec :: Subst -> Id -> RuleInfo -> RuleInfo +substSpec subst new_id (RuleInfo rules rhs_fvs) + = seqRuleInfo new_spec `seq` new_spec + where + subst_ru_fn = const (idName new_id) + new_spec = RuleInfo (map (substRule subst subst_ru_fn) rules) + (substDVarSet subst rhs_fvs) + +------------------ +substRulesForImportedIds :: Subst -> [CoreRule] -> [CoreRule] +substRulesForImportedIds subst rules + = map (substRule subst not_needed) rules + where + not_needed name = pprPanic "substRulesForImportedIds" (ppr name) + +------------------ +substRule :: Subst -> (Name -> Name) -> CoreRule -> CoreRule + +-- The subst_ru_fn argument is applied to substitute the ru_fn field +-- of the rule: +-- - Rules for *imported* Ids never change ru_fn +-- - Rules for *local* Ids are in the IdInfo for that Id, +-- and the ru_fn field is simply replaced by the new name +-- of the Id +substRule _ _ rule@(BuiltinRule {}) = rule +substRule subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args + , ru_fn = fn_name, ru_rhs = rhs + , ru_local = is_local }) + = rule { ru_bndrs = bndrs' + , ru_fn = if is_local + then subst_ru_fn fn_name + else fn_name + , ru_args = map (substExpr doc subst') args + , ru_rhs = substExpr (text "foo") subst' rhs } + -- Do NOT optimise the RHS (previously we did simplOptExpr here) + -- See Note [Substitute lazily] + where + doc = text "subst-rule" <+> ppr fn_name + (subst', bndrs') = substBndrs subst bndrs + +------------------ +substDVarSet :: Subst -> DVarSet -> DVarSet +substDVarSet subst fvs + = mkDVarSet $ fst $ foldr (subst_fv subst) ([], emptyVarSet) $ dVarSetElems fvs + where + subst_fv subst fv acc + | isId fv = expr_fvs (lookupIdSubst (text "substDVarSet") subst fv) isLocalVar emptyVarSet $! acc + | otherwise = tyCoFVsOfType (lookupTCvSubst subst fv) (const True) emptyVarSet $! acc + +------------------ +substTickish :: Subst -> Tickish Id -> Tickish Id +substTickish subst (Breakpoint n ids) + = Breakpoint n (map do_one ids) + where + do_one = getIdFromTrivialExpr . lookupIdSubst (text "subst_tickish") subst +substTickish _subst other = other + +{- Note [Substitute lazily] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The functions that substitute over IdInfo must be pretty lazy, because +they are knot-tied by substRecBndrs. + +One case in point was #10627 in which a rule for a function 'f' +referred to 'f' (at a different type) on the RHS. But instead of just +substituting in the rhs of the rule, we were calling simpleOptExpr, which +looked at the idInfo for 'f'; result <>. + +In any case we don't need to optimise the RHS of rules, or unfoldings, +because the simplifier will do that. + + +Note [substTickish] +~~~~~~~~~~~~~~~~~~~~~~ +A Breakpoint contains a list of Ids. What happens if we ever want to +substitute an expression for one of these Ids? + +First, we ensure that we only ever substitute trivial expressions for +these Ids, by marking them as NoOccInfo in the occurrence analyser. +Then, when substituting for the Id, we unwrap any type applications +and abstractions to get back to an Id, with getIdFromTrivialExpr. + +Second, we have to ensure that we never try to substitute a literal +for an Id in a breakpoint. We ensure this by never storing an Id with +an unlifted type in a Breakpoint - see Coverage.mkTickish. +Breakpoints can't handle free variables with unlifted types anyway. +-} + +{- +Note [Worker inlining] +~~~~~~~~~~~~~~~~~~~~~~ +A worker can get sustituted away entirely. + - it might be trivial + - it might simply be very small +We do not treat an InlWrapper as an 'occurrence' in the occurrence +analyser, so it's possible that the worker is not even in scope any more. + +In all all these cases we simply drop the special case, returning to +InlVanilla. The WARN is just so I can see if it happens a lot. +-} + diff --git a/compiler/coreSyn/CoreSyn.hs b/compiler/coreSyn/CoreSyn.hs new file mode 100644 --- /dev/null +++ b/compiler/coreSyn/CoreSyn.hs @@ -0,0 +1,2232 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE BangPatterns #-} + +-- | CoreSyn holds all the main data types for use by for the Glasgow Haskell Compiler midsection +module CoreSyn ( + -- * Main data types + Expr(..), Alt, Bind(..), AltCon(..), Arg, + Tickish(..), TickishScoping(..), TickishPlacement(..), + CoreProgram, CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr, + TaggedExpr, TaggedAlt, TaggedBind, TaggedArg, TaggedBndr(..), deTagExpr, + + -- * In/Out type synonyms + InId, InBind, InExpr, InAlt, InArg, InType, InKind, + InBndr, InVar, InCoercion, InTyVar, InCoVar, + OutId, OutBind, OutExpr, OutAlt, OutArg, OutType, OutKind, + OutBndr, OutVar, OutCoercion, OutTyVar, OutCoVar, MOutCoercion, + + -- ** 'Expr' construction + mkLet, mkLets, mkLetNonRec, mkLetRec, mkLams, + mkApps, mkTyApps, mkCoApps, mkVarApps, mkTyArg, + + mkIntLit, mkIntLitInt, + mkWordLit, mkWordLitWord, + mkWord64LitWord64, mkInt64LitInt64, + mkCharLit, mkStringLit, + mkFloatLit, mkFloatLitFloat, + mkDoubleLit, mkDoubleLitDouble, + + mkConApp, mkConApp2, mkTyBind, mkCoBind, + varToCoreExpr, varsToCoreExprs, + + isId, cmpAltCon, cmpAlt, ltAlt, + + -- ** Simple 'Expr' access functions and predicates + bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, + collectBinders, collectTyBinders, collectTyAndValBinders, + collectNBinders, + collectArgs, stripNArgs, collectArgsTicks, flattenBinds, + + exprToType, exprToCoercion_maybe, + applyTypeToArg, + + isValArg, isTypeArg, isCoArg, isTyCoArg, valArgCount, valBndrCount, + isRuntimeArg, isRuntimeVar, + + -- * Tick-related functions + tickishCounts, tickishScoped, tickishScopesLike, tickishFloatable, + tickishCanSplit, mkNoCount, mkNoScope, + tickishIsCode, tickishPlace, + tickishContains, + + -- * Unfolding data types + Unfolding(..), UnfoldingGuidance(..), UnfoldingSource(..), + + -- ** Constructing 'Unfolding's + noUnfolding, bootUnfolding, evaldUnfolding, mkOtherCon, + unSaturatedOk, needSaturated, boringCxtOk, boringCxtNotOk, + + -- ** Predicates and deconstruction on 'Unfolding' + unfoldingTemplate, expandUnfolding_maybe, + maybeUnfoldingTemplate, otherCons, + isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, + isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding, + isStableUnfolding, isFragileUnfolding, hasSomeUnfolding, + isBootUnfolding, + canUnfold, neverUnfoldGuidance, isStableSource, + + -- * Annotated expression data types + AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt, + + -- ** Operations on annotated expressions + collectAnnArgs, collectAnnArgsTicks, + + -- ** Operations on annotations + deAnnotate, deAnnotate', deAnnAlt, deAnnBind, + collectAnnBndrs, collectNAnnBndrs, + + -- * Orphanhood + IsOrphan(..), isOrphan, notOrphan, chooseOrphanAnchor, + + -- * Core rule data types + CoreRule(..), RuleBase, + RuleName, RuleFun, IdUnfoldingFun, InScopeEnv, + RuleEnv(..), mkRuleEnv, emptyRuleEnv, + + -- ** Operations on 'CoreRule's + ruleArity, ruleName, ruleIdName, ruleActivation, + setRuleIdName, ruleModule, + isBuiltinRule, isLocalRule, isAutoRule, + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import CostCentre +import VarEnv( InScopeSet ) +import Var +import Type +import Coercion +import Name +import NameSet +import NameEnv( NameEnv, emptyNameEnv ) +import Literal +import DataCon +import Module +import BasicTypes +import DynFlags +import Outputable +import Util +import UniqSet +import SrcLoc ( RealSrcSpan, containsSpan ) +import Binary + +import Data.Data hiding (TyCon) +import Data.Int +import Data.Word + +infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`, `App`, `mkCoApps` +-- Left associative, so that we can say (f `mkTyApps` xs `mkVarApps` ys) + +{- +************************************************************************ +* * +\subsection{The main data types} +* * +************************************************************************ + +These data types are the heart of the compiler +-} + +-- | This is the data type that represents GHCs core intermediate language. Currently +-- GHC uses System FC for this purpose, +-- which is closely related to the simpler and better known System F . +-- +-- We get from Haskell source to this Core language in a number of stages: +-- +-- 1. The source code is parsed into an abstract syntax tree, which is represented +-- by the data type 'HsExpr.HsExpr' with the names being 'RdrName.RdrNames' +-- +-- 2. This syntax tree is /renamed/, which attaches a 'Unique.Unique' to every 'RdrName.RdrName' +-- (yielding a 'Name.Name') to disambiguate identifiers which are lexically identical. +-- For example, this program: +-- +-- @ +-- f x = let f x = x + 1 +-- in f (x - 2) +-- @ +-- +-- Would be renamed by having 'Unique's attached so it looked something like this: +-- +-- @ +-- f_1 x_2 = let f_3 x_4 = x_4 + 1 +-- in f_3 (x_2 - 2) +-- @ +-- But see Note [Shadowing] below. +-- +-- 3. The resulting syntax tree undergoes type checking (which also deals with instantiating +-- type class arguments) to yield a 'HsExpr.HsExpr' type that has 'Id.Id' as it's names. +-- +-- 4. Finally the syntax tree is /desugared/ from the expressive 'HsExpr.HsExpr' type into +-- this 'Expr' type, which has far fewer constructors and hence is easier to perform +-- optimization, analysis and code generation on. +-- +-- The type parameter @b@ is for the type of binders in the expression tree. +-- +-- The language consists of the following elements: +-- +-- * Variables +-- See Note [Variable occurrences in Core] +-- +-- * Primitive literals +-- +-- * Applications: note that the argument may be a 'Type'. +-- See Note [CoreSyn let/app invariant] +-- See Note [Levity polymorphism invariants] +-- +-- * Lambda abstraction +-- See Note [Levity polymorphism invariants] +-- +-- * Recursive and non recursive @let@s. Operationally +-- this corresponds to allocating a thunk for the things +-- bound and then executing the sub-expression. +-- +-- See Note [CoreSyn letrec invariant] +-- See Note [CoreSyn let/app invariant] +-- See Note [Levity polymorphism invariants] +-- See Note [CoreSyn type and coercion invariant] +-- +-- * Case expression. Operationally this corresponds to evaluating +-- the scrutinee (expression examined) to weak head normal form +-- and then examining at most one level of resulting constructor (i.e. you +-- cannot do nested pattern matching directly with this). +-- +-- The binder gets bound to the value of the scrutinee, +-- and the 'Type' must be that of all the case alternatives +-- +-- #case_invariants# +-- This is one of the more complicated elements of the Core language, +-- and comes with a number of restrictions: +-- +-- 1. The list of alternatives may be empty; +-- See Note [Empty case alternatives] +-- +-- 2. The 'DEFAULT' case alternative must be first in the list, +-- if it occurs at all. +-- +-- 3. The remaining cases are in order of increasing +-- tag (for 'DataAlts') or +-- lit (for 'LitAlts'). +-- This makes finding the relevant constructor easy, +-- and makes comparison easier too. +-- +-- 4. The list of alternatives must be exhaustive. An /exhaustive/ case +-- does not necessarily mention all constructors: +-- +-- @ +-- data Foo = Red | Green | Blue +-- ... case x of +-- Red -> True +-- other -> f (case x of +-- Green -> ... +-- Blue -> ... ) ... +-- @ +-- +-- The inner case does not need a @Red@ alternative, because @x@ +-- can't be @Red@ at that program point. +-- +-- 5. Floating-point values must not be scrutinised against literals. +-- See #9238 and Note [Rules for floating-point comparisons] +-- in PrelRules for rationale. +-- +-- * Cast an expression to a particular type. +-- This is used to implement @newtype@s (a @newtype@ constructor or +-- destructor just becomes a 'Cast' in Core) and GADTs. +-- +-- * Notes. These allow general information to be added to expressions +-- in the syntax tree +-- +-- * A type: this should only show up at the top level of an Arg +-- +-- * A coercion + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in coreSyn/CoreLint.hs +data Expr b + = Var Id + | Lit Literal + | App (Expr b) (Arg b) + | Lam b (Expr b) + | Let (Bind b) (Expr b) + | Case (Expr b) b Type [Alt b] -- See #case_invariants# + | Cast (Expr b) Coercion + | Tick (Tickish Id) (Expr b) + | Type Type + | Coercion Coercion + deriving Data + +-- | Type synonym for expressions that occur in function argument positions. +-- Only 'Arg' should contain a 'Type' at top level, general 'Expr' should not +type Arg b = Expr b + +-- | A case split alternative. Consists of the constructor leading to the alternative, +-- the variables bound from the constructor, and the expression to be executed given that binding. +-- The default alternative is @(DEFAULT, [], rhs)@ + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in coreSyn/CoreLint.hs +type Alt b = (AltCon, [b], Expr b) + +-- | A case alternative constructor (i.e. pattern match) + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in coreSyn/CoreLint.hs +data AltCon + = DataAlt DataCon -- ^ A plain data constructor: @case e of { Foo x -> ... }@. + -- Invariant: the 'DataCon' is always from a @data@ type, and never from a @newtype@ + + | LitAlt Literal -- ^ A literal: @case e of { 1 -> ... }@ + -- Invariant: always an *unlifted* literal + -- See Note [Literal alternatives] + + | DEFAULT -- ^ Trivial alternative: @case e of { _ -> ... }@ + deriving (Eq, Data) + +-- This instance is a bit shady. It can only be used to compare AltCons for +-- a single type constructor. Fortunately, it seems quite unlikely that we'll +-- ever need to compare AltCons for different type constructors. +-- The instance adheres to the order described in [CoreSyn case invariants] +instance Ord AltCon where + compare (DataAlt con1) (DataAlt con2) = + ASSERT( dataConTyCon con1 == dataConTyCon con2 ) + compare (dataConTag con1) (dataConTag con2) + compare (DataAlt _) _ = GT + compare _ (DataAlt _) = LT + compare (LitAlt l1) (LitAlt l2) = compare l1 l2 + compare (LitAlt _) DEFAULT = GT + compare DEFAULT DEFAULT = EQ + compare DEFAULT _ = LT + +-- | Binding, used for top level bindings in a module and local bindings in a @let@. + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in coreSyn/CoreLint.hs +data Bind b = NonRec b (Expr b) + | Rec [(b, (Expr b))] + deriving Data + +{- +Note [Shadowing] +~~~~~~~~~~~~~~~~ +While various passes attempt to rename on-the-fly in a manner that +avoids "shadowing" (thereby simplifying downstream optimizations), +neither the simplifier nor any other pass GUARANTEES that shadowing is +avoided. Thus, all passes SHOULD work fine even in the presence of +arbitrary shadowing in their inputs. + +In particular, scrutinee variables `x` in expressions of the form +`Case e x t` are often renamed to variables with a prefix +"wild_". These "wild" variables may appear in the body of the +case-expression, and further, may be shadowed within the body. + +So the Unique in a Var is not really unique at all. Still, it's very +useful to give a constant-time equality/ordering for Vars, and to give +a key that can be used to make sets of Vars (VarSet), or mappings from +Vars to other things (VarEnv). Moreover, if you do want to eliminate +shadowing, you can give a new Unique to an Id without changing its +printable name, which makes debugging easier. + +Note [Literal alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Literal alternatives (LitAlt lit) are always for *un-lifted* literals. +We have one literal, a literal Integer, that is lifted, and we don't +allow in a LitAlt, because LitAlt cases don't do any evaluation. Also +(see #5603) if you say + case 3 of + S# x -> ... + J# _ _ -> ... +(where S#, J# are the constructors for Integer) we don't want the +simplifier calling findAlt with argument (LitAlt 3). No no. Integer +literals are an opaque encoding of an algebraic data type, not of +an unlifted literal, like all the others. + +Also, we do not permit case analysis with literal patterns on floating-point +types. See #9238 and Note [Rules for floating-point comparisons] in +PrelRules for the rationale for this restriction. + +-------------------------- CoreSyn INVARIANTS --------------------------- + +Note [Variable occurrences in Core] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Variable /occurrences/ are never CoVars, though /bindings/ can be. +All CoVars appear in Coercions. + +For example + \(c :: Age~#Int) (d::Int). d |> (sym c) +Here 'c' is a CoVar, which is lambda-bound, but it /occurs/ in +a Coercion, (sym c). + +Note [CoreSyn letrec invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The right hand sides of all top-level and recursive @let@s +/must/ be of lifted type (see "Type#type_classification" for +the meaning of /lifted/ vs. /unlifted/). + +There is one exception to this rule, top-level @let@s are +allowed to bind primitive string literals: see +Note [CoreSyn top-level string literals]. + +Note [CoreSyn top-level string literals] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As an exception to the usual rule that top-level binders must be lifted, +we allow binding primitive string literals (of type Addr#) of type Addr# at the +top level. This allows us to share string literals earlier in the pipeline and +crucially allows other optimizations in the Core2Core pipeline to fire. +Consider, + + f n = let a::Addr# = "foo"# + in \x -> blah + +In order to be able to inline `f`, we would like to float `a` to the top. +Another option would be to inline `a`, but that would lead to duplicating string +literals, which we want to avoid. See #8472. + +The solution is simply to allow top-level unlifted binders. We can't allow +arbitrary unlifted expression at the top-level though, unlifted binders cannot +be thunks, so we just allow string literals. + +We allow the top-level primitive string literals to be wrapped in Ticks +in the same way they can be wrapped when nested in an expression. +CoreToSTG currently discards Ticks around top-level primitive string literals. +See #14779. + +Also see Note [Compilation plan for top-level string literals]. + +Note [Compilation plan for top-level string literals] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here is a summary on how top-level string literals are handled by various +parts of the compilation pipeline. + +* In the source language, there is no way to bind a primitive string literal + at the top level. + +* In Core, we have a special rule that permits top-level Addr# bindings. See + Note [CoreSyn top-level string literals]. Core-to-core passes may introduce + new top-level string literals. + +* In STG, top-level string literals are explicitly represented in the syntax + tree. + +* A top-level string literal may end up exported from a module. In this case, + in the object file, the content of the exported literal is given a label with + the _bytes suffix. + +Note [CoreSyn let/app invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The let/app invariant + the right hand side of a non-recursive 'Let', and + the argument of an 'App', + /may/ be of unlifted type, but only if + the expression is ok-for-speculation + or the 'Let' is for a join point. + +This means that the let can be floated around +without difficulty. For example, this is OK: + + y::Int# = x +# 1# + +But this is not, as it may affect termination if the +expression is floated out: + + y::Int# = fac 4# + +In this situation you should use @case@ rather than a @let@. The function +'CoreUtils.needsCaseBinding' can help you determine which to generate, or +alternatively use 'MkCore.mkCoreLet' rather than this constructor directly, +which will generate a @case@ if necessary + +The let/app invariant is initially enforced by mkCoreLet and mkCoreApp in +coreSyn/MkCore. + +Note [CoreSyn type and coercion invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We allow a /non-recursive/, /non-top-level/ let to bind type and +coercion variables. These can be very convenient for postponing type +substitutions until the next run of the simplifier. + +* A type variable binding must have a RHS of (Type ty) + +* A coercion variable binding must have a RHS of (Coercion co) + + It is possible to have terms that return a coercion, but we use + case-binding for those; e.g. + case (eq_sel d) of (co :: a ~# b) -> blah + where eq_sel :: (a~b) -> (a~#b) + + Or even even + case (df @Int) of (co :: a ~# b) -> blah + Which is very exotic, and I think never encountered; but see + Note [Equality superclasses in quantified constraints] + in TcCanonical + +Note [CoreSyn case invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See #case_invariants# + +Note [Levity polymorphism invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The levity-polymorphism invariants are these (as per "Levity Polymorphism", +PLDI '17): + +* The type of a term-binder must not be levity-polymorphic, + unless it is a let(rec)-bound join point + (see Note [Invariants on join points]) + +* The type of the argument of an App must not be levity-polymorphic. + +A type (t::TYPE r) is "levity polymorphic" if 'r' has any free variables. + +For example + \(r::RuntimeRep). \(a::TYPE r). \(x::a). e +is illegal because x's type has kind (TYPE r), which has 'r' free. + +See Note [Levity polymorphism checking] in DsMonad to see where these +invariants are established for user-written code. + +Note [CoreSyn let goal] +~~~~~~~~~~~~~~~~~~~~~~~ +* The simplifier tries to ensure that if the RHS of a let is a constructor + application, its arguments are trivial, so that the constructor can be + inlined vigorously. + +Note [Type let] +~~~~~~~~~~~~~~~ +See #type_let# + +Note [Empty case alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The alternatives of a case expression should be exhaustive. But +this exhaustive list can be empty! + +* A case expression can have empty alternatives if (and only if) the + scrutinee is bound to raise an exception or diverge. When do we know + this? See Note [Bottoming expressions] in CoreUtils. + +* The possibility of empty alternatives is one reason we need a type on + the case expression: if the alternatives are empty we can't get the + type from the alternatives! + +* In the case of empty types (see Note [Bottoming expressions]), say + data T + we do NOT want to replace + case (x::T) of Bool {} --> error Bool "Inaccessible case" + because x might raise an exception, and *that*'s what we want to see! + (#6067 is an example.) To preserve semantics we'd have to say + x `seq` error Bool "Inaccessible case" + but the 'seq' is just a case, so we are back to square 1. Or I suppose + we could say + x |> UnsafeCoerce T Bool + but that loses all trace of the fact that this originated with an empty + set of alternatives. + +* We can use the empty-alternative construct to coerce error values from + one type to another. For example + + f :: Int -> Int + f n = error "urk" + + g :: Int -> (# Char, Bool #) + g x = case f x of { 0 -> ..., n -> ... } + + Then if we inline f in g's RHS we get + case (error Int "urk") of (# Char, Bool #) { ... } + and we can discard the alternatives since the scrutinee is bottom to give + case (error Int "urk") of (# Char, Bool #) {} + + This is nicer than using an unsafe coerce between Int ~ (# Char,Bool #), + if for no other reason that we don't need to instantiate the (~) at an + unboxed type. + +* We treat a case expression with empty alternatives as trivial iff + its scrutinee is (see CoreUtils.exprIsTrivial). This is actually + important; see Note [Empty case is trivial] in CoreUtils + +* An empty case is replaced by its scrutinee during the CoreToStg + conversion; remember STG is un-typed, so there is no need for + the empty case to do the type conversion. + +Note [Join points] +~~~~~~~~~~~~~~~~~~ +In Core, a *join point* is a specially tagged function whose only occurrences +are saturated tail calls. A tail call can appear in these places: + + 1. In the branches (not the scrutinee) of a case + 2. Underneath a let (value or join point) + 3. Inside another join point + +We write a join-point declaration as + join j @a @b x y = e1 in e2, +like a let binding but with "join" instead (or "join rec" for "let rec"). Note +that we put the parameters before the = rather than using lambdas; this is +because it's relevant how many parameters the join point takes *as a join +point.* This number is called the *join arity,* distinct from arity because it +counts types as well as values. Note that a join point may return a lambda! So + join j x = x + 1 +is different from + join j = \x -> x + 1 +The former has join arity 1, while the latter has join arity 0. + +The identifier for a join point is called a join id or a *label.* An invocation +is called a *jump.* We write a jump using the jump keyword: + + jump j 3 + +The words *label* and *jump* are evocative of assembly code (or Cmm) for a +reason: join points are indeed compiled as labeled blocks, and jumps become +actual jumps (plus argument passing and stack adjustment). There is no closure +allocated and only a fraction of the function-call overhead. Hence we would +like as many functions as possible to become join points (see OccurAnal) and +the type rules for join points ensure we preserve the properties that make them +efficient. + +In the actual AST, a join point is indicated by the IdDetails of the binder: a +local value binding gets 'VanillaId' but a join point gets a 'JoinId' with its +join arity. + +For more details, see the paper: + + Luke Maurer, Paul Downen, Zena Ariola, and Simon Peyton Jones. "Compiling + without continuations." Submitted to PLDI'17. + + https://www.microsoft.com/en-us/research/publication/compiling-without-continuations/ + +Note [Invariants on join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Join points must follow these invariants: + + 1. All occurrences must be tail calls. Each of these tail calls must pass the + same number of arguments, counting both types and values; we call this the + "join arity" (to distinguish from regular arity, which only counts values). + + 2. For join arity n, the right-hand side must begin with at least n lambdas. + No ticks, no casts, just lambdas! C.f. CoreUtils.joinRhsArity. + + 2a. Moreover, this same constraint applies to any unfolding of the binder. + Reason: if we want to push a continuation into the RHS we must push it + into the unfolding as well. + + 3. If the binding is recursive, then all other bindings in the recursive group + must also be join points. + + 4. The binding's type must not be polymorphic in its return type (as defined + in Note [The polymorphism rule of join points]). + +However, join points have simpler invariants in other ways + + 5. A join point can have an unboxed type without the RHS being + ok-for-speculation (i.e. drop the let/app invariant) + e.g. let j :: Int# = factorial x in ... + + 6. A join point can have a levity-polymorphic RHS + e.g. let j :: r :: TYPE l = fail void# in ... + This happened in an intermediate program #13394 + +Examples: + + join j1 x = 1 + x in jump j (jump j x) -- Fails 1: non-tail call + join j1' x = 1 + x in if even a + then jump j1 a + else jump j1 a b -- Fails 1: inconsistent calls + join j2 x = flip (+) x in j2 1 2 -- Fails 2: not enough lambdas + join j2' x = \y -> x + y in j3 1 -- Passes: extra lams ok + join j @a (x :: a) = x -- Fails 4: polymorphic in ret type + +Invariant 1 applies to left-hand sides of rewrite rules, so a rule for a join +point must have an exact call as its LHS. + +Strictly speaking, invariant 3 is redundant, since a call from inside a lazy +binding isn't a tail call. Since a let-bound value can't invoke a free join +point, then, they can't be mutually recursive. (A Core binding group *can* +include spurious extra bindings if the occurrence analyser hasn't run, so +invariant 3 does still need to be checked.) For the rigorous definition of +"tail call", see Section 3 of the paper (Note [Join points]). + +Invariant 4 is subtle; see Note [The polymorphism rule of join points]. + +Core Lint will check these invariants, anticipating that any binder whose +OccInfo is marked AlwaysTailCalled will become a join point as soon as the +simplifier (or simpleOptPgm) runs. + +Note [The type of a join point] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A join point has the same type it would have as a function. That is, if it takes +an Int and a Bool and its body produces a String, its type is `Int -> Bool -> +String`. Natural as this may seem, it can be awkward. A join point shouldn't be +thought to "return" in the same sense a function does---a jump is one-way. This +is crucial for understanding how case-of-case interacts with join points: + + case (join + j :: Int -> Bool -> String + j x y = ... + in + jump j z w) of + "" -> True + _ -> False + +The simplifier will pull the case into the join point (see Note [Case-of-case +and join points] in Simplify): + + join + j :: Int -> Bool -> Bool -- changed! + j x y = case ... of "" -> True + _ -> False + in + jump j z w + +The body of the join point now returns a Bool, so the label `j` has to have its +type updated accordingly. Inconvenient though this may be, it has the advantage +that 'CoreUtils.exprType' can still return a type for any expression, including +a jump. + +This differs from the paper (see Note [Invariants on join points]). In the +paper, we instead give j the type `Int -> Bool -> forall a. a`. Then each jump +carries the "return type" as a parameter, exactly the way other non-returning +functions like `error` work: + + case (join + j :: Int -> Bool -> forall a. a + j x y = ... + in + jump j z w @String) of + "" -> True + _ -> False + +Now we can move the case inward and we only have to change the jump: + + join + j :: Int -> Bool -> forall a. a + j x y = case ... of "" -> True + _ -> False + in + jump j z w @Bool + +(Core Lint would still check that the body of the join point has the right type; +that type would simply not be reflected in the join id.) + +Note [The polymorphism rule of join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Invariant 4 of Note [Invariants on join points] forbids a join point to be +polymorphic in its return type. That is, if its type is + + forall a1 ... ak. t1 -> ... -> tn -> r + +where its join arity is k+n, none of the type parameters ai may occur free in r. + +In some way, this falls out of the fact that given + + join + j @a1 ... @ak x1 ... xn = e1 + in e2 + +then all calls to `j` are in tail-call positions of `e`, and expressions in +tail-call positions in `e` have the same type as `e`. +Therefore the type of `e1` -- the return type of the join point -- must be the +same as the type of e2. +Since the type variables aren't bound in `e2`, its type can't include them, and +thus neither can the type of `e1`. + +This unfortunately prevents the `go` in the following code from being a +join-point: + + iter :: forall a. Int -> (a -> a) -> a -> a + iter @a n f x = go @a n f x + where + go :: forall a. Int -> (a -> a) -> a -> a + go @a 0 _ x = x + go @a n f x = go @a (n-1) f (f x) + +In this case, a static argument transformation would fix that (see +ticket #14620): + + iter :: forall a. Int -> (a -> a) -> a -> a + iter @a n f x = go' @a n f x + where + go' :: Int -> (a -> a) -> a -> a + go' 0 _ x = x + go' n f x = go' (n-1) f (f x) + +In general, loopification could be employed to do that (see #14068.) + +Can we simply drop the requirement, and allow `go` to be a join-point? We +could, and it would work. But we could not longer apply the case-of-join-point +transformation universally. This transformation would do: + + case (join go @a n f x = case n of 0 -> x + n -> go @a (n-1) f (f x) + in go @Bool n neg True) of + True -> e1; False -> e2 + + ===> + + join go @a n f x = case n of 0 -> case x of True -> e1; False -> e2 + n -> go @a (n-1) f (f x) + in go @Bool n neg True + +but that is ill-typed, as `x` is type `a`, not `Bool`. + + +This also justifies why we do not consider the `e` in `e |> co` to be in +tail position: A cast changes the type, but the type must be the same. But +operationally, casts are vacuous, so this is a bit unfortunate! See #14610 for +ideas how to fix this. + +************************************************************************ +* * + In/Out type synonyms +* * +********************************************************************* -} + +{- Many passes apply a substitution, and it's very handy to have type + synonyms to remind us whether or not the substitution has been applied -} + +-- Pre-cloning or substitution +type InBndr = CoreBndr +type InType = Type +type InKind = Kind +type InBind = CoreBind +type InExpr = CoreExpr +type InAlt = CoreAlt +type InArg = CoreArg +type InCoercion = Coercion + +-- Post-cloning or substitution +type OutBndr = CoreBndr +type OutType = Type +type OutKind = Kind +type OutCoercion = Coercion +type OutBind = CoreBind +type OutExpr = CoreExpr +type OutAlt = CoreAlt +type OutArg = CoreArg +type MOutCoercion = MCoercion + + +{- ********************************************************************* +* * + Ticks +* * +************************************************************************ +-} + +-- | Allows attaching extra information to points in expressions + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in coreSyn/CoreLint.hs +data Tickish id = + -- | An @{-# SCC #-}@ profiling annotation, either automatically + -- added by the desugarer as a result of -auto-all, or added by + -- the user. + ProfNote { + profNoteCC :: CostCentre, -- ^ the cost centre + profNoteCount :: !Bool, -- ^ bump the entry count? + profNoteScope :: !Bool -- ^ scopes over the enclosed expression + -- (i.e. not just a tick) + } + + -- | A "tick" used by HPC to track the execution of each + -- subexpression in the original source code. + | HpcTick { + tickModule :: Module, + tickId :: !Int + } + + -- | A breakpoint for the GHCi debugger. This behaves like an HPC + -- tick, but has a list of free variables which will be available + -- for inspection in GHCi when the program stops at the breakpoint. + -- + -- NB. we must take account of these Ids when (a) counting free variables, + -- and (b) substituting (don't substitute for them) + | Breakpoint + { breakpointId :: !Int + , breakpointFVs :: [id] -- ^ the order of this list is important: + -- it matches the order of the lists in the + -- appropriate entry in HscTypes.ModBreaks. + -- + -- Careful about substitution! See + -- Note [substTickish] in CoreSubst. + } + + -- | A source note. + -- + -- Source notes are pure annotations: Their presence should neither + -- influence compilation nor execution. The semantics are given by + -- causality: The presence of a source note means that a local + -- change in the referenced source code span will possibly provoke + -- the generated code to change. On the flip-side, the functionality + -- of annotated code *must* be invariant against changes to all + -- source code *except* the spans referenced in the source notes + -- (see "Causality of optimized Haskell" paper for details). + -- + -- Therefore extending the scope of any given source note is always + -- valid. Note that it is still undesirable though, as this reduces + -- their usefulness for debugging and profiling. Therefore we will + -- generally try only to make use of this property where it is + -- necessary to enable optimizations. + | SourceNote + { sourceSpan :: RealSrcSpan -- ^ Source covered + , sourceName :: String -- ^ Name for source location + -- (uses same names as CCs) + } + + deriving (Eq, Ord, Data) + +-- | A "counting tick" (where tickishCounts is True) is one that +-- counts evaluations in some way. We cannot discard a counting tick, +-- and the compiler should preserve the number of counting ticks as +-- far as possible. +-- +-- However, we still allow the simplifier to increase or decrease +-- sharing, so in practice the actual number of ticks may vary, except +-- that we never change the value from zero to non-zero or vice versa. +tickishCounts :: Tickish id -> Bool +tickishCounts n@ProfNote{} = profNoteCount n +tickishCounts HpcTick{} = True +tickishCounts Breakpoint{} = True +tickishCounts _ = False + + +-- | Specifies the scoping behaviour of ticks. This governs the +-- behaviour of ticks that care about the covered code and the cost +-- associated with it. Important for ticks relating to profiling. +data TickishScoping = + -- | No scoping: The tick does not care about what code it + -- covers. Transformations can freely move code inside as well as + -- outside without any additional annotation obligations + NoScope + + -- | Soft scoping: We want all code that is covered to stay + -- covered. Note that this scope type does not forbid + -- transformations from happening, as long as all results of + -- the transformations are still covered by this tick or a copy of + -- it. For example + -- + -- let x = tick<...> (let y = foo in bar) in baz + -- ===> + -- let x = tick<...> bar; y = tick<...> foo in baz + -- + -- Is a valid transformation as far as "bar" and "foo" is + -- concerned, because both still are scoped over by the tick. + -- + -- Note though that one might object to the "let" not being + -- covered by the tick any more. However, we are generally lax + -- with this - constant costs don't matter too much, and given + -- that the "let" was effectively merged we can view it as having + -- lost its identity anyway. + -- + -- Also note that this scoping behaviour allows floating a tick + -- "upwards" in pretty much any situation. For example: + -- + -- case foo of x -> tick<...> bar + -- ==> + -- tick<...> case foo of x -> bar + -- + -- While this is always leagl, we want to make a best effort to + -- only make us of this where it exposes transformation + -- opportunities. + | SoftScope + + -- | Cost centre scoping: We don't want any costs to move to other + -- cost-centre stacks. This means we not only want no code or cost + -- to get moved out of their cost centres, but we also object to + -- code getting associated with new cost-centre ticks - or + -- changing the order in which they get applied. + -- + -- A rule of thumb is that we don't want any code to gain new + -- annotations. However, there are notable exceptions, for + -- example: + -- + -- let f = \y -> foo in tick<...> ... (f x) ... + -- ==> + -- tick<...> ... foo[x/y] ... + -- + -- In-lining lambdas like this is always legal, because inlining a + -- function does not change the cost-centre stack when the + -- function is called. + | CostCentreScope + + deriving (Eq) + +-- | Returns the intended scoping rule for a Tickish +tickishScoped :: Tickish id -> TickishScoping +tickishScoped n@ProfNote{} + | profNoteScope n = CostCentreScope + | otherwise = NoScope +tickishScoped HpcTick{} = NoScope +tickishScoped Breakpoint{} = CostCentreScope + -- Breakpoints are scoped: eventually we're going to do call + -- stacks, but also this helps prevent the simplifier from moving + -- breakpoints around and changing their result type (see #1531). +tickishScoped SourceNote{} = SoftScope + +-- | Returns whether the tick scoping rule is at least as permissive +-- as the given scoping rule. +tickishScopesLike :: Tickish id -> TickishScoping -> Bool +tickishScopesLike t scope = tickishScoped t `like` scope + where NoScope `like` _ = True + _ `like` NoScope = False + SoftScope `like` _ = True + _ `like` SoftScope = False + CostCentreScope `like` _ = True + +-- | Returns @True@ for ticks that can be floated upwards easily even +-- where it might change execution counts, such as: +-- +-- Just (tick<...> foo) +-- ==> +-- tick<...> (Just foo) +-- +-- This is a combination of @tickishSoftScope@ and +-- @tickishCounts@. Note that in principle splittable ticks can become +-- floatable using @mkNoTick@ -- even though there's currently no +-- tickish for which that is the case. +tickishFloatable :: Tickish id -> Bool +tickishFloatable t = t `tickishScopesLike` SoftScope && not (tickishCounts t) + +-- | Returns @True@ for a tick that is both counting /and/ scoping and +-- can be split into its (tick, scope) parts using 'mkNoScope' and +-- 'mkNoTick' respectively. +tickishCanSplit :: Tickish id -> Bool +tickishCanSplit ProfNote{profNoteScope = True, profNoteCount = True} + = True +tickishCanSplit _ = False + +mkNoCount :: Tickish id -> Tickish id +mkNoCount n | not (tickishCounts n) = n + | not (tickishCanSplit n) = panic "mkNoCount: Cannot split!" +mkNoCount n@ProfNote{} = n {profNoteCount = False} +mkNoCount _ = panic "mkNoCount: Undefined split!" + +mkNoScope :: Tickish id -> Tickish id +mkNoScope n | tickishScoped n == NoScope = n + | not (tickishCanSplit n) = panic "mkNoScope: Cannot split!" +mkNoScope n@ProfNote{} = n {profNoteScope = False} +mkNoScope _ = panic "mkNoScope: Undefined split!" + +-- | Return @True@ if this source annotation compiles to some backend +-- code. Without this flag, the tickish is seen as a simple annotation +-- that does not have any associated evaluation code. +-- +-- What this means that we are allowed to disregard the tick if doing +-- so means that we can skip generating any code in the first place. A +-- typical example is top-level bindings: +-- +-- foo = tick<...> \y -> ... +-- ==> +-- foo = \y -> tick<...> ... +-- +-- Here there is just no operational difference between the first and +-- the second version. Therefore code generation should simply +-- translate the code as if it found the latter. +tickishIsCode :: Tickish id -> Bool +tickishIsCode SourceNote{} = False +tickishIsCode _tickish = True -- all the rest for now + + +-- | Governs the kind of expression that the tick gets placed on when +-- annotating for example using @mkTick@. If we find that we want to +-- put a tickish on an expression ruled out here, we try to float it +-- inwards until we find a suitable expression. +data TickishPlacement = + + -- | Place ticks exactly on run-time expressions. We can still + -- move the tick through pure compile-time constructs such as + -- other ticks, casts or type lambdas. This is the most + -- restrictive placement rule for ticks, as all tickishs have in + -- common that they want to track runtime processes. The only + -- legal placement rule for counting ticks. + PlaceRuntime + + -- | As @PlaceRuntime@, but we float the tick through all + -- lambdas. This makes sense where there is little difference + -- between annotating the lambda and annotating the lambda's code. + | PlaceNonLam + + -- | In addition to floating through lambdas, cost-centre style + -- tickishs can also be moved from constructors, non-function + -- variables and literals. For example: + -- + -- let x = scc<...> C (scc<...> y) (scc<...> 3) in ... + -- + -- Neither the constructor application, the variable or the + -- literal are likely to have any cost worth mentioning. And even + -- if y names a thunk, the call would not care about the + -- evaluation context. Therefore removing all annotations in the + -- above example is safe. + | PlaceCostCentre + + deriving (Eq) + +-- | Placement behaviour we want for the ticks +tickishPlace :: Tickish id -> TickishPlacement +tickishPlace n@ProfNote{} + | profNoteCount n = PlaceRuntime + | otherwise = PlaceCostCentre +tickishPlace HpcTick{} = PlaceRuntime +tickishPlace Breakpoint{} = PlaceRuntime +tickishPlace SourceNote{} = PlaceNonLam + +-- | Returns whether one tick "contains" the other one, therefore +-- making the second tick redundant. +tickishContains :: Eq b => Tickish b -> Tickish b -> Bool +tickishContains (SourceNote sp1 n1) (SourceNote sp2 n2) + = containsSpan sp1 sp2 && n1 == n2 + -- compare the String last +tickishContains t1 t2 + = t1 == t2 + +{- +************************************************************************ +* * + Orphans +* * +************************************************************************ +-} + +-- | Is this instance an orphan? If it is not an orphan, contains an 'OccName' +-- witnessing the instance's non-orphanhood. +-- See Note [Orphans] +data IsOrphan + = IsOrphan + | NotOrphan OccName -- The OccName 'n' witnesses the instance's non-orphanhood + -- In that case, the instance is fingerprinted as part + -- of the definition of 'n's definition + deriving Data + +-- | Returns true if 'IsOrphan' is orphan. +isOrphan :: IsOrphan -> Bool +isOrphan IsOrphan = True +isOrphan _ = False + +-- | Returns true if 'IsOrphan' is not an orphan. +notOrphan :: IsOrphan -> Bool +notOrphan NotOrphan{} = True +notOrphan _ = False + +chooseOrphanAnchor :: NameSet -> IsOrphan +-- Something (rule, instance) is relate to all the Names in this +-- list. Choose one of them to be an "anchor" for the orphan. We make +-- the choice deterministic to avoid gratuitious changes in the ABI +-- hash (#4012). Specifically, use lexicographic comparison of +-- OccName rather than comparing Uniques +-- +-- NB: 'minimum' use Ord, and (Ord OccName) works lexicographically +-- +chooseOrphanAnchor local_names + | isEmptyNameSet local_names = IsOrphan + | otherwise = NotOrphan (minimum occs) + where + occs = map nameOccName $ nonDetEltsUniqSet local_names + -- It's OK to use nonDetEltsUFM here, see comments above + +instance Binary IsOrphan where + put_ bh IsOrphan = putByte bh 0 + put_ bh (NotOrphan n) = do + putByte bh 1 + put_ bh n + get bh = do + h <- getByte bh + case h of + 0 -> return IsOrphan + _ -> do + n <- get bh + return $ NotOrphan n + +{- +Note [Orphans] +~~~~~~~~~~~~~~ +Class instances, rules, and family instances are divided into orphans +and non-orphans. Roughly speaking, an instance/rule is an orphan if +its left hand side mentions nothing defined in this module. Orphan-hood +has two major consequences + + * A module that contains orphans is called an "orphan module". If + the module being compiled depends (transitively) on an oprhan + module M, then M.hi is read in regardless of whether M is oherwise + needed. This is to ensure that we don't miss any instance decls in + M. But it's painful, because it means we need to keep track of all + the orphan modules below us. + + * A non-orphan is not finger-printed separately. Instead, for + fingerprinting purposes it is treated as part of the entity it + mentions on the LHS. For example + data T = T1 | T2 + instance Eq T where .... + The instance (Eq T) is incorprated as part of T's fingerprint. + + In contrast, orphans are all fingerprinted together in the + mi_orph_hash field of the ModIface. + + See MkIface.addFingerprints. + +Orphan-hood is computed + * For class instances: + when we make a ClsInst + (because it is needed during instance lookup) + + * For rules and family instances: + when we generate an IfaceRule (MkIface.coreRuleToIfaceRule) + or IfaceFamInst (MkIface.instanceToIfaceInst) +-} + +{- +************************************************************************ +* * +\subsection{Transformation rules} +* * +************************************************************************ + +The CoreRule type and its friends are dealt with mainly in CoreRules, +but CoreFVs, Subst, PprCore, CoreTidy also inspect the representation. +-} + +-- | Gathers a collection of 'CoreRule's. Maps (the name of) an 'Id' to its rules +type RuleBase = NameEnv [CoreRule] + -- The rules are unordered; + -- we sort out any overlaps on lookup + +-- | A full rule environment which we can apply rules from. Like a 'RuleBase', +-- but it also includes the set of visible orphans we use to filter out orphan +-- rules which are not visible (even though we can see them...) +data RuleEnv + = RuleEnv { re_base :: RuleBase + , re_visible_orphs :: ModuleSet + } + +mkRuleEnv :: RuleBase -> [Module] -> RuleEnv +mkRuleEnv rules vis_orphs = RuleEnv rules (mkModuleSet vis_orphs) + +emptyRuleEnv :: RuleEnv +emptyRuleEnv = RuleEnv emptyNameEnv emptyModuleSet + +-- | A 'CoreRule' is: +-- +-- * \"Local\" if the function it is a rule for is defined in the +-- same module as the rule itself. +-- +-- * \"Orphan\" if nothing on the LHS is defined in the same module +-- as the rule itself +data CoreRule + = Rule { + ru_name :: RuleName, -- ^ Name of the rule, for communication with the user + ru_act :: Activation, -- ^ When the rule is active + + -- Rough-matching stuff + -- see comments with InstEnv.ClsInst( is_cls, is_rough ) + ru_fn :: Name, -- ^ Name of the 'Id.Id' at the head of this rule + ru_rough :: [Maybe Name], -- ^ Name at the head of each argument to the left hand side + + -- Proper-matching stuff + -- see comments with InstEnv.ClsInst( is_tvs, is_tys ) + ru_bndrs :: [CoreBndr], -- ^ Variables quantified over + ru_args :: [CoreExpr], -- ^ Left hand side arguments + + -- And the right-hand side + ru_rhs :: CoreExpr, -- ^ Right hand side of the rule + -- Occurrence info is guaranteed correct + -- See Note [OccInfo in unfoldings and rules] + + -- Locality + ru_auto :: Bool, -- ^ @True@ <=> this rule is auto-generated + -- (notably by Specialise or SpecConstr) + -- @False@ <=> generated at the user's behest + -- See Note [Trimming auto-rules] in TidyPgm + -- for the sole purpose of this field. + + ru_origin :: !Module, -- ^ 'Module' the rule was defined in, used + -- to test if we should see an orphan rule. + + ru_orphan :: !IsOrphan, -- ^ Whether or not the rule is an orphan. + + ru_local :: Bool -- ^ @True@ iff the fn at the head of the rule is + -- defined in the same module as the rule + -- and is not an implicit 'Id' (like a record selector, + -- class operation, or data constructor). This + -- is different from 'ru_orphan', where a rule + -- can avoid being an orphan if *any* Name in + -- LHS of the rule was defined in the same + -- module as the rule. + } + + -- | Built-in rules are used for constant folding + -- and suchlike. They have no free variables. + -- A built-in rule is always visible (there is no such thing as + -- an orphan built-in rule.) + | BuiltinRule { + ru_name :: RuleName, -- ^ As above + ru_fn :: Name, -- ^ As above + ru_nargs :: Int, -- ^ Number of arguments that 'ru_try' consumes, + -- if it fires, including type arguments + ru_try :: RuleFun + -- ^ This function does the rewrite. It given too many + -- arguments, it simply discards them; the returned 'CoreExpr' + -- is just the rewrite of 'ru_fn' applied to the first 'ru_nargs' args + } + -- See Note [Extra args in rule matching] in Rules.hs + +type RuleFun = DynFlags -> InScopeEnv -> Id -> [CoreExpr] -> Maybe CoreExpr +type InScopeEnv = (InScopeSet, IdUnfoldingFun) + +type IdUnfoldingFun = Id -> Unfolding +-- A function that embodies how to unfold an Id if you need +-- to do that in the Rule. The reason we need to pass this info in +-- is that whether an Id is unfoldable depends on the simplifier phase + +isBuiltinRule :: CoreRule -> Bool +isBuiltinRule (BuiltinRule {}) = True +isBuiltinRule _ = False + +isAutoRule :: CoreRule -> Bool +isAutoRule (BuiltinRule {}) = False +isAutoRule (Rule { ru_auto = is_auto }) = is_auto + +-- | The number of arguments the 'ru_fn' must be applied +-- to before the rule can match on it +ruleArity :: CoreRule -> Int +ruleArity (BuiltinRule {ru_nargs = n}) = n +ruleArity (Rule {ru_args = args}) = length args + +ruleName :: CoreRule -> RuleName +ruleName = ru_name + +ruleModule :: CoreRule -> Maybe Module +ruleModule Rule { ru_origin } = Just ru_origin +ruleModule BuiltinRule {} = Nothing + +ruleActivation :: CoreRule -> Activation +ruleActivation (BuiltinRule { }) = AlwaysActive +ruleActivation (Rule { ru_act = act }) = act + +-- | The 'Name' of the 'Id.Id' at the head of the rule left hand side +ruleIdName :: CoreRule -> Name +ruleIdName = ru_fn + +isLocalRule :: CoreRule -> Bool +isLocalRule = ru_local + +-- | Set the 'Name' of the 'Id.Id' at the head of the rule left hand side +setRuleIdName :: Name -> CoreRule -> CoreRule +setRuleIdName nm ru = ru { ru_fn = nm } + +{- +************************************************************************ +* * + Unfoldings +* * +************************************************************************ + +The @Unfolding@ type is declared here to avoid numerous loops +-} + +-- | Records the /unfolding/ of an identifier, which is approximately the form the +-- identifier would have if we substituted its definition in for the identifier. +-- This type should be treated as abstract everywhere except in "CoreUnfold" +data Unfolding + = NoUnfolding -- ^ We have no information about the unfolding. + + | BootUnfolding -- ^ We have no information about the unfolding, because + -- this 'Id' came from an @hi-boot@ file. + -- See Note [Inlining and hs-boot files] in ToIface + -- for what this is used for. + + | OtherCon [AltCon] -- ^ It ain't one of these constructors. + -- @OtherCon xs@ also indicates that something has been evaluated + -- and hence there's no point in re-evaluating it. + -- @OtherCon []@ is used even for non-data-type values + -- to indicated evaluated-ness. Notably: + -- + -- > data C = C !(Int -> Int) + -- > case x of { C f -> ... } + -- + -- Here, @f@ gets an @OtherCon []@ unfolding. + + | DFunUnfolding { -- The Unfolding of a DFunId + -- See Note [DFun unfoldings] + -- df = /\a1..am. \d1..dn. MkD t1 .. tk + -- (op1 a1..am d1..dn) + -- (op2 a1..am d1..dn) + df_bndrs :: [Var], -- The bound variables [a1..m],[d1..dn] + df_con :: DataCon, -- The dictionary data constructor (never a newtype datacon) + df_args :: [CoreExpr] -- Args of the data con: types, superclasses and methods, + } -- in positional order + + | CoreUnfolding { -- An unfolding for an Id with no pragma, + -- or perhaps a NOINLINE pragma + -- (For NOINLINE, the phase, if any, is in the + -- InlinePragInfo for this Id.) + uf_tmpl :: CoreExpr, -- Template; occurrence info is correct + uf_src :: UnfoldingSource, -- Where the unfolding came from + uf_is_top :: Bool, -- True <=> top level binding + uf_is_value :: Bool, -- exprIsHNF template (cached); it is ok to discard + -- a `seq` on this variable + uf_is_conlike :: Bool, -- True <=> applicn of constructor or CONLIKE function + -- Cached version of exprIsConLike + uf_is_work_free :: Bool, -- True <=> doesn't waste (much) work to expand + -- inside an inlining + -- Cached version of exprIsCheap + uf_expandable :: Bool, -- True <=> can expand in RULE matching + -- Cached version of exprIsExpandable + uf_guidance :: UnfoldingGuidance -- Tells about the *size* of the template. + } + -- ^ An unfolding with redundant cached information. Parameters: + -- + -- uf_tmpl: Template used to perform unfolding; + -- NB: Occurrence info is guaranteed correct: + -- see Note [OccInfo in unfoldings and rules] + -- + -- uf_is_top: Is this a top level binding? + -- + -- uf_is_value: 'exprIsHNF' template (cached); it is ok to discard a 'seq' on + -- this variable + -- + -- uf_is_work_free: Does this waste only a little work if we expand it inside an inlining? + -- Basically this is a cached version of 'exprIsWorkFree' + -- + -- uf_guidance: Tells us about the /size/ of the unfolding template + + +------------------------------------------------ +data UnfoldingSource + = -- See also Note [Historical note: unfoldings for wrappers] + + InlineRhs -- The current rhs of the function + -- Replace uf_tmpl each time around + + | InlineStable -- From an INLINE or INLINABLE pragma + -- INLINE if guidance is UnfWhen + -- INLINABLE if guidance is UnfIfGoodArgs/UnfoldNever + -- (well, technically an INLINABLE might be made + -- UnfWhen if it was small enough, and then + -- it will behave like INLINE outside the current + -- module, but that is the way automatic unfoldings + -- work so it is consistent with the intended + -- meaning of INLINABLE). + -- + -- uf_tmpl may change, but only as a result of + -- gentle simplification, it doesn't get updated + -- to the current RHS during compilation as with + -- InlineRhs. + -- + -- See Note [InlineStable] + + | InlineCompulsory -- Something that *has* no binding, so you *must* inline it + -- Only a few primop-like things have this property + -- (see MkId.hs, calls to mkCompulsoryUnfolding). + -- Inline absolutely always, however boring the context. + + + +-- | 'UnfoldingGuidance' says when unfolding should take place +data UnfoldingGuidance + = UnfWhen { -- Inline without thinking about the *size* of the uf_tmpl + -- Used (a) for small *and* cheap unfoldings + -- (b) for INLINE functions + -- See Note [INLINE for small functions] in CoreUnfold + ug_arity :: Arity, -- Number of value arguments expected + + ug_unsat_ok :: Bool, -- True <=> ok to inline even if unsaturated + ug_boring_ok :: Bool -- True <=> ok to inline even if the context is boring + -- So True,True means "always" + } + + | UnfIfGoodArgs { -- Arose from a normal Id; the info here is the + -- result of a simple analysis of the RHS + + ug_args :: [Int], -- Discount if the argument is evaluated. + -- (i.e., a simplification will definitely + -- be possible). One elt of the list per *value* arg. + + ug_size :: Int, -- The "size" of the unfolding. + + ug_res :: Int -- Scrutinee discount: the discount to substract if the thing is in + } -- a context (case (thing args) of ...), + -- (where there are the right number of arguments.) + + | UnfNever -- The RHS is big, so don't inline it + deriving (Eq) + +{- +Note [Historical note: unfoldings for wrappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to have a nice clever scheme in interface files for +wrappers. A wrapper's unfolding can be reconstructed from its worker's +id and its strictness. This decreased .hi file size (sometimes +significantly, for modules like GHC.Classes with many high-arity w/w +splits) and had a slight corresponding effect on compile times. + +However, when we added the second demand analysis, this scheme lead to +some Core lint errors. The second analysis could change the strictness +signatures, which sometimes resulted in a wrapper's regenerated +unfolding applying the wrapper to too many arguments. + +Instead of repairing the clever .hi scheme, we abandoned it in favor +of simplicity. The .hi sizes are usually insignificant (excluding the ++1M for base libraries), and compile time barely increases (~+1% for +nofib). The nicer upshot is that the UnfoldingSource no longer mentions +an Id, so, eg, substitutions need not traverse them. + + +Note [DFun unfoldings] +~~~~~~~~~~~~~~~~~~~~~~ +The Arity in a DFunUnfolding is total number of args (type and value) +that the DFun needs to produce a dictionary. That's not necessarily +related to the ordinary arity of the dfun Id, esp if the class has +one method, so the dictionary is represented by a newtype. Example + + class C a where { op :: a -> Int } + instance C a -> C [a] where op xs = op (head xs) + +The instance translates to + + $dfCList :: forall a. C a => C [a] -- Arity 2! + $dfCList = /\a.\d. $copList {a} d |> co + + $copList :: forall a. C a => [a] -> Int -- Arity 2! + $copList = /\a.\d.\xs. op {a} d (head xs) + +Now we might encounter (op (dfCList {ty} d) a1 a2) +and we want the (op (dfList {ty} d)) rule to fire, because $dfCList +has all its arguments, even though its (value) arity is 2. That's +why we record the number of expected arguments in the DFunUnfolding. + +Note that although it's an Arity, it's most convenient for it to give +the *total* number of arguments, both type and value. See the use +site in exprIsConApp_maybe. +-} + +-- Constants for the UnfWhen constructor +needSaturated, unSaturatedOk :: Bool +needSaturated = False +unSaturatedOk = True + +boringCxtNotOk, boringCxtOk :: Bool +boringCxtOk = True +boringCxtNotOk = False + +------------------------------------------------ +noUnfolding :: Unfolding +-- ^ There is no known 'Unfolding' +evaldUnfolding :: Unfolding +-- ^ This unfolding marks the associated thing as being evaluated + +noUnfolding = NoUnfolding +evaldUnfolding = OtherCon [] + +-- | There is no known 'Unfolding', because this came from an +-- hi-boot file. +bootUnfolding :: Unfolding +bootUnfolding = BootUnfolding + +mkOtherCon :: [AltCon] -> Unfolding +mkOtherCon = OtherCon + +isStableSource :: UnfoldingSource -> Bool +-- Keep the unfolding template +isStableSource InlineCompulsory = True +isStableSource InlineStable = True +isStableSource InlineRhs = False + +-- | Retrieves the template of an unfolding: panics if none is known +unfoldingTemplate :: Unfolding -> CoreExpr +unfoldingTemplate = uf_tmpl + +-- | Retrieves the template of an unfolding if possible +-- maybeUnfoldingTemplate is used mainly wnen specialising, and we do +-- want to specialise DFuns, so it's important to return a template +-- for DFunUnfoldings +maybeUnfoldingTemplate :: Unfolding -> Maybe CoreExpr +maybeUnfoldingTemplate (CoreUnfolding { uf_tmpl = expr }) + = Just expr +maybeUnfoldingTemplate (DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args }) + = Just (mkLams bndrs (mkApps (Var (dataConWorkId con)) args)) +maybeUnfoldingTemplate _ + = Nothing + +-- | The constructors that the unfolding could never be: +-- returns @[]@ if no information is available +otherCons :: Unfolding -> [AltCon] +otherCons (OtherCon cons) = cons +otherCons _ = [] + +-- | Determines if it is certainly the case that the unfolding will +-- yield a value (something in HNF): returns @False@ if unsure +isValueUnfolding :: Unfolding -> Bool + -- Returns False for OtherCon +isValueUnfolding (CoreUnfolding { uf_is_value = is_evald }) = is_evald +isValueUnfolding _ = False + +-- | Determines if it possibly the case that the unfolding will +-- yield a value. Unlike 'isValueUnfolding' it returns @True@ +-- for 'OtherCon' +isEvaldUnfolding :: Unfolding -> Bool + -- Returns True for OtherCon +isEvaldUnfolding (OtherCon _) = True +isEvaldUnfolding (CoreUnfolding { uf_is_value = is_evald }) = is_evald +isEvaldUnfolding _ = False + +-- | @True@ if the unfolding is a constructor application, the application +-- of a CONLIKE function or 'OtherCon' +isConLikeUnfolding :: Unfolding -> Bool +isConLikeUnfolding (OtherCon _) = True +isConLikeUnfolding (CoreUnfolding { uf_is_conlike = con }) = con +isConLikeUnfolding _ = False + +-- | Is the thing we will unfold into certainly cheap? +isCheapUnfolding :: Unfolding -> Bool +isCheapUnfolding (CoreUnfolding { uf_is_work_free = is_wf }) = is_wf +isCheapUnfolding _ = False + +isExpandableUnfolding :: Unfolding -> Bool +isExpandableUnfolding (CoreUnfolding { uf_expandable = is_expable }) = is_expable +isExpandableUnfolding _ = False + +expandUnfolding_maybe :: Unfolding -> Maybe CoreExpr +-- Expand an expandable unfolding; this is used in rule matching +-- See Note [Expanding variables] in Rules.hs +-- The key point here is that CONLIKE things can be expanded +expandUnfolding_maybe (CoreUnfolding { uf_expandable = True, uf_tmpl = rhs }) = Just rhs +expandUnfolding_maybe _ = Nothing + +isCompulsoryUnfolding :: Unfolding -> Bool +isCompulsoryUnfolding (CoreUnfolding { uf_src = InlineCompulsory }) = True +isCompulsoryUnfolding _ = False + +isStableUnfolding :: Unfolding -> Bool +-- True of unfoldings that should not be overwritten +-- by a CoreUnfolding for the RHS of a let-binding +isStableUnfolding (CoreUnfolding { uf_src = src }) = isStableSource src +isStableUnfolding (DFunUnfolding {}) = True +isStableUnfolding _ = False + +-- | Only returns False if there is no unfolding information available at all +hasSomeUnfolding :: Unfolding -> Bool +hasSomeUnfolding NoUnfolding = False +hasSomeUnfolding BootUnfolding = False +hasSomeUnfolding _ = True + +isBootUnfolding :: Unfolding -> Bool +isBootUnfolding BootUnfolding = True +isBootUnfolding _ = False + +neverUnfoldGuidance :: UnfoldingGuidance -> Bool +neverUnfoldGuidance UnfNever = True +neverUnfoldGuidance _ = False + +isFragileUnfolding :: Unfolding -> Bool +-- An unfolding is fragile if it mentions free variables or +-- is otherwise subject to change. A robust one can be kept. +-- See Note [Fragile unfoldings] +isFragileUnfolding (CoreUnfolding {}) = True +isFragileUnfolding (DFunUnfolding {}) = True +isFragileUnfolding _ = False + -- NoUnfolding, BootUnfolding, OtherCon are all non-fragile + +canUnfold :: Unfolding -> Bool +canUnfold (CoreUnfolding { uf_guidance = g }) = not (neverUnfoldGuidance g) +canUnfold _ = False + +{- Note [Fragile unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An unfolding is "fragile" if it mentions free variables (and hence would +need substitution) or might be affected by optimisation. The non-fragile +ones are + + NoUnfolding, BootUnfolding + + OtherCon {} If we know this binder (say a lambda binder) will be + bound to an evaluated thing, we want to retain that + info in simpleOptExpr; see #13077. + +We consider even a StableUnfolding as fragile, because it needs substitution. + +Note [InlineStable] +~~~~~~~~~~~~~~~~~ +When you say + {-# INLINE f #-} + f x = +you intend that calls (f e) are replaced by [e/x] So we +should capture (\x.) in the Unfolding of 'f', and never meddle +with it. Meanwhile, we can optimise to our heart's content, +leaving the original unfolding intact in Unfolding of 'f'. For example + all xs = foldr (&&) True xs + any p = all . map p {-# INLINE any #-} +We optimise any's RHS fully, but leave the InlineRule saying "all . map p", +which deforests well at the call site. + +So INLINE pragma gives rise to an InlineRule, which captures the original RHS. + +Moreover, it's only used when 'f' is applied to the +specified number of arguments; that is, the number of argument on +the LHS of the '=' sign in the original source definition. +For example, (.) is now defined in the libraries like this + {-# INLINE (.) #-} + (.) f g = \x -> f (g x) +so that it'll inline when applied to two arguments. If 'x' appeared +on the left, thus + (.) f g x = f (g x) +it'd only inline when applied to three arguments. This slightly-experimental +change was requested by Roman, but it seems to make sense. + +See also Note [Inlining an InlineRule] in CoreUnfold. + + +Note [OccInfo in unfoldings and rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In unfoldings and rules, we guarantee that the template is occ-analysed, +so that the occurrence info on the binders is correct. This is important, +because the Simplifier does not re-analyse the template when using it. If +the occurrence info is wrong + - We may get more simplifier iterations than necessary, because + once-occ info isn't there + - More seriously, we may get an infinite loop if there's a Rec + without a loop breaker marked + + +************************************************************************ +* * + AltCon +* * +************************************************************************ +-} + +-- The Ord is needed for the FiniteMap used in the lookForConstructor +-- in SimplEnv. If you declared that lookForConstructor *ignores* +-- constructor-applications with LitArg args, then you could get +-- rid of this Ord. + +instance Outputable AltCon where + ppr (DataAlt dc) = ppr dc + ppr (LitAlt lit) = ppr lit + ppr DEFAULT = text "__DEFAULT" + +cmpAlt :: (AltCon, a, b) -> (AltCon, a, b) -> Ordering +cmpAlt (con1, _, _) (con2, _, _) = con1 `cmpAltCon` con2 + +ltAlt :: (AltCon, a, b) -> (AltCon, a, b) -> Bool +ltAlt a1 a2 = (a1 `cmpAlt` a2) == LT + +cmpAltCon :: AltCon -> AltCon -> Ordering +-- ^ Compares 'AltCon's within a single list of alternatives +-- DEFAULT comes out smallest, so that sorting by AltCon +-- puts alternatives in the order required by #case_invariants# +cmpAltCon DEFAULT DEFAULT = EQ +cmpAltCon DEFAULT _ = LT + +cmpAltCon (DataAlt d1) (DataAlt d2) = dataConTag d1 `compare` dataConTag d2 +cmpAltCon (DataAlt _) DEFAULT = GT +cmpAltCon (LitAlt l1) (LitAlt l2) = l1 `compare` l2 +cmpAltCon (LitAlt _) DEFAULT = GT + +cmpAltCon con1 con2 = WARN( True, text "Comparing incomparable AltCons" <+> + ppr con1 <+> ppr con2 ) + LT + +{- +************************************************************************ +* * +\subsection{Useful synonyms} +* * +************************************************************************ + +Note [CoreProgram] +~~~~~~~~~~~~~~~~~~ +The top level bindings of a program, a CoreProgram, are represented as +a list of CoreBind + + * Later bindings in the list can refer to earlier ones, but not vice + versa. So this is OK + NonRec { x = 4 } + Rec { p = ...q...x... + ; q = ...p...x } + Rec { f = ...p..x..f.. } + NonRec { g = ..f..q...x.. } + But it would NOT be ok for 'f' to refer to 'g'. + + * The occurrence analyser does strongly-connected component analysis + on each Rec binding, and splits it into a sequence of smaller + bindings where possible. So the program typically starts life as a + single giant Rec, which is then dependency-analysed into smaller + chunks. +-} + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in coreSyn/CoreLint.hs +type CoreProgram = [CoreBind] -- See Note [CoreProgram] + +-- | The common case for the type of binders and variables when +-- we are manipulating the Core language within GHC +type CoreBndr = Var +-- | Expressions where binders are 'CoreBndr's +type CoreExpr = Expr CoreBndr +-- | Argument expressions where binders are 'CoreBndr's +type CoreArg = Arg CoreBndr +-- | Binding groups where binders are 'CoreBndr's +type CoreBind = Bind CoreBndr +-- | Case alternatives where binders are 'CoreBndr's +type CoreAlt = Alt CoreBndr + +{- +************************************************************************ +* * +\subsection{Tagging} +* * +************************************************************************ +-} + +-- | Binders are /tagged/ with a t +data TaggedBndr t = TB CoreBndr t -- TB for "tagged binder" + +type TaggedBind t = Bind (TaggedBndr t) +type TaggedExpr t = Expr (TaggedBndr t) +type TaggedArg t = Arg (TaggedBndr t) +type TaggedAlt t = Alt (TaggedBndr t) + +instance Outputable b => Outputable (TaggedBndr b) where + ppr (TB b l) = char '<' <> ppr b <> comma <> ppr l <> char '>' + +deTagExpr :: TaggedExpr t -> CoreExpr +deTagExpr (Var v) = Var v +deTagExpr (Lit l) = Lit l +deTagExpr (Type ty) = Type ty +deTagExpr (Coercion co) = Coercion co +deTagExpr (App e1 e2) = App (deTagExpr e1) (deTagExpr e2) +deTagExpr (Lam (TB b _) e) = Lam b (deTagExpr e) +deTagExpr (Let bind body) = Let (deTagBind bind) (deTagExpr body) +deTagExpr (Case e (TB b _) ty alts) = Case (deTagExpr e) b ty (map deTagAlt alts) +deTagExpr (Tick t e) = Tick t (deTagExpr e) +deTagExpr (Cast e co) = Cast (deTagExpr e) co + +deTagBind :: TaggedBind t -> CoreBind +deTagBind (NonRec (TB b _) rhs) = NonRec b (deTagExpr rhs) +deTagBind (Rec prs) = Rec [(b, deTagExpr rhs) | (TB b _, rhs) <- prs] + +deTagAlt :: TaggedAlt t -> CoreAlt +deTagAlt (con, bndrs, rhs) = (con, [b | TB b _ <- bndrs], deTagExpr rhs) + +{- +************************************************************************ +* * +\subsection{Core-constructing functions with checking} +* * +************************************************************************ +-} + +-- | Apply a list of argument expressions to a function expression in a nested fashion. Prefer to +-- use 'MkCore.mkCoreApps' if possible +mkApps :: Expr b -> [Arg b] -> Expr b +-- | Apply a list of type argument expressions to a function expression in a nested fashion +mkTyApps :: Expr b -> [Type] -> Expr b +-- | Apply a list of coercion argument expressions to a function expression in a nested fashion +mkCoApps :: Expr b -> [Coercion] -> Expr b +-- | Apply a list of type or value variables to a function expression in a nested fashion +mkVarApps :: Expr b -> [Var] -> Expr b +-- | Apply a list of argument expressions to a data constructor in a nested fashion. Prefer to +-- use 'MkCore.mkCoreConApps' if possible +mkConApp :: DataCon -> [Arg b] -> Expr b + +mkApps f args = foldl' App f args +mkCoApps f args = foldl' (\ e a -> App e (Coercion a)) f args +mkVarApps f vars = foldl' (\ e a -> App e (varToCoreExpr a)) f vars +mkConApp con args = mkApps (Var (dataConWorkId con)) args + +mkTyApps f args = foldl' (\ e a -> App e (mkTyArg a)) f args + +mkConApp2 :: DataCon -> [Type] -> [Var] -> Expr b +mkConApp2 con tys arg_ids = Var (dataConWorkId con) + `mkApps` map Type tys + `mkApps` map varToCoreExpr arg_ids + +mkTyArg :: Type -> Expr b +mkTyArg ty + | Just co <- isCoercionTy_maybe ty = Coercion co + | otherwise = Type ty + +-- | Create a machine integer literal expression of type @Int#@ from an @Integer@. +-- If you want an expression of type @Int@ use 'MkCore.mkIntExpr' +mkIntLit :: DynFlags -> Integer -> Expr b +-- | Create a machine integer literal expression of type @Int#@ from an @Int@. +-- If you want an expression of type @Int@ use 'MkCore.mkIntExpr' +mkIntLitInt :: DynFlags -> Int -> Expr b + +mkIntLit dflags n = Lit (mkLitInt dflags n) +mkIntLitInt dflags n = Lit (mkLitInt dflags (toInteger n)) + +-- | Create a machine word literal expression of type @Word#@ from an @Integer@. +-- If you want an expression of type @Word@ use 'MkCore.mkWordExpr' +mkWordLit :: DynFlags -> Integer -> Expr b +-- | Create a machine word literal expression of type @Word#@ from a @Word@. +-- If you want an expression of type @Word@ use 'MkCore.mkWordExpr' +mkWordLitWord :: DynFlags -> Word -> Expr b + +mkWordLit dflags w = Lit (mkLitWord dflags w) +mkWordLitWord dflags w = Lit (mkLitWord dflags (toInteger w)) + +mkWord64LitWord64 :: Word64 -> Expr b +mkWord64LitWord64 w = Lit (mkLitWord64 (toInteger w)) + +mkInt64LitInt64 :: Int64 -> Expr b +mkInt64LitInt64 w = Lit (mkLitInt64 (toInteger w)) + +-- | Create a machine character literal expression of type @Char#@. +-- If you want an expression of type @Char@ use 'MkCore.mkCharExpr' +mkCharLit :: Char -> Expr b +-- | Create a machine string literal expression of type @Addr#@. +-- If you want an expression of type @String@ use 'MkCore.mkStringExpr' +mkStringLit :: String -> Expr b + +mkCharLit c = Lit (mkLitChar c) +mkStringLit s = Lit (mkLitString s) + +-- | Create a machine single precision literal expression of type @Float#@ from a @Rational@. +-- If you want an expression of type @Float@ use 'MkCore.mkFloatExpr' +mkFloatLit :: Rational -> Expr b +-- | Create a machine single precision literal expression of type @Float#@ from a @Float@. +-- If you want an expression of type @Float@ use 'MkCore.mkFloatExpr' +mkFloatLitFloat :: Float -> Expr b + +mkFloatLit f = Lit (mkLitFloat f) +mkFloatLitFloat f = Lit (mkLitFloat (toRational f)) + +-- | Create a machine double precision literal expression of type @Double#@ from a @Rational@. +-- If you want an expression of type @Double@ use 'MkCore.mkDoubleExpr' +mkDoubleLit :: Rational -> Expr b +-- | Create a machine double precision literal expression of type @Double#@ from a @Double@. +-- If you want an expression of type @Double@ use 'MkCore.mkDoubleExpr' +mkDoubleLitDouble :: Double -> Expr b + +mkDoubleLit d = Lit (mkLitDouble d) +mkDoubleLitDouble d = Lit (mkLitDouble (toRational d)) + +-- | Bind all supplied binding groups over an expression in a nested let expression. Assumes +-- that the rhs satisfies the let/app invariant. Prefer to use 'MkCore.mkCoreLets' if +-- possible, which does guarantee the invariant +mkLets :: [Bind b] -> Expr b -> Expr b +-- | Bind all supplied binders over an expression in a nested lambda expression. Prefer to +-- use 'MkCore.mkCoreLams' if possible +mkLams :: [b] -> Expr b -> Expr b + +mkLams binders body = foldr Lam body binders +mkLets binds body = foldr mkLet body binds + +mkLet :: Bind b -> Expr b -> Expr b +-- The desugarer sometimes generates an empty Rec group +-- which Lint rejects, so we kill it off right away +mkLet (Rec []) body = body +mkLet bind body = Let bind body + +-- | @mkLetNonRec bndr rhs body@ wraps @body@ in a @let@ binding @bndr@. +mkLetNonRec :: b -> Expr b -> Expr b -> Expr b +mkLetNonRec b rhs body = Let (NonRec b rhs) body + +-- | @mkLetRec binds body@ wraps @body@ in a @let rec@ with the given set of +-- @binds@ if binds is non-empty. +mkLetRec :: [(b, Expr b)] -> Expr b -> Expr b +mkLetRec [] body = body +mkLetRec bs body = Let (Rec bs) body + +-- | Create a binding group where a type variable is bound to a type. Per "CoreSyn#type_let", +-- this can only be used to bind something in a non-recursive @let@ expression +mkTyBind :: TyVar -> Type -> CoreBind +mkTyBind tv ty = NonRec tv (Type ty) + +-- | Create a binding group where a type variable is bound to a type. Per "CoreSyn#type_let", +-- this can only be used to bind something in a non-recursive @let@ expression +mkCoBind :: CoVar -> Coercion -> CoreBind +mkCoBind cv co = NonRec cv (Coercion co) + +-- | Convert a binder into either a 'Var' or 'Type' 'Expr' appropriately +varToCoreExpr :: CoreBndr -> Expr b +varToCoreExpr v | isTyVar v = Type (mkTyVarTy v) + | isCoVar v = Coercion (mkCoVarCo v) + | otherwise = ASSERT( isId v ) Var v + +varsToCoreExprs :: [CoreBndr] -> [Expr b] +varsToCoreExprs vs = map varToCoreExpr vs + +{- +************************************************************************ +* * + Getting a result type +* * +************************************************************************ + +These are defined here to avoid a module loop between CoreUtils and CoreFVs + +-} + +applyTypeToArg :: Type -> CoreExpr -> Type +-- ^ Determines the type resulting from applying an expression with given type +-- to a given argument expression +applyTypeToArg fun_ty arg = piResultTy fun_ty (exprToType arg) + +-- | If the expression is a 'Type', converts. Otherwise, +-- panics. NB: This does /not/ convert 'Coercion' to 'CoercionTy'. +exprToType :: CoreExpr -> Type +exprToType (Type ty) = ty +exprToType _bad = pprPanic "exprToType" empty + +-- | If the expression is a 'Coercion', converts. +exprToCoercion_maybe :: CoreExpr -> Maybe Coercion +exprToCoercion_maybe (Coercion co) = Just co +exprToCoercion_maybe _ = Nothing + +{- +************************************************************************ +* * +\subsection{Simple access functions} +* * +************************************************************************ +-} + +-- | Extract every variable by this group +bindersOf :: Bind b -> [b] +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] in coreSyn/CoreLint.hs +bindersOf (NonRec binder _) = [binder] +bindersOf (Rec pairs) = [binder | (binder, _) <- pairs] + +-- | 'bindersOf' applied to a list of binding groups +bindersOfBinds :: [Bind b] -> [b] +bindersOfBinds binds = foldr ((++) . bindersOf) [] binds + +rhssOfBind :: Bind b -> [Expr b] +rhssOfBind (NonRec _ rhs) = [rhs] +rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs] + +rhssOfAlts :: [Alt b] -> [Expr b] +rhssOfAlts alts = [e | (_,_,e) <- alts] + +-- | Collapse all the bindings in the supplied groups into a single +-- list of lhs\/rhs pairs suitable for binding in a 'Rec' binding group +flattenBinds :: [Bind b] -> [(b, Expr b)] +flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds +flattenBinds (Rec prs1 : binds) = prs1 ++ flattenBinds binds +flattenBinds [] = [] + +-- | We often want to strip off leading lambdas before getting down to +-- business. Variants are 'collectTyBinders', 'collectValBinders', +-- and 'collectTyAndValBinders' +collectBinders :: Expr b -> ([b], Expr b) +collectTyBinders :: CoreExpr -> ([TyVar], CoreExpr) +collectValBinders :: CoreExpr -> ([Id], CoreExpr) +collectTyAndValBinders :: CoreExpr -> ([TyVar], [Id], CoreExpr) +-- | Strip off exactly N leading lambdas (type or value). Good for use with +-- join points. +collectNBinders :: Int -> Expr b -> ([b], Expr b) + +collectBinders expr + = go [] expr + where + go bs (Lam b e) = go (b:bs) e + go bs e = (reverse bs, e) + +collectTyBinders expr + = go [] expr + where + go tvs (Lam b e) | isTyVar b = go (b:tvs) e + go tvs e = (reverse tvs, e) + +collectValBinders expr + = go [] expr + where + go ids (Lam b e) | isId b = go (b:ids) e + go ids body = (reverse ids, body) + +collectTyAndValBinders expr + = (tvs, ids, body) + where + (tvs, body1) = collectTyBinders expr + (ids, body) = collectValBinders body1 + +collectNBinders orig_n orig_expr + = go orig_n [] orig_expr + where + go 0 bs expr = (reverse bs, expr) + go n bs (Lam b e) = go (n-1) (b:bs) e + go _ _ _ = pprPanic "collectNBinders" $ int orig_n + +-- | Takes a nested application expression and returns the function +-- being applied and the arguments to which it is applied +collectArgs :: Expr b -> (Expr b, [Arg b]) +collectArgs expr + = go expr [] + where + go (App f a) as = go f (a:as) + go e as = (e, as) + +-- | Attempt to remove the last N arguments of a function call. +-- Strip off any ticks or coercions encountered along the way and any +-- at the end. +stripNArgs :: Word -> Expr a -> Maybe (Expr a) +stripNArgs !n (Tick _ e) = stripNArgs n e +stripNArgs n (Cast f _) = stripNArgs n f +stripNArgs 0 e = Just e +stripNArgs n (App f _) = stripNArgs (n - 1) f +stripNArgs _ _ = Nothing + +-- | Like @collectArgs@, but also collects looks through floatable +-- ticks if it means that we can find more arguments. +collectArgsTicks :: (Tickish Id -> Bool) -> Expr b + -> (Expr b, [Arg b], [Tickish Id]) +collectArgsTicks skipTick expr + = go expr [] [] + where + go (App f a) as ts = go f (a:as) ts + go (Tick t e) as ts + | skipTick t = go e as (t:ts) + go e as ts = (e, as, reverse ts) + + +{- +************************************************************************ +* * +\subsection{Predicates} +* * +************************************************************************ + +At one time we optionally carried type arguments through to runtime. +@isRuntimeVar v@ returns if (Lam v _) really becomes a lambda at runtime, +i.e. if type applications are actual lambdas because types are kept around +at runtime. Similarly isRuntimeArg. +-} + +-- | Will this variable exist at runtime? +isRuntimeVar :: Var -> Bool +isRuntimeVar = isId + +-- | Will this argument expression exist at runtime? +isRuntimeArg :: CoreExpr -> Bool +isRuntimeArg = isValArg + +-- | Returns @True@ for value arguments, false for type args +-- NB: coercions are value arguments (zero width, to be sure, +-- like State#, but still value args). +isValArg :: Expr b -> Bool +isValArg e = not (isTypeArg e) + +-- | Returns @True@ iff the expression is a 'Type' or 'Coercion' +-- expression at its top level +isTyCoArg :: Expr b -> Bool +isTyCoArg (Type {}) = True +isTyCoArg (Coercion {}) = True +isTyCoArg _ = False + +-- | Returns @True@ iff the expression is a 'Coercion' +-- expression at its top level +isCoArg :: Expr b -> Bool +isCoArg (Coercion {}) = True +isCoArg _ = False + +-- | Returns @True@ iff the expression is a 'Type' expression at its +-- top level. Note this does NOT include 'Coercion's. +isTypeArg :: Expr b -> Bool +isTypeArg (Type {}) = True +isTypeArg _ = False + +-- | The number of binders that bind values rather than types +valBndrCount :: [CoreBndr] -> Int +valBndrCount = count isId + +-- | The number of argument expressions that are values rather than types at their top level +valArgCount :: [Arg b] -> Int +valArgCount = count isValArg + +{- +************************************************************************ +* * +\subsection{Annotated core} +* * +************************************************************************ +-} + +-- | Annotated core: allows annotation at every node in the tree +type AnnExpr bndr annot = (annot, AnnExpr' bndr annot) + +-- | A clone of the 'Expr' type but allowing annotation at every tree node +data AnnExpr' bndr annot + = AnnVar Id + | AnnLit Literal + | AnnLam bndr (AnnExpr bndr annot) + | AnnApp (AnnExpr bndr annot) (AnnExpr bndr annot) + | AnnCase (AnnExpr bndr annot) bndr Type [AnnAlt bndr annot] + | AnnLet (AnnBind bndr annot) (AnnExpr bndr annot) + | AnnCast (AnnExpr bndr annot) (annot, Coercion) + -- Put an annotation on the (root of) the coercion + | AnnTick (Tickish Id) (AnnExpr bndr annot) + | AnnType Type + | AnnCoercion Coercion + +-- | A clone of the 'Alt' type but allowing annotation at every tree node +type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot) + +-- | A clone of the 'Bind' type but allowing annotation at every tree node +data AnnBind bndr annot + = AnnNonRec bndr (AnnExpr bndr annot) + | AnnRec [(bndr, AnnExpr bndr annot)] + +-- | Takes a nested application expression and returns the function +-- being applied and the arguments to which it is applied +collectAnnArgs :: AnnExpr b a -> (AnnExpr b a, [AnnExpr b a]) +collectAnnArgs expr + = go expr [] + where + go (_, AnnApp f a) as = go f (a:as) + go e as = (e, as) + +collectAnnArgsTicks :: (Tickish Var -> Bool) -> AnnExpr b a + -> (AnnExpr b a, [AnnExpr b a], [Tickish Var]) +collectAnnArgsTicks tickishOk expr + = go expr [] [] + where + go (_, AnnApp f a) as ts = go f (a:as) ts + go (_, AnnTick t e) as ts | tickishOk t + = go e as (t:ts) + go e as ts = (e, as, reverse ts) + +deAnnotate :: AnnExpr bndr annot -> Expr bndr +deAnnotate (_, e) = deAnnotate' e + +deAnnotate' :: AnnExpr' bndr annot -> Expr bndr +deAnnotate' (AnnType t) = Type t +deAnnotate' (AnnCoercion co) = Coercion co +deAnnotate' (AnnVar v) = Var v +deAnnotate' (AnnLit lit) = Lit lit +deAnnotate' (AnnLam binder body) = Lam binder (deAnnotate body) +deAnnotate' (AnnApp fun arg) = App (deAnnotate fun) (deAnnotate arg) +deAnnotate' (AnnCast e (_,co)) = Cast (deAnnotate e) co +deAnnotate' (AnnTick tick body) = Tick tick (deAnnotate body) + +deAnnotate' (AnnLet bind body) + = Let (deAnnBind bind) (deAnnotate body) +deAnnotate' (AnnCase scrut v t alts) + = Case (deAnnotate scrut) v t (map deAnnAlt alts) + +deAnnAlt :: AnnAlt bndr annot -> Alt bndr +deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs) + +deAnnBind :: AnnBind b annot -> Bind b +deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs) +deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs] + +-- | As 'collectBinders' but for 'AnnExpr' rather than 'Expr' +collectAnnBndrs :: AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot) +collectAnnBndrs e + = collect [] e + where + collect bs (_, AnnLam b body) = collect (b:bs) body + collect bs body = (reverse bs, body) + +-- | As 'collectNBinders' but for 'AnnExpr' rather than 'Expr' +collectNAnnBndrs :: Int -> AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot) +collectNAnnBndrs orig_n e + = collect orig_n [] e + where + collect 0 bs body = (reverse bs, body) + collect n bs (_, AnnLam b body) = collect (n-1) (b:bs) body + collect _ _ _ = pprPanic "collectNBinders" $ int orig_n diff --git a/compiler/coreSyn/CoreTidy.hs b/compiler/coreSyn/CoreTidy.hs new file mode 100644 --- /dev/null +++ b/compiler/coreSyn/CoreTidy.hs @@ -0,0 +1,282 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1996-1998 + + +This module contains "tidying" code for *nested* expressions, bindings, rules. +The code for *top-level* bindings is in TidyPgm. +-} + +{-# LANGUAGE CPP #-} +module CoreTidy ( + tidyExpr, tidyVarOcc, tidyRule, tidyRules, tidyUnfolding + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import CoreSyn +import CoreSeq ( seqUnfolding ) +import CoreArity +import Id +import IdInfo +import Demand ( zapUsageEnvSig ) +import Type( tidyType, tidyVarBndr ) +import Coercion( tidyCo ) +import Var +import VarEnv +import UniqFM +import Name hiding (tidyNameOcc) +import SrcLoc +import Maybes +import Data.List + +{- +************************************************************************ +* * +\subsection{Tidying expressions, rules} +* * +************************************************************************ +-} + +tidyBind :: TidyEnv + -> CoreBind + -> (TidyEnv, CoreBind) + +tidyBind env (NonRec bndr rhs) + = tidyLetBndr env env (bndr,rhs) =: \ (env', bndr') -> + (env', NonRec bndr' (tidyExpr env' rhs)) + +tidyBind env (Rec prs) + = let + (env', bndrs') = mapAccumL (tidyLetBndr env') env prs + in + map (tidyExpr env') (map snd prs) =: \ rhss' -> + (env', Rec (zip bndrs' rhss')) + + +------------ Expressions -------------- +tidyExpr :: TidyEnv -> CoreExpr -> CoreExpr +tidyExpr env (Var v) = Var (tidyVarOcc env v) +tidyExpr env (Type ty) = Type (tidyType env ty) +tidyExpr env (Coercion co) = Coercion (tidyCo env co) +tidyExpr _ (Lit lit) = Lit lit +tidyExpr env (App f a) = App (tidyExpr env f) (tidyExpr env a) +tidyExpr env (Tick t e) = Tick (tidyTickish env t) (tidyExpr env e) +tidyExpr env (Cast e co) = Cast (tidyExpr env e) (tidyCo env co) + +tidyExpr env (Let b e) + = tidyBind env b =: \ (env', b') -> + Let b' (tidyExpr env' e) + +tidyExpr env (Case e b ty alts) + = tidyBndr env b =: \ (env', b) -> + Case (tidyExpr env e) b (tidyType env ty) + (map (tidyAlt env') alts) + +tidyExpr env (Lam b e) + = tidyBndr env b =: \ (env', b) -> + Lam b (tidyExpr env' e) + +------------ Case alternatives -------------- +tidyAlt :: TidyEnv -> CoreAlt -> CoreAlt +tidyAlt env (con, vs, rhs) + = tidyBndrs env vs =: \ (env', vs) -> + (con, vs, tidyExpr env' rhs) + +------------ Tickish -------------- +tidyTickish :: TidyEnv -> Tickish Id -> Tickish Id +tidyTickish env (Breakpoint ix ids) = Breakpoint ix (map (tidyVarOcc env) ids) +tidyTickish _ other_tickish = other_tickish + +------------ Rules -------------- +tidyRules :: TidyEnv -> [CoreRule] -> [CoreRule] +tidyRules _ [] = [] +tidyRules env (rule : rules) + = tidyRule env rule =: \ rule -> + tidyRules env rules =: \ rules -> + (rule : rules) + +tidyRule :: TidyEnv -> CoreRule -> CoreRule +tidyRule _ rule@(BuiltinRule {}) = rule +tidyRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs, + ru_fn = fn, ru_rough = mb_ns }) + = tidyBndrs env bndrs =: \ (env', bndrs) -> + map (tidyExpr env') args =: \ args -> + rule { ru_bndrs = bndrs, ru_args = args, + ru_rhs = tidyExpr env' rhs, + ru_fn = tidyNameOcc env fn, + ru_rough = map (fmap (tidyNameOcc env')) mb_ns } + +{- +************************************************************************ +* * +\subsection{Tidying non-top-level binders} +* * +************************************************************************ +-} + +tidyNameOcc :: TidyEnv -> Name -> Name +-- In rules and instances, we have Names, and we must tidy them too +-- Fortunately, we can lookup in the VarEnv with a name +tidyNameOcc (_, var_env) n = case lookupUFM var_env n of + Nothing -> n + Just v -> idName v + +tidyVarOcc :: TidyEnv -> Var -> Var +tidyVarOcc (_, var_env) v = lookupVarEnv var_env v `orElse` v + +-- tidyBndr is used for lambda and case binders +tidyBndr :: TidyEnv -> Var -> (TidyEnv, Var) +tidyBndr env var + | isTyCoVar var = tidyVarBndr env var + | otherwise = tidyIdBndr env var + +tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var]) +tidyBndrs env vars = mapAccumL tidyBndr env vars + +-- Non-top-level variables, not covars +tidyIdBndr :: TidyEnv -> Id -> (TidyEnv, Id) +tidyIdBndr env@(tidy_env, var_env) id + = -- Do this pattern match strictly, otherwise we end up holding on to + -- stuff in the OccName. + case tidyOccName tidy_env (getOccName id) of { (tidy_env', occ') -> + let + -- Give the Id a fresh print-name, *and* rename its type + -- The SrcLoc isn't important now, + -- though we could extract it from the Id + -- + ty' = tidyType env (idType id) + name' = mkInternalName (idUnique id) occ' noSrcSpan + id' = mkLocalIdWithInfo name' ty' new_info + var_env' = extendVarEnv var_env id id' + + -- Note [Tidy IdInfo] + new_info = vanillaIdInfo `setOccInfo` occInfo old_info + `setUnfoldingInfo` new_unf + -- see Note [Preserve OneShotInfo] + `setOneShotInfo` oneShotInfo old_info + old_info = idInfo id + old_unf = unfoldingInfo old_info + new_unf = zapUnfolding old_unf -- See Note [Preserve evaluatedness] + in + ((tidy_env', var_env'), id') + } + +tidyLetBndr :: TidyEnv -- Knot-tied version for unfoldings + -> TidyEnv -- The one to extend + -> (Id, CoreExpr) -> (TidyEnv, Var) +-- Used for local (non-top-level) let(rec)s +-- Just like tidyIdBndr above, but with more IdInfo +tidyLetBndr rec_tidy_env env@(tidy_env, var_env) (id,rhs) + = case tidyOccName tidy_env (getOccName id) of { (tidy_env', occ') -> + let + ty' = tidyType env (idType id) + name' = mkInternalName (idUnique id) occ' noSrcSpan + details = idDetails id + id' = mkLocalVar details name' ty' new_info + var_env' = extendVarEnv var_env id id' + + -- Note [Tidy IdInfo] + -- We need to keep around any interesting strictness and + -- demand info because later on we may need to use it when + -- converting to A-normal form. + -- eg. + -- f (g x), where f is strict in its argument, will be converted + -- into case (g x) of z -> f z by CorePrep, but only if f still + -- has its strictness info. + -- + -- Similarly for the demand info - on a let binder, this tells + -- CorePrep to turn the let into a case. + -- But: Remove the usage demand here + -- (See Note [Zapping DmdEnv after Demand Analyzer] in WorkWrap) + -- + -- Similarly arity info for eta expansion in CorePrep + -- + -- Set inline-prag info so that we preseve it across + -- separate compilation boundaries + old_info = idInfo id + new_info = vanillaIdInfo + `setOccInfo` occInfo old_info + `setArityInfo` exprArity rhs + `setStrictnessInfo` zapUsageEnvSig (strictnessInfo old_info) + `setDemandInfo` demandInfo old_info + `setInlinePragInfo` inlinePragInfo old_info + `setUnfoldingInfo` new_unf + + old_unf = unfoldingInfo old_info + new_unf | isStableUnfolding old_unf = tidyUnfolding rec_tidy_env old_unf old_unf + | otherwise = zapUnfolding old_unf + -- See Note [Preserve evaluatedness] + in + ((tidy_env', var_env'), id') } + +------------ Unfolding -------------- +tidyUnfolding :: TidyEnv -> Unfolding -> Unfolding -> Unfolding +tidyUnfolding tidy_env df@(DFunUnfolding { df_bndrs = bndrs, df_args = args }) _ + = df { df_bndrs = bndrs', df_args = map (tidyExpr tidy_env') args } + where + (tidy_env', bndrs') = tidyBndrs tidy_env bndrs + +tidyUnfolding tidy_env + unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src }) + unf_from_rhs + | isStableSource src + = seqIt $ unf { uf_tmpl = tidyExpr tidy_env unf_rhs } -- Preserves OccInfo + -- This seqIt avoids a space leak: otherwise the uf_is_value, + -- uf_is_conlike, ... fields may retain a reference to the + -- pre-tidied expression forever (ToIface doesn't look at them) + + | otherwise + = unf_from_rhs + where seqIt unf = seqUnfolding unf `seq` unf +tidyUnfolding _ unf _ = unf -- NoUnfolding or OtherCon + +{- +Note [Tidy IdInfo] +~~~~~~~~~~~~~~~~~~ +All nested Ids now have the same IdInfo, namely vanillaIdInfo, which +should save some space; except that we preserve occurrence info for +two reasons: + + (a) To make printing tidy core nicer + + (b) Because we tidy RULES and InlineRules, which may then propagate + via --make into the compilation of the next module, and we want + the benefit of that occurrence analysis when we use the rule or + or inline the function. In particular, it's vital not to lose + loop-breaker info, else we get an infinite inlining loop + +Note that tidyLetBndr puts more IdInfo back. + +Note [Preserve evaluatedness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T = MkT !Bool + ....(case v of MkT y -> + let z# = case y of + True -> 1# + False -> 2# + in ...) + +The z# binding is ok because the RHS is ok-for-speculation, +but Lint will complain unless it can *see* that. So we +preserve the evaluated-ness on 'y' in tidyBndr. + +(Another alternative would be to tidy unboxed lets into cases, +but that seems more indirect and surprising.) + +Note [Preserve OneShotInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We keep the OneShotInfo because we want it to propagate into the interface. +Not all OneShotInfo is determined by a compiler analysis; some is added by a +call of GHC.Exts.oneShot, which is then discarded before the end of the +optimisation pipeline, leaving only the OneShotInfo on the lambda. Hence we +must preserve this info in inlinings. See Note [The oneShot function] in MkId. + +This applies to lambda binders only, hence it is stored in IfaceLamBndr. +-} + +(=:) :: a -> (a -> b) -> b +m =: k = m `seq` k m diff --git a/compiler/coreSyn/CoreUnfold.hs b/compiler/coreSyn/CoreUnfold.hs new file mode 100644 --- /dev/null +++ b/compiler/coreSyn/CoreUnfold.hs @@ -0,0 +1,1605 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1994-1998 + + +Core-syntax unfoldings + +Unfoldings (which can travel across module boundaries) are in Core +syntax (namely @CoreExpr@s). + +The type @Unfolding@ sits ``above'' simply-Core-expressions +unfoldings, capturing ``higher-level'' things we know about a binding, +usually things that the simplifier found out (e.g., ``it's a +literal''). In the corner of a @CoreUnfolding@ unfolding, you will +find, unsurprisingly, a Core expression. +-} + +{-# LANGUAGE CPP #-} + +module CoreUnfold ( + Unfolding, UnfoldingGuidance, -- Abstract types + + noUnfolding, mkImplicitUnfolding, + mkUnfolding, mkCoreUnfolding, + mkTopUnfolding, mkSimpleUnfolding, mkWorkerUnfolding, + mkInlineUnfolding, mkInlineUnfoldingWithArity, + mkInlinableUnfolding, mkWwInlineRule, + mkCompulsoryUnfolding, mkDFunUnfolding, + specUnfolding, + + ArgSummary(..), + + couldBeSmallEnoughToInline, inlineBoringOk, + certainlyWillInline, smallEnoughToInline, + + callSiteInline, CallCtxt(..), + + -- Reexport from CoreSubst (it only live there so it can be used + -- by the Very Simple Optimiser) + exprIsConApp_maybe, exprIsLiteral_maybe + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import DynFlags +import CoreSyn +import PprCore () -- Instances +import OccurAnal ( occurAnalyseExpr_NoBinderSwap ) +import CoreOpt +import CoreArity ( manifestArity ) +import CoreUtils +import Id +import Demand ( isBottomingSig ) +import DataCon +import Literal +import PrimOp +import IdInfo +import BasicTypes ( Arity, InlineSpec(..), inlinePragmaSpec ) +import Type +import PrelNames +import TysPrim ( realWorldStatePrimTy ) +import Bag +import Util +import Outputable +import ForeignCall +import Name + +import qualified Data.ByteString as BS +import Data.List + +{- +************************************************************************ +* * +\subsection{Making unfoldings} +* * +************************************************************************ +-} + +mkTopUnfolding :: DynFlags -> Bool -> CoreExpr -> Unfolding +mkTopUnfolding dflags is_bottoming rhs + = mkUnfolding dflags InlineRhs True is_bottoming rhs + +mkImplicitUnfolding :: DynFlags -> CoreExpr -> Unfolding +-- For implicit Ids, do a tiny bit of optimising first +mkImplicitUnfolding dflags expr + = mkTopUnfolding dflags False (simpleOptExpr dflags expr) + +-- Note [Top-level flag on inline rules] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Slight hack: note that mk_inline_rules conservatively sets the +-- top-level flag to True. It gets set more accurately by the simplifier +-- Simplify.simplUnfolding. + +mkSimpleUnfolding :: DynFlags -> CoreExpr -> Unfolding +mkSimpleUnfolding dflags rhs + = mkUnfolding dflags InlineRhs False False rhs + +mkDFunUnfolding :: [Var] -> DataCon -> [CoreExpr] -> Unfolding +mkDFunUnfolding bndrs con ops + = DFunUnfolding { df_bndrs = bndrs + , df_con = con + , df_args = map occurAnalyseExpr_NoBinderSwap ops } + -- See Note [Occurrence analysis of unfoldings] + +mkWwInlineRule :: DynFlags -> CoreExpr -> Arity -> Unfolding +mkWwInlineRule dflags expr arity + = mkCoreUnfolding InlineStable True + (simpleOptExpr dflags expr) + (UnfWhen { ug_arity = arity, ug_unsat_ok = unSaturatedOk + , ug_boring_ok = boringCxtNotOk }) + +mkCompulsoryUnfolding :: CoreExpr -> Unfolding +mkCompulsoryUnfolding expr -- Used for things that absolutely must be unfolded + = mkCoreUnfolding InlineCompulsory True + (simpleOptExpr unsafeGlobalDynFlags expr) + (UnfWhen { ug_arity = 0 -- Arity of unfolding doesn't matter + , ug_unsat_ok = unSaturatedOk, ug_boring_ok = boringCxtOk }) + +mkWorkerUnfolding :: DynFlags -> (CoreExpr -> CoreExpr) -> Unfolding -> Unfolding +-- See Note [Worker-wrapper for INLINABLE functions] in WorkWrap +mkWorkerUnfolding dflags work_fn + (CoreUnfolding { uf_src = src, uf_tmpl = tmpl + , uf_is_top = top_lvl }) + | isStableSource src + = mkCoreUnfolding src top_lvl new_tmpl guidance + where + new_tmpl = simpleOptExpr dflags (work_fn tmpl) + guidance = calcUnfoldingGuidance dflags False new_tmpl + +mkWorkerUnfolding _ _ _ = noUnfolding + +-- | Make an unfolding that may be used unsaturated +-- (ug_unsat_ok = unSaturatedOk) and that is reported as having its +-- manifest arity (the number of outer lambdas applications will +-- resolve before doing any work). +mkInlineUnfolding :: CoreExpr -> Unfolding +mkInlineUnfolding expr + = mkCoreUnfolding InlineStable + True -- Note [Top-level flag on inline rules] + expr' guide + where + expr' = simpleOptExpr unsafeGlobalDynFlags expr + guide = UnfWhen { ug_arity = manifestArity expr' + , ug_unsat_ok = unSaturatedOk + , ug_boring_ok = boring_ok } + boring_ok = inlineBoringOk expr' + +-- | Make an unfolding that will be used once the RHS has been saturated +-- to the given arity. +mkInlineUnfoldingWithArity :: Arity -> CoreExpr -> Unfolding +mkInlineUnfoldingWithArity arity expr + = mkCoreUnfolding InlineStable + True -- Note [Top-level flag on inline rules] + expr' guide + where + expr' = simpleOptExpr unsafeGlobalDynFlags expr + guide = UnfWhen { ug_arity = arity + , ug_unsat_ok = needSaturated + , ug_boring_ok = boring_ok } + -- See Note [INLINE pragmas and boring contexts] as to why we need to look + -- at the arity here. + boring_ok | arity == 0 = True + | otherwise = inlineBoringOk expr' + +mkInlinableUnfolding :: DynFlags -> CoreExpr -> Unfolding +mkInlinableUnfolding dflags expr + = mkUnfolding dflags InlineStable False False expr' + where + expr' = simpleOptExpr dflags expr + +specUnfolding :: DynFlags -> [Var] -> (CoreExpr -> CoreExpr) -> Arity + -> Unfolding -> Unfolding +-- See Note [Specialising unfoldings] +-- specUnfolding spec_bndrs spec_app arity_decrease unf +-- = \spec_bndrs. spec_app( unf ) +-- +specUnfolding dflags spec_bndrs spec_app arity_decrease + df@(DFunUnfolding { df_bndrs = old_bndrs, df_con = con, df_args = args }) + = ASSERT2( arity_decrease == count isId old_bndrs - count isId spec_bndrs, ppr df ) + mkDFunUnfolding spec_bndrs con (map spec_arg args) + -- There is a hard-to-check assumption here that the spec_app has + -- enough applications to exactly saturate the old_bndrs + -- For DFunUnfoldings we transform + -- \old_bndrs. MkD ... + -- to + -- \new_bndrs. MkD (spec_app(\old_bndrs. )) ... ditto + -- The ASSERT checks the value part of that + where + spec_arg arg = simpleOptExpr dflags (spec_app (mkLams old_bndrs arg)) + -- The beta-redexes created by spec_app will be + -- simplified away by simplOptExpr + +specUnfolding dflags spec_bndrs spec_app arity_decrease + (CoreUnfolding { uf_src = src, uf_tmpl = tmpl + , uf_is_top = top_lvl + , uf_guidance = old_guidance }) + | isStableSource src -- See Note [Specialising unfoldings] + , UnfWhen { ug_arity = old_arity + , ug_unsat_ok = unsat_ok + , ug_boring_ok = boring_ok } <- old_guidance + = let guidance = UnfWhen { ug_arity = old_arity - arity_decrease + , ug_unsat_ok = unsat_ok + , ug_boring_ok = boring_ok } + new_tmpl = simpleOptExpr dflags (mkLams spec_bndrs (spec_app tmpl)) + -- The beta-redexes created by spec_app will be + -- simplified away by simplOptExpr + + in mkCoreUnfolding src top_lvl new_tmpl guidance + +specUnfolding _ _ _ _ _ = noUnfolding + +{- Note [Specialising unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we specialise a function for some given type-class arguments, we use +specUnfolding to specialise its unfolding. Some important points: + +* If the original function has a DFunUnfolding, the specialised one + must do so too! Otherwise we lose the magic rules that make it + interact with ClassOps + +* There is a bit of hack for INLINABLE functions: + f :: Ord a => .... + f = + {- INLINABLE f #-} + Now if we specialise f, should the specialised version still have + an INLINABLE pragma? If it does, we'll capture a specialised copy + of as its unfolding, and that probaby won't inline. But + if we don't, the specialised version of might be small + enough to inline at a call site. This happens with Control.Monad.liftM3, + and can cause a lot more allocation as a result (nofib n-body shows this). + + Moreover, keeping the INLINABLE thing isn't much help, because + the specialised function (probaby) isn't overloaded any more. + + Conclusion: drop the INLINEALE pragma. In practice what this means is: + if a stable unfolding has UnfoldingGuidance of UnfWhen, + we keep it (so the specialised thing too will always inline) + if a stable unfolding has UnfoldingGuidance of UnfIfGoodArgs + (which arises from INLINABLE), we discard it + +Note [Honour INLINE on 0-ary bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + x = + {-# INLINE x #-} + + f y = ...x... + +The semantics of an INLINE pragma is + + inline x at every call site, provided it is saturated; + that is, applied to at least as many arguments as appear + on the LHS of the Haskell source definition. + +(This soure-code-derived arity is stored in the `ug_arity` field of +the `UnfoldingGuidance`.) + +In the example, x's ug_arity is 0, so we should inline it at every use +site. It's rare to have such an INLINE pragma (usually INLINE Is on +functions), but it's occasionally very important (#15578, #15519). +In #15519 we had something like + x = case (g a b) of I# r -> T r + {-# INLINE x #-} + f y = ...(h x).... + +where h is strict. So we got + f y = ...(case g a b of I# r -> h (T r))... + +and that in turn allowed SpecConstr to ramp up performance. + +How do we deliver on this? By adjusting the ug_boring_ok +flag in mkInlineUnfoldingWithArity; see +Note [INLINE pragmas and boring contexts] + +NB: there is a real risk that full laziness will float it right back +out again. Consider again + x = factorial 200 + {-# INLINE x #-} + f y = ...x... + +After inlining we get + f y = ...(factorial 200)... + +but it's entirely possible that full laziness will do + lvl23 = factorial 200 + f y = ...lvl23... + +That's a problem for another day. + +Note [INLINE pragmas and boring contexts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An INLINE pragma uses mkInlineUnfoldingWithArity to build the +unfolding. That sets the ug_boring_ok flag to False if the function +is not tiny (inlineBoringOK), so that even INLINE functions are not +inlined in an utterly boring context. E.g. + \x y. Just (f y x) +Nothing is gained by inlining f here, even if it has an INLINE +pragma. + +But for 0-ary bindings, we want to inline regardless; see +Note [Honour INLINE on 0-ary bindings]. + +I'm a bit worried that it's possible for the same kind of problem +to arise for non-0-ary functions too, but let's wait and see. +-} + +mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr + -> UnfoldingGuidance -> Unfolding +-- Occurrence-analyses the expression before capturing it +mkCoreUnfolding src top_lvl expr guidance + = CoreUnfolding { uf_tmpl = occurAnalyseExpr_NoBinderSwap expr, + -- See Note [Occurrence analysis of unfoldings] + uf_src = src, + uf_is_top = top_lvl, + uf_is_value = exprIsHNF expr, + uf_is_conlike = exprIsConLike expr, + uf_is_work_free = exprIsWorkFree expr, + uf_expandable = exprIsExpandable expr, + uf_guidance = guidance } + +mkUnfolding :: DynFlags -> UnfoldingSource + -> Bool -- Is top-level + -> Bool -- Definitely a bottoming binding + -- (only relevant for top-level bindings) + -> CoreExpr + -> Unfolding +-- Calculates unfolding guidance +-- Occurrence-analyses the expression before capturing it +mkUnfolding dflags src is_top_lvl is_bottoming expr + = CoreUnfolding { uf_tmpl = occurAnalyseExpr_NoBinderSwap expr, + -- See Note [Occurrence analysis of unfoldings] + uf_src = src, + uf_is_top = is_top_lvl, + uf_is_value = exprIsHNF expr, + uf_is_conlike = exprIsConLike expr, + uf_expandable = exprIsExpandable expr, + uf_is_work_free = exprIsWorkFree expr, + uf_guidance = guidance } + where + is_top_bottoming = is_top_lvl && is_bottoming + guidance = calcUnfoldingGuidance dflags is_top_bottoming expr + -- NB: *not* (calcUnfoldingGuidance (occurAnalyseExpr_NoBinderSwap expr))! + -- See Note [Calculate unfolding guidance on the non-occ-anal'd expression] + +{- +Note [Occurrence analysis of unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We do occurrence-analysis of unfoldings once and for all, when the +unfolding is built, rather than each time we inline them. + +But given this decision it's vital that we do +*always* do it. Consider this unfolding + \x -> letrec { f = ...g...; g* = f } in body +where g* is (for some strange reason) the loop breaker. If we don't +occ-anal it when reading it in, we won't mark g as a loop breaker, and +we may inline g entirely in body, dropping its binding, and leaving +the occurrence in f out of scope. This happened in #8892, where +the unfolding in question was a DFun unfolding. + +But more generally, the simplifier is designed on the +basis that it is looking at occurrence-analysed expressions, so better +ensure that they acutally are. + +We use occurAnalyseExpr_NoBinderSwap instead of occurAnalyseExpr; +see Note [No binder swap in unfoldings]. + +Note [No binder swap in unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The binder swap can temporarily violate Core Lint, by assinging +a LocalId binding to a GlobalId. For example, if A.foo{r872} +is a GlobalId with unique r872, then + + case A.foo{r872} of bar { + K x -> ...(A.foo{r872})... + } + +gets transformed to + + case A.foo{r872} of bar { + K x -> let foo{r872} = bar + in ...(A.foo{r872})... + +This is usually not a problem, because the simplifier will transform +this to: + + case A.foo{r872} of bar { + K x -> ...(bar)... + +However, after occurrence analysis but before simplification, this extra 'let' +violates the Core Lint invariant that we do not have local 'let' bindings for +GlobalIds. That seems (just) tolerable for the occurrence analysis that happens +just before the Simplifier, but not for unfoldings, which are Linted +independently. +As a quick workaround, we disable binder swap in this module. +See #16288 and #16296 for further plans. + +Note [Calculate unfolding guidance on the non-occ-anal'd expression] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Notice that we give the non-occur-analysed expression to +calcUnfoldingGuidance. In some ways it'd be better to occur-analyse +first; for example, sometimes during simplification, there's a large +let-bound thing which has been substituted, and so is now dead; so +'expr' contains two copies of the thing while the occurrence-analysed +expression doesn't. + +Nevertheless, we *don't* and *must not* occ-analyse before computing +the size because + +a) The size computation bales out after a while, whereas occurrence + analysis does not. + +b) Residency increases sharply if you occ-anal first. I'm not + 100% sure why, but it's a large effect. Compiling Cabal went + from residency of 534M to over 800M with this one change. + +This can occasionally mean that the guidance is very pessimistic; +it gets fixed up next round. And it should be rare, because large +let-bound things that are dead are usually caught by preInlineUnconditionally + + +************************************************************************ +* * +\subsection{The UnfoldingGuidance type} +* * +************************************************************************ +-} + +inlineBoringOk :: CoreExpr -> Bool +-- See Note [INLINE for small functions] +-- True => the result of inlining the expression is +-- no bigger than the expression itself +-- eg (\x y -> f y x) +-- This is a quick and dirty version. It doesn't attempt +-- to deal with (\x y z -> x (y z)) +-- The really important one is (x `cast` c) +inlineBoringOk e + = go 0 e + where + go :: Int -> CoreExpr -> Bool + go credit (Lam x e) | isId x = go (credit+1) e + | otherwise = go credit e + go credit (App f (Type {})) = go credit f + go credit (App f a) | credit > 0 + , exprIsTrivial a = go (credit-1) f + go credit (Tick _ e) = go credit e -- dubious + go credit (Cast e _) = go credit e + go _ (Var {}) = boringCxtOk + go _ _ = boringCxtNotOk + +calcUnfoldingGuidance + :: DynFlags + -> Bool -- Definitely a top-level, bottoming binding + -> CoreExpr -- Expression to look at + -> UnfoldingGuidance +calcUnfoldingGuidance dflags is_top_bottoming (Tick t expr) + | not (tickishIsCode t) -- non-code ticks don't matter for unfolding + = calcUnfoldingGuidance dflags is_top_bottoming expr +calcUnfoldingGuidance dflags is_top_bottoming expr + = case sizeExpr dflags bOMB_OUT_SIZE val_bndrs body of + TooBig -> UnfNever + SizeIs size cased_bndrs scrut_discount + | uncondInline expr n_val_bndrs size + -> UnfWhen { ug_unsat_ok = unSaturatedOk + , ug_boring_ok = boringCxtOk + , ug_arity = n_val_bndrs } -- Note [INLINE for small functions] + + | is_top_bottoming + -> UnfNever -- See Note [Do not inline top-level bottoming functions] + + | otherwise + -> UnfIfGoodArgs { ug_args = map (mk_discount cased_bndrs) val_bndrs + , ug_size = size + , ug_res = scrut_discount } + + where + (bndrs, body) = collectBinders expr + bOMB_OUT_SIZE = ufCreationThreshold dflags + -- Bomb out if size gets bigger than this + val_bndrs = filter isId bndrs + n_val_bndrs = length val_bndrs + + mk_discount :: Bag (Id,Int) -> Id -> Int + mk_discount cbs bndr = foldlBag combine 0 cbs + where + combine acc (bndr', disc) + | bndr == bndr' = acc `plus_disc` disc + | otherwise = acc + + plus_disc :: Int -> Int -> Int + plus_disc | isFunTy (idType bndr) = max + | otherwise = (+) + -- See Note [Function and non-function discounts] + +{- +Note [Computing the size of an expression] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The basic idea of sizeExpr is obvious enough: count nodes. But getting the +heuristics right has taken a long time. Here's the basic strategy: + + * Variables, literals: 0 + (Exception for string literals, see litSize.) + + * Function applications (f e1 .. en): 1 + #value args + + * Constructor applications: 1, regardless of #args + + * Let(rec): 1 + size of components + + * Note, cast: 0 + +Examples + + Size Term + -------------- + 0 42# + 0 x + 0 True + 2 f x + 1 Just x + 4 f (g x) + +Notice that 'x' counts 0, while (f x) counts 2. That's deliberate: there's +a function call to account for. Notice also that constructor applications +are very cheap, because exposing them to a caller is so valuable. + +[25/5/11] All sizes are now multiplied by 10, except for primops +(which have sizes like 1 or 4. This makes primops look fantastically +cheap, and seems to be almost unversally beneficial. Done partly as a +result of #4978. + +Note [Do not inline top-level bottoming functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The FloatOut pass has gone to some trouble to float out calls to 'error' +and similar friends. See Note [Bottoming floats] in SetLevels. +Do not re-inline them! But we *do* still inline if they are very small +(the uncondInline stuff). + +Note [INLINE for small functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider {-# INLINE f #-} + f x = Just x + g y = f y +Then f's RHS is no larger than its LHS, so we should inline it into +even the most boring context. In general, f the function is +sufficiently small that its body is as small as the call itself, the +inline unconditionally, regardless of how boring the context is. + +Things to note: + +(1) We inline *unconditionally* if inlined thing is smaller (using sizeExpr) + than the thing it's replacing. Notice that + (f x) --> (g 3) -- YES, unconditionally + (f x) --> x : [] -- YES, *even though* there are two + -- arguments to the cons + x --> g 3 -- NO + x --> Just v -- NO + + It's very important not to unconditionally replace a variable by + a non-atomic term. + +(2) We do this even if the thing isn't saturated, else we end up with the + silly situation that + f x y = x + ...map (f 3)... + doesn't inline. Even in a boring context, inlining without being + saturated will give a lambda instead of a PAP, and will be more + efficient at runtime. + +(3) However, when the function's arity > 0, we do insist that it + has at least one value argument at the call site. (This check is + made in the UnfWhen case of callSiteInline.) Otherwise we find this: + f = /\a \x:a. x + d = /\b. MkD (f b) + If we inline f here we get + d = /\b. MkD (\x:b. x) + and then prepareRhs floats out the argument, abstracting the type + variables, so we end up with the original again! + +(4) We must be much more cautious about arity-zero things. Consider + let x = y +# z in ... + In *size* terms primops look very small, because the generate a + single instruction, but we do not want to unconditionally replace + every occurrence of x with (y +# z). So we only do the + unconditional-inline thing for *trivial* expressions. + + NB: you might think that PostInlineUnconditionally would do this + but it doesn't fire for top-level things; see SimplUtils + Note [Top level and postInlineUnconditionally] +-} + +uncondInline :: CoreExpr -> Arity -> Int -> Bool +-- Inline unconditionally if there no size increase +-- Size of call is arity (+1 for the function) +-- See Note [INLINE for small functions] +uncondInline rhs arity size + | arity > 0 = size <= 10 * (arity + 1) -- See Note [INLINE for small functions] (1) + | otherwise = exprIsTrivial rhs -- See Note [INLINE for small functions] (4) + +sizeExpr :: DynFlags + -> Int -- Bomb out if it gets bigger than this + -> [Id] -- Arguments; we're interested in which of these + -- get case'd + -> CoreExpr + -> ExprSize + +-- Note [Computing the size of an expression] + +sizeExpr dflags bOMB_OUT_SIZE top_args expr + = size_up expr + where + size_up (Cast e _) = size_up e + size_up (Tick _ e) = size_up e + size_up (Type _) = sizeZero -- Types cost nothing + size_up (Coercion _) = sizeZero + size_up (Lit lit) = sizeN (litSize lit) + size_up (Var f) | isRealWorldId f = sizeZero + -- Make sure we get constructor discounts even + -- on nullary constructors + | otherwise = size_up_call f [] 0 + + size_up (App fun arg) + | isTyCoArg arg = size_up fun + | otherwise = size_up arg `addSizeNSD` + size_up_app fun [arg] (if isRealWorldExpr arg then 1 else 0) + + size_up (Lam b e) + | isId b && not (isRealWorldId b) = lamScrutDiscount dflags (size_up e `addSizeN` 10) + | otherwise = size_up e + + size_up (Let (NonRec binder rhs) body) + = size_up_rhs (binder, rhs) `addSizeNSD` + size_up body `addSizeN` + size_up_alloc binder + + size_up (Let (Rec pairs) body) + = foldr (addSizeNSD . size_up_rhs) + (size_up body `addSizeN` sum (map (size_up_alloc . fst) pairs)) + pairs + + size_up (Case e _ _ alts) + | null alts + = size_up e -- case e of {} never returns, so take size of scrutinee + + size_up (Case e _ _ alts) + -- Now alts is non-empty + | Just v <- is_top_arg e -- We are scrutinising an argument variable + = let + alt_sizes = map size_up_alt alts + + -- alts_size tries to compute a good discount for + -- the case when we are scrutinising an argument variable + alts_size (SizeIs tot tot_disc tot_scrut) + -- Size of all alternatives + (SizeIs max _ _) + -- Size of biggest alternative + = SizeIs tot (unitBag (v, 20 + tot - max) + `unionBags` tot_disc) tot_scrut + -- If the variable is known, we produce a + -- discount that will take us back to 'max', + -- the size of the largest alternative The + -- 1+ is a little discount for reduced + -- allocation in the caller + -- + -- Notice though, that we return tot_disc, + -- the total discount from all branches. I + -- think that's right. + + alts_size tot_size _ = tot_size + in + alts_size (foldr1 addAltSize alt_sizes) -- alts is non-empty + (foldr1 maxSize alt_sizes) + -- Good to inline if an arg is scrutinised, because + -- that may eliminate allocation in the caller + -- And it eliminates the case itself + where + is_top_arg (Var v) | v `elem` top_args = Just v + is_top_arg (Cast e _) = is_top_arg e + is_top_arg _ = Nothing + + + size_up (Case e _ _ alts) = size_up e `addSizeNSD` + foldr (addAltSize . size_up_alt) case_size alts + where + case_size + | is_inline_scrut e, lengthAtMost alts 1 = sizeN (-10) + | otherwise = sizeZero + -- Normally we don't charge for the case itself, but + -- we charge one per alternative (see size_up_alt, + -- below) to account for the cost of the info table + -- and comparisons. + -- + -- However, in certain cases (see is_inline_scrut + -- below), no code is generated for the case unless + -- there are multiple alts. In these cases we + -- subtract one, making the first alt free. + -- e.g. case x# +# y# of _ -> ... should cost 1 + -- case touch# x# of _ -> ... should cost 0 + -- (see #4978) + -- + -- I would like to not have the "lengthAtMost alts 1" + -- condition above, but without that some programs got worse + -- (spectral/hartel/event and spectral/para). I don't fully + -- understand why. (SDM 24/5/11) + + -- unboxed variables, inline primops and unsafe foreign calls + -- are all "inline" things: + is_inline_scrut (Var v) = isUnliftedType (idType v) + is_inline_scrut scrut + | (Var f, _) <- collectArgs scrut + = case idDetails f of + FCallId fc -> not (isSafeForeignCall fc) + PrimOpId op -> not (primOpOutOfLine op) + _other -> False + | otherwise + = False + + size_up_rhs (bndr, rhs) + | Just join_arity <- isJoinId_maybe bndr + -- Skip arguments to join point + , (_bndrs, body) <- collectNBinders join_arity rhs + = size_up body + | otherwise + = size_up rhs + + ------------ + -- size_up_app is used when there's ONE OR MORE value args + size_up_app (App fun arg) args voids + | isTyCoArg arg = size_up_app fun args voids + | isRealWorldExpr arg = size_up_app fun (arg:args) (voids + 1) + | otherwise = size_up arg `addSizeNSD` + size_up_app fun (arg:args) voids + size_up_app (Var fun) args voids = size_up_call fun args voids + size_up_app (Tick _ expr) args voids = size_up_app expr args voids + size_up_app (Cast expr _) args voids = size_up_app expr args voids + size_up_app other args voids = size_up other `addSizeN` + callSize (length args) voids + -- if the lhs is not an App or a Var, or an invisible thing like a + -- Tick or Cast, then we should charge for a complete call plus the + -- size of the lhs itself. + + ------------ + size_up_call :: Id -> [CoreExpr] -> Int -> ExprSize + size_up_call fun val_args voids + = case idDetails fun of + FCallId _ -> sizeN (callSize (length val_args) voids) + DataConWorkId dc -> conSize dc (length val_args) + PrimOpId op -> primOpSize op (length val_args) + ClassOpId _ -> classOpSize dflags top_args val_args + _ -> funSize dflags top_args fun (length val_args) voids + + ------------ + size_up_alt (_con, _bndrs, rhs) = size_up rhs `addSizeN` 10 + -- Don't charge for args, so that wrappers look cheap + -- (See comments about wrappers with Case) + -- + -- IMPORTANT: *do* charge 1 for the alternative, else we + -- find that giant case nests are treated as practically free + -- A good example is Foreign.C.Error.errnoToIOError + + ------------ + -- Cost to allocate binding with given binder + size_up_alloc bndr + | isTyVar bndr -- Doesn't exist at runtime + || isJoinId bndr -- Not allocated at all + || isUnliftedType (idType bndr) -- Doesn't live in heap + = 0 + | otherwise + = 10 + + ------------ + -- These addSize things have to be here because + -- I don't want to give them bOMB_OUT_SIZE as an argument + addSizeN TooBig _ = TooBig + addSizeN (SizeIs n xs d) m = mkSizeIs bOMB_OUT_SIZE (n + m) xs d + + -- addAltSize is used to add the sizes of case alternatives + addAltSize TooBig _ = TooBig + addAltSize _ TooBig = TooBig + addAltSize (SizeIs n1 xs d1) (SizeIs n2 ys d2) + = mkSizeIs bOMB_OUT_SIZE (n1 + n2) + (xs `unionBags` ys) + (d1 + d2) -- Note [addAltSize result discounts] + + -- This variant ignores the result discount from its LEFT argument + -- It's used when the second argument isn't part of the result + addSizeNSD TooBig _ = TooBig + addSizeNSD _ TooBig = TooBig + addSizeNSD (SizeIs n1 xs _) (SizeIs n2 ys d2) + = mkSizeIs bOMB_OUT_SIZE (n1 + n2) + (xs `unionBags` ys) + d2 -- Ignore d1 + + isRealWorldId id = idType id `eqType` realWorldStatePrimTy + + -- an expression of type State# RealWorld must be a variable + isRealWorldExpr (Var id) = isRealWorldId id + isRealWorldExpr (Tick _ e) = isRealWorldExpr e + isRealWorldExpr _ = False + +-- | Finds a nominal size of a string literal. +litSize :: Literal -> Int +-- Used by CoreUnfold.sizeExpr +litSize (LitNumber LitNumInteger _ _) = 100 -- Note [Size of literal integers] +litSize (LitNumber LitNumNatural _ _) = 100 +litSize (LitString str) = 10 + 10 * ((BS.length str + 3) `div` 4) + -- If size could be 0 then @f "x"@ might be too small + -- [Sept03: make literal strings a bit bigger to avoid fruitless + -- duplication of little strings] +litSize _other = 0 -- Must match size of nullary constructors + -- Key point: if x |-> 4, then x must inline unconditionally + -- (eg via case binding) + +classOpSize :: DynFlags -> [Id] -> [CoreExpr] -> ExprSize +-- See Note [Conlike is interesting] +classOpSize _ _ [] + = sizeZero +classOpSize dflags top_args (arg1 : other_args) + = SizeIs size arg_discount 0 + where + size = 20 + (10 * length other_args) + -- If the class op is scrutinising a lambda bound dictionary then + -- give it a discount, to encourage the inlining of this function + -- The actual discount is rather arbitrarily chosen + arg_discount = case arg1 of + Var dict | dict `elem` top_args + -> unitBag (dict, ufDictDiscount dflags) + _other -> emptyBag + +-- | The size of a function call +callSize + :: Int -- ^ number of value args + -> Int -- ^ number of value args that are void + -> Int +callSize n_val_args voids = 10 * (1 + n_val_args - voids) + -- The 1+ is for the function itself + -- Add 1 for each non-trivial arg; + -- the allocation cost, as in let(rec) + +-- | The size of a jump to a join point +jumpSize + :: Int -- ^ number of value args + -> Int -- ^ number of value args that are void + -> Int +jumpSize n_val_args voids = 2 * (1 + n_val_args - voids) + -- A jump is 20% the size of a function call. Making jumps free reopens + -- bug #6048, but making them any more expensive loses a 21% improvement in + -- spectral/puzzle. TODO Perhaps adjusting the default threshold would be a + -- better solution? + +funSize :: DynFlags -> [Id] -> Id -> Int -> Int -> ExprSize +-- Size for functions that are not constructors or primops +-- Note [Function applications] +funSize dflags top_args fun n_val_args voids + | fun `hasKey` buildIdKey = buildSize + | fun `hasKey` augmentIdKey = augmentSize + | otherwise = SizeIs size arg_discount res_discount + where + some_val_args = n_val_args > 0 + is_join = isJoinId fun + + size | is_join = jumpSize n_val_args voids + | not some_val_args = 0 + | otherwise = callSize n_val_args voids + + -- DISCOUNTS + -- See Note [Function and non-function discounts] + arg_discount | some_val_args && fun `elem` top_args + = unitBag (fun, ufFunAppDiscount dflags) + | otherwise = emptyBag + -- If the function is an argument and is applied + -- to some values, give it an arg-discount + + res_discount | idArity fun > n_val_args = ufFunAppDiscount dflags + | otherwise = 0 + -- If the function is partially applied, show a result discount +-- XXX maybe behave like ConSize for eval'd variable + +conSize :: DataCon -> Int -> ExprSize +conSize dc n_val_args + | n_val_args == 0 = SizeIs 0 emptyBag 10 -- Like variables + +-- See Note [Unboxed tuple size and result discount] + | isUnboxedTupleCon dc = SizeIs 0 emptyBag (10 * (1 + n_val_args)) + +-- See Note [Constructor size and result discount] + | otherwise = SizeIs 10 emptyBag (10 * (1 + n_val_args)) + +-- XXX still looks to large to me + +{- +Note [Constructor size and result discount] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Treat a constructors application as size 10, regardless of how many +arguments it has; we are keen to expose them (and we charge separately +for their args). We can't treat them as size zero, else we find that +(Just x) has size 0, which is the same as a lone variable; and hence +'v' will always be replaced by (Just x), where v is bound to Just x. + +The "result discount" is applied if the result of the call is +scrutinised (say by a case). For a constructor application that will +mean the constructor application will disappear, so we don't need to +charge it to the function. So the discount should at least match the +cost of the constructor application, namely 10. But to give a bit +of extra incentive we give a discount of 10*(1 + n_val_args). + +Simon M tried a MUCH bigger discount: (10 * (10 + n_val_args)), +and said it was an "unambiguous win", but its terribly dangerous +because a function with many many case branches, each finishing with +a constructor, can have an arbitrarily large discount. This led to +terrible code bloat: see #6099. + +Note [Unboxed tuple size and result discount] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +However, unboxed tuples count as size zero. I found occasions where we had + f x y z = case op# x y z of { s -> (# s, () #) } +and f wasn't getting inlined. + +I tried giving unboxed tuples a *result discount* of zero (see the +commented-out line). Why? When returned as a result they do not +allocate, so maybe we don't want to charge so much for them If you +have a non-zero discount here, we find that workers often get inlined +back into wrappers, because it look like + f x = case $wf x of (# a,b #) -> (a,b) +and we are keener because of the case. However while this change +shrank binary sizes by 0.5% it also made spectral/boyer allocate 5% +more. All other changes were very small. So it's not a big deal but I +didn't adopt the idea. + +Note [Function and non-function discounts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want a discount if the function is applied. A good example is +monadic combinators with continuation arguments, where inlining is +quite important. + +But we don't want a big discount when a function is called many times +(see the detailed comments with #6048) because if the function is +big it won't be inlined at its many call sites and no benefit results. +Indeed, we can get exponentially big inlinings this way; that is what +#6048 is about. + +On the other hand, for data-valued arguments, if there are lots of +case expressions in the body, each one will get smaller if we apply +the function to a constructor application, so we *want* a big discount +if the argument is scrutinised by many case expressions. + +Conclusion: + - For functions, take the max of the discounts + - For data values, take the sum of the discounts + + +Note [Literal integer size] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Literal integers *can* be big (mkInteger [...coefficients...]), but +need not be (S# n). We just use an arbitrary big-ish constant here +so that, in particular, we don't inline top-level defns like + n = S# 5 +There's no point in doing so -- any optimisations will see the S# +through n's unfolding. Nor will a big size inhibit unfoldings functions +that mention a literal Integer, because the float-out pass will float +all those constants to top level. +-} + +primOpSize :: PrimOp -> Int -> ExprSize +primOpSize op n_val_args + = if primOpOutOfLine op + then sizeN (op_size + n_val_args) + else sizeN op_size + where + op_size = primOpCodeSize op + + +buildSize :: ExprSize +buildSize = SizeIs 0 emptyBag 40 + -- We really want to inline applications of build + -- build t (\cn -> e) should cost only the cost of e (because build will be inlined later) + -- Indeed, we should add a result_discount because build is + -- very like a constructor. We don't bother to check that the + -- build is saturated (it usually is). The "-2" discounts for the \c n, + -- The "4" is rather arbitrary. + +augmentSize :: ExprSize +augmentSize = SizeIs 0 emptyBag 40 + -- Ditto (augment t (\cn -> e) ys) should cost only the cost of + -- e plus ys. The -2 accounts for the \cn + +-- When we return a lambda, give a discount if it's used (applied) +lamScrutDiscount :: DynFlags -> ExprSize -> ExprSize +lamScrutDiscount dflags (SizeIs n vs _) = SizeIs n vs (ufFunAppDiscount dflags) +lamScrutDiscount _ TooBig = TooBig + +{- +Note [addAltSize result discounts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When adding the size of alternatives, we *add* the result discounts +too, rather than take the *maximum*. For a multi-branch case, this +gives a discount for each branch that returns a constructor, making us +keener to inline. I did try using 'max' instead, but it makes nofib +'rewrite' and 'puzzle' allocate significantly more, and didn't make +binary sizes shrink significantly either. + +Note [Discounts and thresholds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Constants for discounts and thesholds are defined in main/DynFlags, +all of form ufXxxx. They are: + +ufCreationThreshold + At a definition site, if the unfolding is bigger than this, we + may discard it altogether + +ufUseThreshold + At a call site, if the unfolding, less discounts, is smaller than + this, then it's small enough inline + +ufKeenessFactor + Factor by which the discounts are multiplied before + subtracting from size + +ufDictDiscount + The discount for each occurrence of a dictionary argument + as an argument of a class method. Should be pretty small + else big functions may get inlined + +ufFunAppDiscount + Discount for a function argument that is applied. Quite + large, because if we inline we avoid the higher-order call. + +ufDearOp + The size of a foreign call or not-dupable PrimOp + +ufVeryAggressive + If True, the compiler ignores all the thresholds and inlines very + aggressively. It still adheres to arity, simplifier phase control and + loop breakers. + + +Note [Function applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a function application (f a b) + + - If 'f' is an argument to the function being analysed, + and there's at least one value arg, record a FunAppDiscount for f + + - If the application if a PAP (arity > 2 in this example) + record a *result* discount (because inlining + with "extra" args in the call may mean that we now + get a saturated application) + +Code for manipulating sizes +-} + +-- | The size of a candidate expression for unfolding +data ExprSize + = TooBig + | SizeIs { _es_size_is :: {-# UNPACK #-} !Int -- ^ Size found + , _es_args :: !(Bag (Id,Int)) + -- ^ Arguments cased herein, and discount for each such + , _es_discount :: {-# UNPACK #-} !Int + -- ^ Size to subtract if result is scrutinised by a case + -- expression + } + +instance Outputable ExprSize where + ppr TooBig = text "TooBig" + ppr (SizeIs a _ c) = brackets (int a <+> int c) + +-- subtract the discount before deciding whether to bale out. eg. we +-- want to inline a large constructor application into a selector: +-- tup = (a_1, ..., a_99) +-- x = case tup of ... +-- +mkSizeIs :: Int -> Int -> Bag (Id, Int) -> Int -> ExprSize +mkSizeIs max n xs d | (n - d) > max = TooBig + | otherwise = SizeIs n xs d + +maxSize :: ExprSize -> ExprSize -> ExprSize +maxSize TooBig _ = TooBig +maxSize _ TooBig = TooBig +maxSize s1@(SizeIs n1 _ _) s2@(SizeIs n2 _ _) | n1 > n2 = s1 + | otherwise = s2 + +sizeZero :: ExprSize +sizeN :: Int -> ExprSize + +sizeZero = SizeIs 0 emptyBag 0 +sizeN n = SizeIs n emptyBag 0 + +{- +************************************************************************ +* * +\subsection[considerUnfolding]{Given all the info, do (not) do the unfolding} +* * +************************************************************************ + +We use 'couldBeSmallEnoughToInline' to avoid exporting inlinings that +we ``couldn't possibly use'' on the other side. Can be overridden w/ +flaggery. Just the same as smallEnoughToInline, except that it has no +actual arguments. +-} + +couldBeSmallEnoughToInline :: DynFlags -> Int -> CoreExpr -> Bool +couldBeSmallEnoughToInline dflags threshold rhs + = case sizeExpr dflags threshold [] body of + TooBig -> False + _ -> True + where + (_, body) = collectBinders rhs + +---------------- +smallEnoughToInline :: DynFlags -> Unfolding -> Bool +smallEnoughToInline dflags (CoreUnfolding {uf_guidance = UnfIfGoodArgs {ug_size = size}}) + = size <= ufUseThreshold dflags +smallEnoughToInline _ _ + = False + +---------------- + +certainlyWillInline :: DynFlags -> IdInfo -> Maybe Unfolding +-- ^ Sees if the unfolding is pretty certain to inline. +-- If so, return a *stable* unfolding for it, that will always inline. +certainlyWillInline dflags fn_info + = case unfoldingInfo fn_info of + CoreUnfolding { uf_tmpl = e, uf_guidance = g } + | loop_breaker -> Nothing -- Won't inline, so try w/w + | noinline -> Nothing -- See Note [Worker-wrapper for NOINLINE functions] + | otherwise -> do_cunf e g -- Depends on size, so look at that + + DFunUnfolding {} -> Just fn_unf -- Don't w/w DFuns; it never makes sense + -- to do so, and even if it is currently a + -- loop breaker, it may not be later + + _other_unf -> Nothing + + where + loop_breaker = isStrongLoopBreaker (occInfo fn_info) + noinline = inlinePragmaSpec (inlinePragInfo fn_info) == NoInline + fn_unf = unfoldingInfo fn_info + + do_cunf :: CoreExpr -> UnfoldingGuidance -> Maybe Unfolding + do_cunf _ UnfNever = Nothing + do_cunf _ (UnfWhen {}) = Just (fn_unf { uf_src = InlineStable }) + -- INLINE functions have UnfWhen + + -- The UnfIfGoodArgs case seems important. If we w/w small functions + -- binary sizes go up by 10%! (This is with SplitObjs.) + -- I'm not totally sure why. + -- INLINABLE functions come via this path + -- See Note [certainlyWillInline: INLINABLE] + do_cunf expr (UnfIfGoodArgs { ug_size = size, ug_args = args }) + | not (null args) -- See Note [certainlyWillInline: be careful of thunks] + , not (isBottomingSig (strictnessInfo fn_info)) + -- Do not unconditionally inline a bottoming functions even if + -- it seems smallish. We've carefully lifted it out to top level, + -- so we don't want to re-inline it. + , let arity = length args + , size - (10 * (arity + 1)) <= ufUseThreshold dflags + = Just (fn_unf { uf_src = InlineStable + , uf_guidance = UnfWhen { ug_arity = arity + , ug_unsat_ok = unSaturatedOk + , ug_boring_ok = inlineBoringOk expr } }) + -- Note the "unsaturatedOk". A function like f = \ab. a + -- will certainly inline, even if partially applied (f e), so we'd + -- better make sure that the transformed inlining has the same property + | otherwise + = Nothing + +{- Note [certainlyWillInline: be careful of thunks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Don't claim that thunks will certainly inline, because that risks work +duplication. Even if the work duplication is not great (eg is_cheap +holds), it can make a big difference in an inner loop In #5623 we +found that the WorkWrap phase thought that + y = case x of F# v -> F# (v +# v) +was certainlyWillInline, so the addition got duplicated. + +Note [certainlyWillInline: INLINABLE] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +certainlyWillInline /must/ return Nothing for a large INLINABLE thing, +even though we have a stable inlining, so that strictness w/w takes +place. It makes a big difference to efficiency, and the w/w pass knows +how to transfer the INLINABLE info to the worker; see WorkWrap +Note [Worker-wrapper for INLINABLE functions] + +************************************************************************ +* * +\subsection{callSiteInline} +* * +************************************************************************ + +This is the key function. It decides whether to inline a variable at a call site + +callSiteInline is used at call sites, so it is a bit more generous. +It's a very important function that embodies lots of heuristics. +A non-WHNF can be inlined if it doesn't occur inside a lambda, +and occurs exactly once or + occurs once in each branch of a case and is small + +If the thing is in WHNF, there's no danger of duplicating work, +so we can inline if it occurs once, or is small + +NOTE: we don't want to inline top-level functions that always diverge. +It just makes the code bigger. Tt turns out that the convenient way to prevent +them inlining is to give them a NOINLINE pragma, which we do in +StrictAnal.addStrictnessInfoToTopId +-} + +callSiteInline :: DynFlags + -> Id -- The Id + -> Bool -- True <=> unfolding is active + -> Bool -- True if there are no arguments at all (incl type args) + -> [ArgSummary] -- One for each value arg; True if it is interesting + -> CallCtxt -- True <=> continuation is interesting + -> Maybe CoreExpr -- Unfolding, if any + +data ArgSummary = TrivArg -- Nothing interesting + | NonTrivArg -- Arg has structure + | ValueArg -- Arg is a con-app or PAP + -- ..or con-like. Note [Conlike is interesting] + +instance Outputable ArgSummary where + ppr TrivArg = text "TrivArg" + ppr NonTrivArg = text "NonTrivArg" + ppr ValueArg = text "ValueArg" + +nonTriv :: ArgSummary -> Bool +nonTriv TrivArg = False +nonTriv _ = True + +data CallCtxt + = BoringCtxt + | RhsCtxt -- Rhs of a let-binding; see Note [RHS of lets] + | DiscArgCtxt -- Argument of a function with non-zero arg discount + | RuleArgCtxt -- We are somewhere in the argument of a function with rules + + | ValAppCtxt -- We're applied to at least one value arg + -- This arises when we have ((f x |> co) y) + -- Then the (f x) has argument 'x' but in a ValAppCtxt + + | CaseCtxt -- We're the scrutinee of a case + -- that decomposes its scrutinee + +instance Outputable CallCtxt where + ppr CaseCtxt = text "CaseCtxt" + ppr ValAppCtxt = text "ValAppCtxt" + ppr BoringCtxt = text "BoringCtxt" + ppr RhsCtxt = text "RhsCtxt" + ppr DiscArgCtxt = text "DiscArgCtxt" + ppr RuleArgCtxt = text "RuleArgCtxt" + +callSiteInline dflags id active_unfolding lone_variable arg_infos cont_info + = case idUnfolding id of + -- idUnfolding checks for loop-breakers, returning NoUnfolding + -- Things with an INLINE pragma may have an unfolding *and* + -- be a loop breaker (maybe the knot is not yet untied) + CoreUnfolding { uf_tmpl = unf_template + , uf_is_work_free = is_wf + , uf_guidance = guidance, uf_expandable = is_exp } + | active_unfolding -> tryUnfolding dflags id lone_variable + arg_infos cont_info unf_template + is_wf is_exp guidance + | otherwise -> traceInline dflags id "Inactive unfolding:" (ppr id) Nothing + NoUnfolding -> Nothing + BootUnfolding -> Nothing + OtherCon {} -> Nothing + DFunUnfolding {} -> Nothing -- Never unfold a DFun + +traceInline :: DynFlags -> Id -> String -> SDoc -> a -> a +traceInline dflags inline_id str doc result + | Just prefix <- inlineCheck dflags + = if prefix `isPrefixOf` occNameString (getOccName inline_id) + then pprTrace str doc result + else result + | dopt Opt_D_dump_inlinings dflags && dopt Opt_D_verbose_core2core dflags + = pprTrace str doc result + | otherwise + = result + +tryUnfolding :: DynFlags -> Id -> Bool -> [ArgSummary] -> CallCtxt + -> CoreExpr -> Bool -> Bool -> UnfoldingGuidance + -> Maybe CoreExpr +tryUnfolding dflags id lone_variable + arg_infos cont_info unf_template + is_wf is_exp guidance + = case guidance of + UnfNever -> traceInline dflags id str (text "UnfNever") Nothing + + UnfWhen { ug_arity = uf_arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok } + | enough_args && (boring_ok || some_benefit || ufVeryAggressive dflags) + -- See Note [INLINE for small functions (3)] + -> traceInline dflags id str (mk_doc some_benefit empty True) (Just unf_template) + | otherwise + -> traceInline dflags id str (mk_doc some_benefit empty False) Nothing + where + some_benefit = calc_some_benefit uf_arity + enough_args = (n_val_args >= uf_arity) || (unsat_ok && n_val_args > 0) + + UnfIfGoodArgs { ug_args = arg_discounts, ug_res = res_discount, ug_size = size } + | ufVeryAggressive dflags + -> traceInline dflags id str (mk_doc some_benefit extra_doc True) (Just unf_template) + | is_wf && some_benefit && small_enough + -> traceInline dflags id str (mk_doc some_benefit extra_doc True) (Just unf_template) + | otherwise + -> traceInline dflags id str (mk_doc some_benefit extra_doc False) Nothing + where + some_benefit = calc_some_benefit (length arg_discounts) + extra_doc = text "discounted size =" <+> int discounted_size + discounted_size = size - discount + small_enough = discounted_size <= ufUseThreshold dflags + discount = computeDiscount dflags arg_discounts + res_discount arg_infos cont_info + + where + mk_doc some_benefit extra_doc yes_or_no + = vcat [ text "arg infos" <+> ppr arg_infos + , text "interesting continuation" <+> ppr cont_info + , text "some_benefit" <+> ppr some_benefit + , text "is exp:" <+> ppr is_exp + , text "is work-free:" <+> ppr is_wf + , text "guidance" <+> ppr guidance + , extra_doc + , text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"] + + str = "Considering inlining: " ++ showSDocDump dflags (ppr id) + n_val_args = length arg_infos + + -- some_benefit is used when the RHS is small enough + -- and the call has enough (or too many) value + -- arguments (ie n_val_args >= arity). But there must + -- be *something* interesting about some argument, or the + -- result context, to make it worth inlining + calc_some_benefit :: Arity -> Bool -- The Arity is the number of args + -- expected by the unfolding + calc_some_benefit uf_arity + | not saturated = interesting_args -- Under-saturated + -- Note [Unsaturated applications] + | otherwise = interesting_args -- Saturated or over-saturated + || interesting_call + where + saturated = n_val_args >= uf_arity + over_saturated = n_val_args > uf_arity + interesting_args = any nonTriv arg_infos + -- NB: (any nonTriv arg_infos) looks at the + -- over-saturated args too which is "wrong"; + -- but if over-saturated we inline anyway. + + interesting_call + | over_saturated + = True + | otherwise + = case cont_info of + CaseCtxt -> not (lone_variable && is_exp) -- Note [Lone variables] + ValAppCtxt -> True -- Note [Cast then apply] + RuleArgCtxt -> uf_arity > 0 -- See Note [Unfold info lazy contexts] + DiscArgCtxt -> uf_arity > 0 -- Note [Inlining in ArgCtxt] + RhsCtxt -> uf_arity > 0 -- + _other -> False -- See Note [Nested functions] + + +{- +Note [Unfold into lazy contexts], Note [RHS of lets] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When the call is the argument of a function with a RULE, or the RHS of a let, +we are a little bit keener to inline. For example + f y = (y,y,y) + g y = let x = f y in ...(case x of (a,b,c) -> ...) ... +We'd inline 'f' if the call was in a case context, and it kind-of-is, +only we can't see it. Also + x = f v +could be expensive whereas + x = case v of (a,b) -> a +is patently cheap and may allow more eta expansion. +So we treat the RHS of a let as not-totally-boring. + +Note [Unsaturated applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When a call is not saturated, we *still* inline if one of the +arguments has interesting structure. That's sometimes very important. +A good example is the Ord instance for Bool in Base: + + Rec { + $fOrdBool =GHC.Classes.D:Ord + @ Bool + ... + $cmin_ajX + + $cmin_ajX [Occ=LoopBreaker] :: Bool -> Bool -> Bool + $cmin_ajX = GHC.Classes.$dmmin @ Bool $fOrdBool + } + +But the defn of GHC.Classes.$dmmin is: + + $dmmin :: forall a. GHC.Classes.Ord a => a -> a -> a + {- Arity: 3, HasNoCafRefs, Strictness: SLL, + Unfolding: (\ @ a $dOrd :: GHC.Classes.Ord a x :: a y :: a -> + case @ a GHC.Classes.<= @ a $dOrd x y of wild { + GHC.Types.False -> y GHC.Types.True -> x }) -} + +We *really* want to inline $dmmin, even though it has arity 3, in +order to unravel the recursion. + + +Note [Things to watch] +~~~~~~~~~~~~~~~~~~~~~~ +* { y = I# 3; x = y `cast` co; ...case (x `cast` co) of ... } + Assume x is exported, so not inlined unconditionally. + Then we want x to inline unconditionally; no reason for it + not to, and doing so avoids an indirection. + +* { x = I# 3; ....f x.... } + Make sure that x does not inline unconditionally! + Lest we get extra allocation. + +Note [Inlining an InlineRule] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An InlineRules is used for + (a) programmer INLINE pragmas + (b) inlinings from worker/wrapper + +For (a) the RHS may be large, and our contract is that we *only* inline +when the function is applied to all the arguments on the LHS of the +source-code defn. (The uf_arity in the rule.) + +However for worker/wrapper it may be worth inlining even if the +arity is not satisfied (as we do in the CoreUnfolding case) so we don't +require saturation. + +Note [Nested functions] +~~~~~~~~~~~~~~~~~~~~~~~ +At one time we treated a call of a non-top-level function as +"interesting" (regardless of how boring the context) in the hope +that inlining it would eliminate the binding, and its allocation. +Specifically, in the default case of interesting_call we had + _other -> not is_top && uf_arity > 0 + +But actually postInlineUnconditionally does some of this and overall +it makes virtually no difference to nofib. So I simplified away this +special case + +Note [Cast then apply] +~~~~~~~~~~~~~~~~~~~~~~ +Consider + myIndex = __inline_me ( (/\a. ) |> co ) + co :: (forall a. a -> a) ~ (forall a. T a) + ... /\a.\x. case ((myIndex a) |> sym co) x of { ... } ... + +We need to inline myIndex to unravel this; but the actual call (myIndex a) has +no value arguments. The ValAppCtxt gives it enough incentive to inline. + +Note [Inlining in ArgCtxt] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +The condition (arity > 0) here is very important, because otherwise +we end up inlining top-level stuff into useless places; eg + x = I# 3# + f = \y. g x +This can make a very big difference: it adds 16% to nofib 'integer' allocs, +and 20% to 'power'. + +At one stage I replaced this condition by 'True' (leading to the above +slow-down). The motivation was test eyeball/inline1.hs; but that seems +to work ok now. + +NOTE: arguably, we should inline in ArgCtxt only if the result of the +call is at least CONLIKE. At least for the cases where we use ArgCtxt +for the RHS of a 'let', we only profit from the inlining if we get a +CONLIKE thing (modulo lets). + +Note [Lone variables] See also Note [Interaction of exprIsWorkFree and lone variables] +~~~~~~~~~~~~~~~~~~~~~ which appears below +The "lone-variable" case is important. I spent ages messing about +with unsatisfactory variants, but this is nice. The idea is that if a +variable appears all alone + + as an arg of lazy fn, or rhs BoringCtxt + as scrutinee of a case CaseCtxt + as arg of a fn ArgCtxt +AND + it is bound to a cheap expression + +then we should not inline it (unless there is some other reason, +e.g. it is the sole occurrence). That is what is happening at +the use of 'lone_variable' in 'interesting_call'. + +Why? At least in the case-scrutinee situation, turning + let x = (a,b) in case x of y -> ... +into + let x = (a,b) in case (a,b) of y -> ... +and thence to + let x = (a,b) in let y = (a,b) in ... +is bad if the binding for x will remain. + +Another example: I discovered that strings +were getting inlined straight back into applications of 'error' +because the latter is strict. + s = "foo" + f = \x -> ...(error s)... + +Fundamentally such contexts should not encourage inlining because, provided +the RHS is "expandable" (see Note [exprIsExpandable] in CoreUtils) the +context can ``see'' the unfolding of the variable (e.g. case or a +RULE) so there's no gain. + +However, watch out: + + * Consider this: + foo = _inline_ (\n. [n]) + bar = _inline_ (foo 20) + baz = \n. case bar of { (m:_) -> m + n } + Here we really want to inline 'bar' so that we can inline 'foo' + and the whole thing unravels as it should obviously do. This is + important: in the NDP project, 'bar' generates a closure data + structure rather than a list. + + So the non-inlining of lone_variables should only apply if the + unfolding is regarded as cheap; because that is when exprIsConApp_maybe + looks through the unfolding. Hence the "&& is_wf" in the + InlineRule branch. + + * Even a type application or coercion isn't a lone variable. + Consider + case $fMonadST @ RealWorld of { :DMonad a b c -> c } + We had better inline that sucker! The case won't see through it. + + For now, I'm treating treating a variable applied to types + in a *lazy* context "lone". The motivating example was + f = /\a. \x. BIG + g = /\a. \y. h (f a) + There's no advantage in inlining f here, and perhaps + a significant disadvantage. Hence some_val_args in the Stop case + +Note [Interaction of exprIsWorkFree and lone variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The lone-variable test says "don't inline if a case expression +scrutinises a lone variable whose unfolding is cheap". It's very +important that, under these circumstances, exprIsConApp_maybe +can spot a constructor application. So, for example, we don't +consider + let x = e in (x,x) +to be cheap, and that's good because exprIsConApp_maybe doesn't +think that expression is a constructor application. + +In the 'not (lone_variable && is_wf)' test, I used to test is_value +rather than is_wf, which was utterly wrong, because the above +expression responds True to exprIsHNF, which is what sets is_value. + +This kind of thing can occur if you have + + {-# INLINE foo #-} + foo = let x = e in (x,x) + +which Roman did. + + +-} + +computeDiscount :: DynFlags -> [Int] -> Int -> [ArgSummary] -> CallCtxt + -> Int +computeDiscount dflags arg_discounts res_discount arg_infos cont_info + -- We multiple the raw discounts (args_discount and result_discount) + -- ty opt_UnfoldingKeenessFactor because the former have to do with + -- *size* whereas the discounts imply that there's some extra + -- *efficiency* to be gained (e.g. beta reductions, case reductions) + -- by inlining. + + = 10 -- Discount of 10 because the result replaces the call + -- so we count 10 for the function itself + + + 10 * length actual_arg_discounts + -- Discount of 10 for each arg supplied, + -- because the result replaces the call + + + round (ufKeenessFactor dflags * + fromIntegral (total_arg_discount + res_discount')) + where + actual_arg_discounts = zipWith mk_arg_discount arg_discounts arg_infos + total_arg_discount = sum actual_arg_discounts + + mk_arg_discount _ TrivArg = 0 + mk_arg_discount _ NonTrivArg = 10 + mk_arg_discount discount ValueArg = discount + + res_discount' + | LT <- arg_discounts `compareLength` arg_infos + = res_discount -- Over-saturated + | otherwise + = case cont_info of + BoringCtxt -> 0 + CaseCtxt -> res_discount -- Presumably a constructor + ValAppCtxt -> res_discount -- Presumably a function + _ -> 40 `min` res_discount + -- ToDo: this 40 `min` res_discount doesn't seem right + -- for DiscArgCtxt it shouldn't matter because the function will + -- get the arg discount for any non-triv arg + -- for RuleArgCtxt we do want to be keener to inline; but not only + -- constructor results + -- for RhsCtxt I suppose that exposing a data con is good in general + -- And 40 seems very arbitrary + -- + -- res_discount can be very large when a function returns + -- constructors; but we only want to invoke that large discount + -- when there's a case continuation. + -- Otherwise we, rather arbitrarily, threshold it. Yuk. + -- But we want to aovid inlining large functions that return + -- constructors into contexts that are simply "interesting" diff --git a/compiler/coreSyn/CoreUtils.hs b/compiler/coreSyn/CoreUtils.hs new file mode 100644 --- /dev/null +++ b/compiler/coreSyn/CoreUtils.hs @@ -0,0 +1,2633 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Utility functions on @Core@ syntax +-} + +{-# LANGUAGE CPP #-} + +-- | Commonly useful utilites for manipulating the Core language +module CoreUtils ( + -- * Constructing expressions + mkCast, + mkTick, mkTicks, mkTickNoHNF, tickHNFArgs, + bindNonRec, needsCaseBinding, + mkAltExpr, + + -- * Taking expressions apart + findDefault, addDefault, findAlt, isDefaultAlt, + mergeAlts, trimConArgs, + filterAlts, combineIdenticalAlts, refineDefaultAlt, + + -- * Properties of expressions + exprType, coreAltType, coreAltsType, isExprLevPoly, + exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, exprIsBottom, + getIdFromTrivialExpr_maybe, + exprIsCheap, exprIsExpandable, exprIsCheapX, CheapAppFun, + exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprIsWorkFree, + exprIsBig, exprIsConLike, + rhsIsStatic, isCheapApp, isExpandableApp, + exprIsTickedString, exprIsTickedString_maybe, + exprIsTopLevelBindable, + altsAreExhaustive, + + -- * Equality + cheapEqExpr, cheapEqExpr', eqExpr, + diffExpr, diffBinds, + + -- * Eta reduction + tryEtaReduce, + + -- * Manipulating data constructors and types + exprToType, exprToCoercion_maybe, + applyTypeToArgs, applyTypeToArg, + dataConRepInstPat, dataConRepFSInstPat, + isEmptyTy, + + -- * Working with ticks + stripTicksTop, stripTicksTopE, stripTicksTopT, + stripTicksE, stripTicksT, + + -- * StaticPtr + collectMakeStaticArgs, + + -- * Join points + isJoinBind + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import CoreSyn +import PrelNames ( makeStaticName ) +import PprCore +import CoreFVs( exprFreeVars ) +import Var +import SrcLoc +import VarEnv +import VarSet +import Name +import Literal +import DataCon +import PrimOp +import Id +import IdInfo +import PrelNames( absentErrorIdKey ) +import Type +import TyCoRep( TyCoBinder(..), TyBinder ) +import Coercion +import TyCon +import Unique +import Outputable +import TysPrim +import DynFlags +import FastString +import Maybes +import ListSetOps ( minusList ) +import BasicTypes ( Arity, isConLike ) +import Platform +import Util +import Pair +import Data.ByteString ( ByteString ) +import Data.Function ( on ) +import Data.List +import Data.Ord ( comparing ) +import OrdList +import qualified Data.Set as Set +import UniqSet + +{- +************************************************************************ +* * +\subsection{Find the type of a Core atom/expression} +* * +************************************************************************ +-} + +exprType :: CoreExpr -> Type +-- ^ Recover the type of a well-typed Core expression. Fails when +-- applied to the actual 'CoreSyn.Type' expression as it cannot +-- really be said to have a type +exprType (Var var) = idType var +exprType (Lit lit) = literalType lit +exprType (Coercion co) = coercionType co +exprType (Let bind body) + | NonRec tv rhs <- bind -- See Note [Type bindings] + , Type ty <- rhs = substTyWithUnchecked [tv] [ty] (exprType body) + | otherwise = exprType body +exprType (Case _ _ ty _) = ty +exprType (Cast _ co) = pSnd (coercionKind co) +exprType (Tick _ e) = exprType e +exprType (Lam binder expr) = mkLamType binder (exprType expr) +exprType e@(App _ _) + = case collectArgs e of + (fun, args) -> applyTypeToArgs e (exprType fun) args + +exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy + +coreAltType :: CoreAlt -> Type +-- ^ Returns the type of the alternatives right hand side +coreAltType alt@(_,bs,rhs) + = case occCheckExpand bs rhs_ty of + -- Note [Existential variables and silly type synonyms] + Just ty -> ty + Nothing -> pprPanic "coreAltType" (pprCoreAlt alt $$ ppr rhs_ty) + where + rhs_ty = exprType rhs + +coreAltsType :: [CoreAlt] -> Type +-- ^ Returns the type of the first alternative, which should be the same as for all alternatives +coreAltsType (alt:_) = coreAltType alt +coreAltsType [] = panic "corAltsType" + +-- | Is this expression levity polymorphic? This should be the +-- same as saying (isKindLevPoly . typeKind . exprType) but +-- much faster. +isExprLevPoly :: CoreExpr -> Bool +isExprLevPoly = go + where + go (Var _) = False -- no levity-polymorphic binders + go (Lit _) = False -- no levity-polymorphic literals + go e@(App f _) | not (go_app f) = False + | otherwise = check_type e + go (Lam _ _) = False + go (Let _ e) = go e + go e@(Case {}) = check_type e -- checking type is fast + go e@(Cast {}) = check_type e + go (Tick _ e) = go e + go e@(Type {}) = pprPanic "isExprLevPoly ty" (ppr e) + go (Coercion {}) = False -- this case can happen in SetLevels + + check_type = isTypeLevPoly . exprType -- slow approach + + -- if the function is a variable (common case), check its + -- levityInfo. This might mean we don't need to look up and compute + -- on the type. Spec of these functions: return False if there is + -- no possibility, ever, of this expression becoming levity polymorphic, + -- no matter what it's applied to; return True otherwise. + -- returning True is always safe. See also Note [Levity info] in + -- IdInfo + go_app (Var id) = not (isNeverLevPolyId id) + go_app (Lit _) = False + go_app (App f _) = go_app f + go_app (Lam _ e) = go_app e + go_app (Let _ e) = go_app e + go_app (Case _ _ ty _) = resultIsLevPoly ty + go_app (Cast _ co) = resultIsLevPoly (pSnd $ coercionKind co) + go_app (Tick _ e) = go_app e + go_app e@(Type {}) = pprPanic "isExprLevPoly app ty" (ppr e) + go_app e@(Coercion {}) = pprPanic "isExprLevPoly app co" (ppr e) + + +{- +Note [Type bindings] +~~~~~~~~~~~~~~~~~~~~ +Core does allow type bindings, although such bindings are +not much used, except in the output of the desugarer. +Example: + let a = Int in (\x:a. x) +Given this, exprType must be careful to substitute 'a' in the +result type (#8522). + +Note [Existential variables and silly type synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T = forall a. T (Funny a) + type Funny a = Bool + f :: T -> Bool + f (T x) = x + +Now, the type of 'x' is (Funny a), where 'a' is existentially quantified. +That means that 'exprType' and 'coreAltsType' may give a result that *appears* +to mention an out-of-scope type variable. See #3409 for a more real-world +example. + +Various possibilities suggest themselves: + + - Ignore the problem, and make Lint not complain about such variables + + - Expand all type synonyms (or at least all those that discard arguments) + This is tricky, because at least for top-level things we want to + retain the type the user originally specified. + + - Expand synonyms on the fly, when the problem arises. That is what + we are doing here. It's not too expensive, I think. + +Note that there might be existentially quantified coercion variables, too. +-} + +-- Not defined with applyTypeToArg because you can't print from CoreSyn. +applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type +-- ^ A more efficient version of 'applyTypeToArg' when we have several arguments. +-- The first argument is just for debugging, and gives some context +applyTypeToArgs e op_ty args + = go op_ty args + where + go op_ty [] = op_ty + go op_ty (Type ty : args) = go_ty_args op_ty [ty] args + go op_ty (Coercion co : args) = go_ty_args op_ty [mkCoercionTy co] args + go op_ty (_ : args) | Just (_, res_ty) <- splitFunTy_maybe op_ty + = go res_ty args + go _ _ = pprPanic "applyTypeToArgs" panic_msg + + -- go_ty_args: accumulate type arguments so we can + -- instantiate all at once with piResultTys + go_ty_args op_ty rev_tys (Type ty : args) + = go_ty_args op_ty (ty:rev_tys) args + go_ty_args op_ty rev_tys (Coercion co : args) + = go_ty_args op_ty (mkCoercionTy co : rev_tys) args + go_ty_args op_ty rev_tys args + = go (piResultTys op_ty (reverse rev_tys)) args + + panic_msg = vcat [ text "Expression:" <+> pprCoreExpr e + , text "Type:" <+> ppr op_ty + , text "Args:" <+> ppr args ] + + +{- +************************************************************************ +* * +\subsection{Attaching notes} +* * +************************************************************************ +-} + +-- | Wrap the given expression in the coercion safely, dropping +-- identity coercions and coalescing nested coercions +mkCast :: CoreExpr -> CoercionR -> CoreExpr +mkCast e co + | ASSERT2( coercionRole co == Representational + , text "coercion" <+> ppr co <+> ptext (sLit "passed to mkCast") + <+> ppr e <+> text "has wrong role" <+> ppr (coercionRole co) ) + isReflCo co + = e + +mkCast (Coercion e_co) co + | isCoVarType (pSnd (coercionKind co)) + -- The guard here checks that g has a (~#) on both sides, + -- otherwise decomposeCo fails. Can in principle happen + -- with unsafeCoerce + = Coercion (mkCoCast e_co co) + +mkCast (Cast expr co2) co + = WARN(let { Pair from_ty _to_ty = coercionKind co; + Pair _from_ty2 to_ty2 = coercionKind co2} in + not (from_ty `eqType` to_ty2), + vcat ([ text "expr:" <+> ppr expr + , text "co2:" <+> ppr co2 + , text "co:" <+> ppr co ]) ) + mkCast expr (mkTransCo co2 co) + +mkCast (Tick t expr) co + = Tick t (mkCast expr co) + +mkCast expr co + = let Pair from_ty _to_ty = coercionKind co in + WARN( not (from_ty `eqType` exprType expr), + text "Trying to coerce" <+> text "(" <> ppr expr + $$ text "::" <+> ppr (exprType expr) <> text ")" + $$ ppr co $$ ppr (coercionType co) ) + (Cast expr co) + +-- | Wraps the given expression in the source annotation, dropping the +-- annotation if possible. +mkTick :: Tickish Id -> CoreExpr -> CoreExpr +mkTick t orig_expr = mkTick' id id orig_expr + where + -- Some ticks (cost-centres) can be split in two, with the + -- non-counting part having laxer placement properties. + canSplit = tickishCanSplit t && tickishPlace (mkNoCount t) /= tickishPlace t + + mkTick' :: (CoreExpr -> CoreExpr) -- ^ apply after adding tick (float through) + -> (CoreExpr -> CoreExpr) -- ^ apply before adding tick (float with) + -> CoreExpr -- ^ current expression + -> CoreExpr + mkTick' top rest expr = case expr of + + -- Cost centre ticks should never be reordered relative to each + -- other. Therefore we can stop whenever two collide. + Tick t2 e + | ProfNote{} <- t2, ProfNote{} <- t -> top $ Tick t $ rest expr + + -- Otherwise we assume that ticks of different placements float + -- through each other. + | tickishPlace t2 /= tickishPlace t -> mkTick' (top . Tick t2) rest e + + -- For annotations this is where we make sure to not introduce + -- redundant ticks. + | tickishContains t t2 -> mkTick' top rest e + | tickishContains t2 t -> orig_expr + | otherwise -> mkTick' top (rest . Tick t2) e + + -- Ticks don't care about types, so we just float all ticks + -- through them. Note that it's not enough to check for these + -- cases top-level. While mkTick will never produce Core with type + -- expressions below ticks, such constructs can be the result of + -- unfoldings. We therefore make an effort to put everything into + -- the right place no matter what we start with. + Cast e co -> mkTick' (top . flip Cast co) rest e + Coercion co -> Coercion co + + Lam x e + -- Always float through type lambdas. Even for non-type lambdas, + -- floating is allowed for all but the most strict placement rule. + | not (isRuntimeVar x) || tickishPlace t /= PlaceRuntime + -> mkTick' (top . Lam x) rest e + + -- If it is both counting and scoped, we split the tick into its + -- two components, often allowing us to keep the counting tick on + -- the outside of the lambda and push the scoped tick inside. + -- The point of this is that the counting tick can probably be + -- floated, and the lambda may then be in a position to be + -- beta-reduced. + | canSplit + -> top $ Tick (mkNoScope t) $ rest $ Lam x $ mkTick (mkNoCount t) e + + App f arg + -- Always float through type applications. + | not (isRuntimeArg arg) + -> mkTick' (top . flip App arg) rest f + + -- We can also float through constructor applications, placement + -- permitting. Again we can split. + | isSaturatedConApp expr && (tickishPlace t==PlaceCostCentre || canSplit) + -> if tickishPlace t == PlaceCostCentre + then top $ rest $ tickHNFArgs t expr + else top $ Tick (mkNoScope t) $ rest $ tickHNFArgs (mkNoCount t) expr + + Var x + | notFunction && tickishPlace t == PlaceCostCentre + -> orig_expr + | notFunction && canSplit + -> top $ Tick (mkNoScope t) $ rest expr + where + -- SCCs can be eliminated on variables provided the variable + -- is not a function. In these cases the SCC makes no difference: + -- the cost of evaluating the variable will be attributed to its + -- definition site. When the variable refers to a function, however, + -- an SCC annotation on the variable affects the cost-centre stack + -- when the function is called, so we must retain those. + notFunction = not (isFunTy (idType x)) + + Lit{} + | tickishPlace t == PlaceCostCentre + -> orig_expr + + -- Catch-all: Annotate where we stand + _any -> top $ Tick t $ rest expr + +mkTicks :: [Tickish Id] -> CoreExpr -> CoreExpr +mkTicks ticks expr = foldr mkTick expr ticks + +isSaturatedConApp :: CoreExpr -> Bool +isSaturatedConApp e = go e [] + where go (App f a) as = go f (a:as) + go (Var fun) args + = isConLikeId fun && idArity fun == valArgCount args + go (Cast f _) as = go f as + go _ _ = False + +mkTickNoHNF :: Tickish Id -> CoreExpr -> CoreExpr +mkTickNoHNF t e + | exprIsHNF e = tickHNFArgs t e + | otherwise = mkTick t e + +-- push a tick into the arguments of a HNF (call or constructor app) +tickHNFArgs :: Tickish Id -> CoreExpr -> CoreExpr +tickHNFArgs t e = push t e + where + push t (App f (Type u)) = App (push t f) (Type u) + push t (App f arg) = App (push t f) (mkTick t arg) + push _t e = e + +-- | Strip ticks satisfying a predicate from top of an expression +stripTicksTop :: (Tickish Id -> Bool) -> Expr b -> ([Tickish Id], Expr b) +stripTicksTop p = go [] + where go ts (Tick t e) | p t = go (t:ts) e + go ts other = (reverse ts, other) + +-- | Strip ticks satisfying a predicate from top of an expression, +-- returning the remaining expression +stripTicksTopE :: (Tickish Id -> Bool) -> Expr b -> Expr b +stripTicksTopE p = go + where go (Tick t e) | p t = go e + go other = other + +-- | Strip ticks satisfying a predicate from top of an expression, +-- returning the ticks +stripTicksTopT :: (Tickish Id -> Bool) -> Expr b -> [Tickish Id] +stripTicksTopT p = go [] + where go ts (Tick t e) | p t = go (t:ts) e + go ts _ = ts + +-- | Completely strip ticks satisfying a predicate from an +-- expression. Note this is O(n) in the size of the expression! +stripTicksE :: (Tickish Id -> Bool) -> Expr b -> Expr b +stripTicksE p expr = go expr + where go (App e a) = App (go e) (go a) + go (Lam b e) = Lam b (go e) + go (Let b e) = Let (go_bs b) (go e) + go (Case e b t as) = Case (go e) b t (map go_a as) + go (Cast e c) = Cast (go e) c + go (Tick t e) + | p t = go e + | otherwise = Tick t (go e) + go other = other + go_bs (NonRec b e) = NonRec b (go e) + go_bs (Rec bs) = Rec (map go_b bs) + go_b (b, e) = (b, go e) + go_a (c,bs,e) = (c,bs, go e) + +stripTicksT :: (Tickish Id -> Bool) -> Expr b -> [Tickish Id] +stripTicksT p expr = fromOL $ go expr + where go (App e a) = go e `appOL` go a + go (Lam _ e) = go e + go (Let b e) = go_bs b `appOL` go e + go (Case e _ _ as) = go e `appOL` concatOL (map go_a as) + go (Cast e _) = go e + go (Tick t e) + | p t = t `consOL` go e + | otherwise = go e + go _ = nilOL + go_bs (NonRec _ e) = go e + go_bs (Rec bs) = concatOL (map go_b bs) + go_b (_, e) = go e + go_a (_, _, e) = go e + +{- +************************************************************************ +* * +\subsection{Other expression construction} +* * +************************************************************************ +-} + +bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr +-- ^ @bindNonRec x r b@ produces either: +-- +-- > let x = r in b +-- +-- or: +-- +-- > case r of x { _DEFAULT_ -> b } +-- +-- depending on whether we have to use a @case@ or @let@ +-- binding for the expression (see 'needsCaseBinding'). +-- It's used by the desugarer to avoid building bindings +-- that give Core Lint a heart attack, although actually +-- the simplifier deals with them perfectly well. See +-- also 'MkCore.mkCoreLet' +bindNonRec bndr rhs body + | isTyVar bndr = let_bind + | isCoVar bndr = if isCoArg rhs then let_bind + {- See Note [Binding coercions] -} else case_bind + | isJoinId bndr = let_bind + | needsCaseBinding (idType bndr) rhs = case_bind + | otherwise = let_bind + where + case_bind = Case rhs bndr (exprType body) [(DEFAULT, [], body)] + let_bind = Let (NonRec bndr rhs) body + +-- | Tests whether we have to use a @case@ rather than @let@ binding for this expression +-- as per the invariants of 'CoreExpr': see "CoreSyn#let_app_invariant" +needsCaseBinding :: Type -> CoreExpr -> Bool +needsCaseBinding ty rhs = isUnliftedType ty && not (exprOkForSpeculation rhs) + -- Make a case expression instead of a let + -- These can arise either from the desugarer, + -- or from beta reductions: (\x.e) (x +# y) + +mkAltExpr :: AltCon -- ^ Case alternative constructor + -> [CoreBndr] -- ^ Things bound by the pattern match + -> [Type] -- ^ The type arguments to the case alternative + -> CoreExpr +-- ^ This guy constructs the value that the scrutinee must have +-- given that you are in one particular branch of a case +mkAltExpr (DataAlt con) args inst_tys + = mkConApp con (map Type inst_tys ++ varsToCoreExprs args) +mkAltExpr (LitAlt lit) [] [] + = Lit lit +mkAltExpr (LitAlt _) _ _ = panic "mkAltExpr LitAlt" +mkAltExpr DEFAULT _ _ = panic "mkAltExpr DEFAULT" + +{- Note [Binding coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider binding a CoVar, c = e. Then, we must atisfy +Note [CoreSyn type and coercion invariant] in CoreSyn, +which allows only (Coercion co) on the RHS. + +************************************************************************ +* * + Operations oer case alternatives +* * +************************************************************************ + +The default alternative must be first, if it exists at all. +This makes it easy to find, though it makes matching marginally harder. +-} + +-- | Extract the default case alternative +findDefault :: [(AltCon, [a], b)] -> ([(AltCon, [a], b)], Maybe b) +findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs) +findDefault alts = (alts, Nothing) + +addDefault :: [(AltCon, [a], b)] -> Maybe b -> [(AltCon, [a], b)] +addDefault alts Nothing = alts +addDefault alts (Just rhs) = (DEFAULT, [], rhs) : alts + +isDefaultAlt :: (AltCon, a, b) -> Bool +isDefaultAlt (DEFAULT, _, _) = True +isDefaultAlt _ = False + +-- | Find the case alternative corresponding to a particular +-- constructor: panics if no such constructor exists +findAlt :: AltCon -> [(AltCon, a, b)] -> Maybe (AltCon, a, b) + -- A "Nothing" result *is* legitimate + -- See Note [Unreachable code] +findAlt con alts + = case alts of + (deflt@(DEFAULT,_,_):alts) -> go alts (Just deflt) + _ -> go alts Nothing + where + go [] deflt = deflt + go (alt@(con1,_,_) : alts) deflt + = case con `cmpAltCon` con1 of + LT -> deflt -- Missed it already; the alts are in increasing order + EQ -> Just alt + GT -> ASSERT( not (con1 == DEFAULT) ) go alts deflt + +{- Note [Unreachable code] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is possible (although unusual) for GHC to find a case expression +that cannot match. For example: + + data Col = Red | Green | Blue + x = Red + f v = case x of + Red -> ... + _ -> ...(case x of { Green -> e1; Blue -> e2 })... + +Suppose that for some silly reason, x isn't substituted in the case +expression. (Perhaps there's a NOINLINE on it, or profiling SCC stuff +gets in the way; cf #3118.) Then the full-lazines pass might produce +this + + x = Red + lvl = case x of { Green -> e1; Blue -> e2 }) + f v = case x of + Red -> ... + _ -> ...lvl... + +Now if x gets inlined, we won't be able to find a matching alternative +for 'Red'. That's because 'lvl' is unreachable. So rather than crashing +we generate (error "Inaccessible alternative"). + +Similar things can happen (augmented by GADTs) when the Simplifier +filters down the matching alternatives in Simplify.rebuildCase. +-} + +--------------------------------- +mergeAlts :: [(AltCon, a, b)] -> [(AltCon, a, b)] -> [(AltCon, a, b)] +-- ^ Merge alternatives preserving order; alternatives in +-- the first argument shadow ones in the second +mergeAlts [] as2 = as2 +mergeAlts as1 [] = as1 +mergeAlts (a1:as1) (a2:as2) + = case a1 `cmpAlt` a2 of + LT -> a1 : mergeAlts as1 (a2:as2) + EQ -> a1 : mergeAlts as1 as2 -- Discard a2 + GT -> a2 : mergeAlts (a1:as1) as2 + + +--------------------------------- +trimConArgs :: AltCon -> [CoreArg] -> [CoreArg] +-- ^ Given: +-- +-- > case (C a b x y) of +-- > C b x y -> ... +-- +-- We want to drop the leading type argument of the scrutinee +-- leaving the arguments to match against the pattern + +trimConArgs DEFAULT args = ASSERT( null args ) [] +trimConArgs (LitAlt _) args = ASSERT( null args ) [] +trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args + +filterAlts :: TyCon -- ^ Type constructor of scrutinee's type (used to prune possibilities) + -> [Type] -- ^ And its type arguments + -> [AltCon] -- ^ 'imposs_cons': constructors known to be impossible due to the form of the scrutinee + -> [(AltCon, [Var], a)] -- ^ Alternatives + -> ([AltCon], [(AltCon, [Var], a)]) + -- Returns: + -- 1. Constructors that will never be encountered by the + -- *default* case (if any). A superset of imposs_cons + -- 2. The new alternatives, trimmed by + -- a) remove imposs_cons + -- b) remove constructors which can't match because of GADTs + -- + -- NB: the final list of alternatives may be empty: + -- This is a tricky corner case. If the data type has no constructors, + -- which GHC allows, or if the imposs_cons covers all constructors (after taking + -- account of GADTs), then no alternatives can match. + -- + -- If callers need to preserve the invariant that there is always at least one branch + -- in a "case" statement then they will need to manually add a dummy case branch that just + -- calls "error" or similar. +filterAlts _tycon inst_tys imposs_cons alts + = (imposs_deflt_cons, addDefault trimmed_alts maybe_deflt) + where + (alts_wo_default, maybe_deflt) = findDefault alts + alt_cons = [con | (con,_,_) <- alts_wo_default] + + trimmed_alts = filterOut (impossible_alt inst_tys) alts_wo_default + + imposs_cons_set = Set.fromList imposs_cons + imposs_deflt_cons = + imposs_cons ++ filterOut (`Set.member` imposs_cons_set) alt_cons + -- "imposs_deflt_cons" are handled + -- EITHER by the context, + -- OR by a non-DEFAULT branch in this case expression. + + impossible_alt :: [Type] -> (AltCon, a, b) -> Bool + impossible_alt _ (con, _, _) | con `Set.member` imposs_cons_set = True + impossible_alt inst_tys (DataAlt con, _, _) = dataConCannotMatch inst_tys con + impossible_alt _ _ = False + +-- | Refine the default alternative to a 'DataAlt', if there is a unique way to do so. +-- See Note [Refine Default Alts] +refineDefaultAlt :: [Unique] -- ^ Uniques for constructing new binders + -> TyCon -- ^ Type constructor of scrutinee's type + -> [Type] -- ^ Type arguments of scrutinee's type + -> [AltCon] -- ^ Constructors that cannot match the DEFAULT (if any) + -> [CoreAlt] + -> (Bool, [CoreAlt]) -- ^ 'True', if a default alt was replaced with a 'DataAlt' +refineDefaultAlt us tycon tys imposs_deflt_cons all_alts + | (DEFAULT,_,rhs) : rest_alts <- all_alts + , isAlgTyCon tycon -- It's a data type, tuple, or unboxed tuples. + , not (isNewTyCon tycon) -- We can have a newtype, if we are just doing an eval: + -- case x of { DEFAULT -> e } + -- and we don't want to fill in a default for them! + , Just all_cons <- tyConDataCons_maybe tycon + , let imposs_data_cons = mkUniqSet [con | DataAlt con <- imposs_deflt_cons] + -- We now know it's a data type, so we can use + -- UniqSet rather than Set (more efficient) + impossible con = con `elementOfUniqSet` imposs_data_cons + || dataConCannotMatch tys con + = case filterOut impossible all_cons of + -- Eliminate the default alternative + -- altogether if it can't match: + [] -> (False, rest_alts) + + -- It matches exactly one constructor, so fill it in: + [con] -> (True, mergeAlts rest_alts [(DataAlt con, ex_tvs ++ arg_ids, rhs)]) + -- We need the mergeAlts to keep the alternatives in the right order + where + (ex_tvs, arg_ids) = dataConRepInstPat us con tys + + -- It matches more than one, so do nothing + _ -> (False, all_alts) + + | debugIsOn, isAlgTyCon tycon, null (tyConDataCons tycon) + , not (isFamilyTyCon tycon || isAbstractTyCon tycon) + -- Check for no data constructors + -- This can legitimately happen for abstract types and type families, + -- so don't report that + = (False, all_alts) + + | otherwise -- The common case + = (False, all_alts) + +{- Note [Refine Default Alts] + +refineDefaultAlt replaces the DEFAULT alt with a constructor if there is one +possible value it could be. + +The simplest example being + +foo :: () -> () +foo x = case x of !_ -> () + +rewrites to + +foo :: () -> () +foo x = case x of () -> () + +There are two reasons in general why this is desirable. + +1. We can simplify inner expressions + +In this example we can eliminate the inner case by refining the outer case. +If we don't refine it, we are left with both case expressions. + +``` +{-# LANGUAGE BangPatterns #-} +module Test where + +mid x = x +{-# NOINLINE mid #-} + +data Foo = Foo1 () + +test :: Foo -> () +test x = + case x of + !_ -> mid (case x of + Foo1 x1 -> x1) + +``` + +refineDefaultAlt fills in the DEFAULT here with `Foo ip1` and then x +becomes bound to `Foo ip1` so is inlined into the other case which +causes the KnownBranch optimisation to kick in. + + +2. combineIdenticalAlts does a better job + +Simon Jakobi also points out that that combineIdenticalAlts will do a better job +if we refine the DEFAULT first. + +``` +data D = C0 | C1 | C2 + +case e of + DEFAULT -> e0 + C0 -> e1 + C1 -> e1 +``` + +When we apply combineIdenticalAlts to this expression, it can't +combine the alts for C0 and C1, as we already have a default case. + +If we apply refineDefaultAlt first, we get + +``` +case e of + C0 -> e1 + C1 -> e1 + C2 -> e0 +``` + +and combineIdenticalAlts can turn that into + +``` +case e of + DEFAULT -> e1 + C2 -> e0 +``` + +It isn't obvious that refineDefaultAlt does this but if you look at its one +call site in SimplUtils then the `imposs_deflt_cons` argument is populated with +constructors which are matched elsewhere. + +-} + + + + +{- Note [Combine identical alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If several alternatives are identical, merge them into a single +DEFAULT alternative. I've occasionally seen this making a big +difference: + + case e of =====> case e of + C _ -> f x D v -> ....v.... + D v -> ....v.... DEFAULT -> f x + DEFAULT -> f x + +The point is that we merge common RHSs, at least for the DEFAULT case. +[One could do something more elaborate but I've never seen it needed.] +To avoid an expensive test, we just merge branches equal to the *first* +alternative; this picks up the common cases + a) all branches equal + b) some branches equal to the DEFAULT (which occurs first) + +The case where Combine Identical Alternatives transformation showed up +was like this (base/Foreign/C/Err/Error.hs): + + x | p `is` 1 -> e1 + | p `is` 2 -> e2 + ...etc... + +where @is@ was something like + + p `is` n = p /= (-1) && p == n + +This gave rise to a horrible sequence of cases + + case p of + (-1) -> $j p + 1 -> e1 + DEFAULT -> $j p + +and similarly in cascade for all the join points! + +NB: it's important that all this is done in [InAlt], *before* we work +on the alternatives themselves, because Simplify.simplAlt may zap the +occurrence info on the binders in the alternatives, which in turn +defeats combineIdenticalAlts (see #7360). + +Note [Care with impossible-constructors when combining alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have (#10538) + data T = A | B | C | D + + case x::T of (Imposs-default-cons {A,B}) + DEFAULT -> e1 + A -> e2 + B -> e1 + +When calling combineIdentialAlts, we'll have computed that the +"impossible constructors" for the DEFAULT alt is {A,B}, since if x is +A or B we'll take the other alternatives. But suppose we combine B +into the DEFAULT, to get + + case x::T of (Imposs-default-cons {A}) + DEFAULT -> e1 + A -> e2 + +Then we must be careful to trim the impossible constructors to just {A}, +else we risk compiling 'e1' wrong! + +Not only that, but we take care when there is no DEFAULT beforehand, +because we are introducing one. Consider + + case x of (Imposs-default-cons {A,B,C}) + A -> e1 + B -> e2 + C -> e1 + +Then when combining the A and C alternatives we get + + case x of (Imposs-default-cons {B}) + DEFAULT -> e1 + B -> e2 + +Note that we have a new DEFAULT branch that we didn't have before. So +we need delete from the "impossible-default-constructors" all the +known-con alternatives that we have eliminated. (In #11172 we +missed the first one.) + +-} + +combineIdenticalAlts :: [AltCon] -- Constructors that cannot match DEFAULT + -> [CoreAlt] + -> (Bool, -- True <=> something happened + [AltCon], -- New constructors that cannot match DEFAULT + [CoreAlt]) -- New alternatives +-- See Note [Combine identical alternatives] +-- True <=> we did some combining, result is a single DEFAULT alternative +combineIdenticalAlts imposs_deflt_cons ((con1,bndrs1,rhs1) : rest_alts) + | all isDeadBinder bndrs1 -- Remember the default + , not (null elim_rest) -- alternative comes first + = (True, imposs_deflt_cons', deflt_alt : filtered_rest) + where + (elim_rest, filtered_rest) = partition identical_to_alt1 rest_alts + deflt_alt = (DEFAULT, [], mkTicks (concat tickss) rhs1) + + -- See Note [Care with impossible-constructors when combining alternatives] + imposs_deflt_cons' = imposs_deflt_cons `minusList` elim_cons + elim_cons = elim_con1 ++ map fstOf3 elim_rest + elim_con1 = case con1 of -- Don't forget con1! + DEFAULT -> [] -- See Note [ + _ -> [con1] + + cheapEqTicked e1 e2 = cheapEqExpr' tickishFloatable e1 e2 + identical_to_alt1 (_con,bndrs,rhs) + = all isDeadBinder bndrs && rhs `cheapEqTicked` rhs1 + tickss = map (stripTicksT tickishFloatable . thdOf3) elim_rest + +combineIdenticalAlts imposs_cons alts + = (False, imposs_cons, alts) + +{- ********************************************************************* +* * + exprIsTrivial +* * +************************************************************************ + +Note [exprIsTrivial] +~~~~~~~~~~~~~~~~~~~~ +@exprIsTrivial@ is true of expressions we are unconditionally happy to + duplicate; simple variables and constants, and type + applications. Note that primop Ids aren't considered + trivial unless + +Note [Variables are trivial] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There used to be a gruesome test for (hasNoBinding v) in the +Var case: + exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0 +The idea here is that a constructor worker, like \$wJust, is +really short for (\x -> \$wJust x), because \$wJust has no binding. +So it should be treated like a lambda. Ditto unsaturated primops. +But now constructor workers are not "have-no-binding" Ids. And +completely un-applied primops and foreign-call Ids are sufficiently +rare that I plan to allow them to be duplicated and put up with +saturating them. + +Note [Tick trivial] +~~~~~~~~~~~~~~~~~~~ +Ticks are only trivial if they are pure annotations. If we treat +"tick x" as trivial, it will be inlined inside lambdas and the +entry count will be skewed, for example. Furthermore "scc x" will +turn into just "x" in mkTick. + +Note [Empty case is trivial] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The expression (case (x::Int) Bool of {}) is just a type-changing +case used when we are sure that 'x' will not return. See +Note [Empty case alternatives] in CoreSyn. + +If the scrutinee is trivial, then so is the whole expression; and the +CoreToSTG pass in fact drops the case expression leaving only the +scrutinee. + +Having more trivial expressions is good. Moreover, if we don't treat +it as trivial we may land up with let-bindings like + let v = case x of {} in ... +and after CoreToSTG that gives + let v = x in ... +and that confuses the code generator (#11155). So best to kill +it off at source. +-} + +exprIsTrivial :: CoreExpr -> Bool +-- If you modify this function, you may also +-- need to modify getIdFromTrivialExpr +exprIsTrivial (Var _) = True -- See Note [Variables are trivial] +exprIsTrivial (Type _) = True +exprIsTrivial (Coercion _) = True +exprIsTrivial (Lit lit) = litIsTrivial lit +exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e +exprIsTrivial (Lam b e) = not (isRuntimeVar b) && exprIsTrivial e +exprIsTrivial (Tick t e) = not (tickishIsCode t) && exprIsTrivial e + -- See Note [Tick trivial] +exprIsTrivial (Cast e _) = exprIsTrivial e +exprIsTrivial (Case e _ _ []) = exprIsTrivial e -- See Note [Empty case is trivial] +exprIsTrivial _ = False + +{- +Note [getIdFromTrivialExpr] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When substituting in a breakpoint we need to strip away the type cruft +from a trivial expression and get back to the Id. The invariant is +that the expression we're substituting was originally trivial +according to exprIsTrivial, AND the expression is not a literal. +See Note [substTickish] for how breakpoint substitution preserves +this extra invariant. + +We also need this functionality in CorePrep to extract out Id of a +function which we are saturating. However, in this case we don't know +if the variable actually refers to a literal; thus we use +'getIdFromTrivialExpr_maybe' to handle this case. See test +T12076lit for an example where this matters. +-} + +getIdFromTrivialExpr :: HasDebugCallStack => CoreExpr -> Id +getIdFromTrivialExpr e + = fromMaybe (pprPanic "getIdFromTrivialExpr" (ppr e)) + (getIdFromTrivialExpr_maybe e) + +getIdFromTrivialExpr_maybe :: CoreExpr -> Maybe Id +-- See Note [getIdFromTrivialExpr] +-- Th equations for this should line up with those for exprIsTrivial +getIdFromTrivialExpr_maybe e + = go e + where + go (App f t) | not (isRuntimeArg t) = go f + go (Tick t e) | not (tickishIsCode t) = go e + go (Cast e _) = go e + go (Lam b e) | not (isRuntimeVar b) = go e + go (Case e _ _ []) = go e + go (Var v) = Just v + go _ = Nothing + +{- +exprIsBottom is a very cheap and cheerful function; it may return +False for bottoming expressions, but it never costs much to ask. See +also CoreArity.exprBotStrictness_maybe, but that's a bit more +expensive. +-} + +exprIsBottom :: CoreExpr -> Bool +-- See Note [Bottoming expressions] +exprIsBottom e + | isEmptyTy (exprType e) + = True + | otherwise + = go 0 e + where + go n (Var v) = isBottomingId v && n >= idArity v + go n (App e a) | isTypeArg a = go n e + | otherwise = go (n+1) e + go n (Tick _ e) = go n e + go n (Cast e _) = go n e + go n (Let _ e) = go n e + go n (Lam v e) | isTyVar v = go n e + go _ (Case _ _ _ alts) = null alts + -- See Note [Empty case alternatives] in CoreSyn + go _ _ = False + +{- Note [Bottoming expressions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A bottoming expression is guaranteed to diverge, or raise an +exception. We can test for it in two different ways, and exprIsBottom +checks for both of these situations: + +* Visibly-bottom computations. For example + (error Int "Hello") + is visibly bottom. The strictness analyser also finds out if + a function diverges or raises an exception, and puts that info + in its strictness signature. + +* Empty types. If a type is empty, its only inhabitant is bottom. + For example: + data T + f :: T -> Bool + f = \(x:t). case x of Bool {} + Since T has no data constructors, the case alternatives are of course + empty. However note that 'x' is not bound to a visibly-bottom value; + it's the *type* that tells us it's going to diverge. + +A GADT may also be empty even though it has constructors: + data T a where + T1 :: a -> T Bool + T2 :: T Int + ...(case (x::T Char) of {})... +Here (T Char) is uninhabited. A more realistic case is (Int ~ Bool), +which is likewise uninhabited. + + +************************************************************************ +* * + exprIsDupable +* * +************************************************************************ + +Note [exprIsDupable] +~~~~~~~~~~~~~~~~~~~~ +@exprIsDupable@ is true of expressions that can be duplicated at a modest + cost in code size. This will only happen in different case + branches, so there's no issue about duplicating work. + + That is, exprIsDupable returns True of (f x) even if + f is very very expensive to call. + + Its only purpose is to avoid fruitless let-binding + and then inlining of case join points +-} + +exprIsDupable :: DynFlags -> CoreExpr -> Bool +exprIsDupable dflags e + = isJust (go dupAppSize e) + where + go :: Int -> CoreExpr -> Maybe Int + go n (Type {}) = Just n + go n (Coercion {}) = Just n + go n (Var {}) = decrement n + go n (Tick _ e) = go n e + go n (Cast e _) = go n e + go n (App f a) | Just n' <- go n a = go n' f + go n (Lit lit) | litIsDupable dflags lit = decrement n + go _ _ = Nothing + + decrement :: Int -> Maybe Int + decrement 0 = Nothing + decrement n = Just (n-1) + +dupAppSize :: Int +dupAppSize = 8 -- Size of term we are prepared to duplicate + -- This is *just* big enough to make test MethSharing + -- inline enough join points. Really it should be + -- smaller, and could be if we fixed #4960. + +{- +************************************************************************ +* * + exprIsCheap, exprIsExpandable +* * +************************************************************************ + +Note [exprIsWorkFree] +~~~~~~~~~~~~~~~~~~~~~ +exprIsWorkFree is used when deciding whether to inline something; we +don't inline it if doing so might duplicate work, by peeling off a +complete copy of the expression. Here we do not want even to +duplicate a primop (#5623): + eg let x = a #+ b in x +# x + we do not want to inline/duplicate x + +Previously we were a bit more liberal, which led to the primop-duplicating +problem. However, being more conservative did lead to a big regression in +one nofib benchmark, wheel-sieve1. The situation looks like this: + + let noFactor_sZ3 :: GHC.Types.Int -> GHC.Types.Bool + noFactor_sZ3 = case s_adJ of _ { GHC.Types.I# x_aRs -> + case GHC.Prim.<=# x_aRs 2 of _ { + GHC.Types.False -> notDivBy ps_adM qs_adN; + GHC.Types.True -> lvl_r2Eb }} + go = \x. ...(noFactor (I# y))....(go x')... + +The function 'noFactor' is heap-allocated and then called. Turns out +that 'notDivBy' is strict in its THIRD arg, but that is invisible to +the caller of noFactor, which therefore cannot do w/w and +heap-allocates noFactor's argument. At the moment (May 12) we are just +going to put up with this, because the previous more aggressive inlining +(which treated 'noFactor' as work-free) was duplicating primops, which +in turn was making inner loops of array calculations runs slow (#5623) + +Note [Case expressions are work-free] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Are case-expressions work-free? Consider + let v = case x of (p,q) -> p + go = \y -> ...case v of ... +Should we inline 'v' at its use site inside the loop? At the moment +we do. I experimented with saying that case are *not* work-free, but +that increased allocation slightly. It's a fairly small effect, and at +the moment we go for the slightly more aggressive version which treats +(case x of ....) as work-free if the alternatives are. + +Moreover it improves arities of overloaded functions where +there is only dictionary selection (no construction) involved + +Note [exprIsCheap] See also Note [Interaction of exprIsCheap and lone variables] +~~~~~~~~~~~~~~~~~~ in CoreUnfold.hs +@exprIsCheap@ looks at a Core expression and returns \tr{True} if +it is obviously in weak head normal form, or is cheap to get to WHNF. +[Note that that's not the same as exprIsDupable; an expression might be +big, and hence not dupable, but still cheap.] + +By ``cheap'' we mean a computation we're willing to: + push inside a lambda, or + inline at more than one place +That might mean it gets evaluated more than once, instead of being +shared. The main examples of things which aren't WHNF but are +``cheap'' are: + + * case e of + pi -> ei + (where e, and all the ei are cheap) + + * let x = e in b + (where e and b are cheap) + + * op x1 ... xn + (where op is a cheap primitive operator) + + * error "foo" + (because we are happy to substitute it inside a lambda) + +Notice that a variable is considered 'cheap': we can push it inside a lambda, +because sharing will make sure it is only evaluated once. + +Note [exprIsCheap and exprIsHNF] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note that exprIsHNF does not imply exprIsCheap. Eg + let x = fac 20 in Just x +This responds True to exprIsHNF (you can discard a seq), but +False to exprIsCheap. + +Note [Arguments and let-bindings exprIsCheapX] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What predicate should we apply to the argument of an application, or the +RHS of a let-binding? + +We used to say "exprIsTrivial arg" due to concerns about duplicating +nested constructor applications, but see #4978. So now we just recursively +use exprIsCheapX. + +We definitely want to treat let and app the same. The principle here is +that + let x = blah in f x +should behave equivalently to + f blah + +This in turn means that the 'letrec g' does not prevent eta expansion +in this (which it previously was): + f = \x. let v = case x of + True -> letrec g = \w. blah + in g + False -> \x. x + in \w. v True +-} + +-------------------- +exprIsWorkFree :: CoreExpr -> Bool -- See Note [exprIsWorkFree] +exprIsWorkFree = exprIsCheapX isWorkFreeApp + +exprIsCheap :: CoreExpr -> Bool +exprIsCheap = exprIsCheapX isCheapApp + +exprIsCheapX :: CheapAppFun -> CoreExpr -> Bool +exprIsCheapX ok_app e + = ok e + where + ok e = go 0 e + + -- n is the number of value arguments + go n (Var v) = ok_app v n + go _ (Lit {}) = True + go _ (Type {}) = True + go _ (Coercion {}) = True + go n (Cast e _) = go n e + go n (Case scrut _ _ alts) = ok scrut && + and [ go n rhs | (_,_,rhs) <- alts ] + go n (Tick t e) | tickishCounts t = False + | otherwise = go n e + go n (Lam x e) | isRuntimeVar x = n==0 || go (n-1) e + | otherwise = go n e + go n (App f e) | isRuntimeArg e = go (n+1) f && ok e + | otherwise = go n f + go n (Let (NonRec _ r) e) = go n e && ok r + go n (Let (Rec prs) e) = go n e && all (ok . snd) prs + + -- Case: see Note [Case expressions are work-free] + -- App, Let: see Note [Arguments and let-bindings exprIsCheapX] + + +{- Note [exprIsExpandable] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +An expression is "expandable" if we are willing to duplicate it, if doing +so might make a RULE or case-of-constructor fire. Consider + let x = (a,b) + y = build g + in ....(case x of (p,q) -> rhs)....(foldr k z y).... + +We don't inline 'x' or 'y' (see Note [Lone variables] in CoreUnfold), +but we do want + + * the case-expression to simplify + (via exprIsConApp_maybe, exprIsLiteral_maybe) + + * the foldr/build RULE to fire + (by expanding the unfolding during rule matching) + +So we classify the unfolding of a let-binding as "expandable" (via the +uf_expandable field) if we want to do this kind of on-the-fly +expansion. Specifically: + +* True of constructor applications (K a b) + +* True of applications of a "CONLIKE" Id; see Note [CONLIKE pragma] in BasicTypes. + (NB: exprIsCheap might not be true of this) + +* False of case-expressions. If we have + let x = case ... in ...(case x of ...)... + we won't simplify. We have to inline x. See #14688. + +* False of let-expressions (same reason); and in any case we + float lets out of an RHS if doing so will reveal an expandable + application (see SimplEnv.doFloatFromRhs). + +* Take care: exprIsExpandable should /not/ be true of primops. I + found this in test T5623a: + let q = /\a. Ptr a (a +# b) + in case q @ Float of Ptr v -> ...q... + + q's inlining should not be expandable, else exprIsConApp_maybe will + say that (q @ Float) expands to (Ptr a (a +# b)), and that will + duplicate the (a +# b) primop, which we should not do lightly. + (It's quite hard to trigger this bug, but T13155 does so for GHC 8.0.) +-} + +------------------------------------- +exprIsExpandable :: CoreExpr -> Bool +-- See Note [exprIsExpandable] +exprIsExpandable e + = ok e + where + ok e = go 0 e + + -- n is the number of value arguments + go n (Var v) = isExpandableApp v n + go _ (Lit {}) = True + go _ (Type {}) = True + go _ (Coercion {}) = True + go n (Cast e _) = go n e + go n (Tick t e) | tickishCounts t = False + | otherwise = go n e + go n (Lam x e) | isRuntimeVar x = n==0 || go (n-1) e + | otherwise = go n e + go n (App f e) | isRuntimeArg e = go (n+1) f && ok e + | otherwise = go n f + go _ (Case {}) = False + go _ (Let {}) = False + + +------------------------------------- +type CheapAppFun = Id -> Arity -> Bool + -- Is an application of this function to n *value* args + -- always cheap, assuming the arguments are cheap? + -- True mainly of data constructors, partial applications; + -- but with minor variations: + -- isWorkFreeApp + -- isCheapApp + -- isExpandableApp + +isWorkFreeApp :: CheapAppFun +isWorkFreeApp fn n_val_args + | n_val_args == 0 -- No value args + = True + | n_val_args < idArity fn -- Partial application + = True + | otherwise + = case idDetails fn of + DataConWorkId {} -> True + _ -> False + +isCheapApp :: CheapAppFun +isCheapApp fn n_val_args + | isWorkFreeApp fn n_val_args = True + | isBottomingId fn = True -- See Note [isCheapApp: bottoming functions] + | otherwise + = case idDetails fn of + DataConWorkId {} -> True -- Actually handled by isWorkFreeApp + RecSelId {} -> n_val_args == 1 -- See Note [Record selection] + ClassOpId {} -> n_val_args == 1 + PrimOpId op -> primOpIsCheap op + _ -> False + -- In principle we should worry about primops + -- that return a type variable, since the result + -- might be applied to something, but I'm not going + -- to bother to check the number of args + +isExpandableApp :: CheapAppFun +isExpandableApp fn n_val_args + | isWorkFreeApp fn n_val_args = True + | otherwise + = case idDetails fn of + DataConWorkId {} -> True -- Actually handled by isWorkFreeApp + RecSelId {} -> n_val_args == 1 -- See Note [Record selection] + ClassOpId {} -> n_val_args == 1 + PrimOpId {} -> False + _ | isBottomingId fn -> False + -- See Note [isExpandableApp: bottoming functions] + | isConLike (idRuleMatchInfo fn) -> True + | all_args_are_preds -> True + | otherwise -> False + + where + -- See if all the arguments are PredTys (implicit params or classes) + -- If so we'll regard it as expandable; see Note [Expandable overloadings] + all_args_are_preds = all_pred_args n_val_args (idType fn) + + all_pred_args n_val_args ty + | n_val_args == 0 + = True + + | Just (bndr, ty) <- splitPiTy_maybe ty + = case bndr of + Named {} -> all_pred_args n_val_args ty + Anon InvisArg _ -> all_pred_args (n_val_args-1) ty + Anon VisArg _ -> False + + | otherwise + = False + +{- Note [isCheapApp: bottoming functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +I'm not sure why we have a special case for bottoming +functions in isCheapApp. Maybe we don't need it. + +Note [isExpandableApp: bottoming functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's important that isExpandableApp does not respond True to bottoming +functions. Recall undefined :: HasCallStack => a +Suppose isExpandableApp responded True to (undefined d), and we had: + + x = undefined + +Then Simplify.prepareRhs would ANF the RHS: + + d = + x = undefined d + +This is already bad: we gain nothing from having x bound to (undefined +var), unlike the case for data constructors. Worse, we get the +simplifier loop described in OccurAnal Note [Cascading inlines]. +Suppose x occurs just once; OccurAnal.occAnalNonRecRhs decides x will +certainly_inline; so we end up inlining d right back into x; but in +the end x doesn't inline because it is bottom (preInlineUnconditionally); +so the process repeats.. We could elaborate the certainly_inline logic +some more, but it's better just to treat bottoming bindings as +non-expandable, because ANFing them is a bad idea in the first place. + +Note [Record selection] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +I'm experimenting with making record selection +look cheap, so we will substitute it inside a +lambda. Particularly for dictionary field selection. + +BUT: Take care with (sel d x)! The (sel d) might be cheap, but +there's no guarantee that (sel d x) will be too. Hence (n_val_args == 1) + +Note [Expandable overloadings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose the user wrote this + {-# RULE forall x. foo (negate x) = h x #-} + f x = ....(foo (negate x)).... +He'd expect the rule to fire. But since negate is overloaded, we might +get this: + f = \d -> let n = negate d in \x -> ...foo (n x)... +So we treat the application of a function (negate in this case) to a +*dictionary* as expandable. In effect, every function is CONLIKE when +it's applied only to dictionaries. + + +************************************************************************ +* * + exprOkForSpeculation +* * +************************************************************************ +-} + +----------------------------- +-- | 'exprOkForSpeculation' returns True of an expression that is: +-- +-- * Safe to evaluate even if normal order eval might not +-- evaluate the expression at all, or +-- +-- * Safe /not/ to evaluate even if normal order would do so +-- +-- It is usually called on arguments of unlifted type, but not always +-- In particular, Simplify.rebuildCase calls it on lifted types +-- when a 'case' is a plain 'seq'. See the example in +-- Note [exprOkForSpeculation: case expressions] below +-- +-- Precisely, it returns @True@ iff: +-- a) The expression guarantees to terminate, +-- b) soon, +-- c) without causing a write side effect (e.g. writing a mutable variable) +-- d) without throwing a Haskell exception +-- e) without risking an unchecked runtime exception (array out of bounds, +-- divide by zero) +-- +-- For @exprOkForSideEffects@ the list is the same, but omitting (e). +-- +-- Note that +-- exprIsHNF implies exprOkForSpeculation +-- exprOkForSpeculation implies exprOkForSideEffects +-- +-- See Note [PrimOp can_fail and has_side_effects] in PrimOp +-- and Note [Transformations affected by can_fail and has_side_effects] +-- +-- As an example of the considerations in this test, consider: +-- +-- > let x = case y# +# 1# of { r# -> I# r# } +-- > in E +-- +-- being translated to: +-- +-- > case y# +# 1# of { r# -> +-- > let x = I# r# +-- > in E +-- > } +-- +-- We can only do this if the @y + 1@ is ok for speculation: it has no +-- side effects, and can't diverge or raise an exception. + +exprOkForSpeculation, exprOkForSideEffects :: CoreExpr -> Bool +exprOkForSpeculation = expr_ok primOpOkForSpeculation +exprOkForSideEffects = expr_ok primOpOkForSideEffects + +expr_ok :: (PrimOp -> Bool) -> CoreExpr -> Bool +expr_ok _ (Lit _) = True +expr_ok _ (Type _) = True +expr_ok _ (Coercion _) = True + +expr_ok primop_ok (Var v) = app_ok primop_ok v [] +expr_ok primop_ok (Cast e _) = expr_ok primop_ok e +expr_ok primop_ok (Lam b e) + | isTyVar b = expr_ok primop_ok e + | otherwise = True + +-- Tick annotations that *tick* cannot be speculated, because these +-- are meant to identify whether or not (and how often) the particular +-- source expression was evaluated at runtime. +expr_ok primop_ok (Tick tickish e) + | tickishCounts tickish = False + | otherwise = expr_ok primop_ok e + +expr_ok _ (Let {}) = False + -- Lets can be stacked deeply, so just give up. + -- In any case, the argument of exprOkForSpeculation is + -- usually in a strict context, so any lets will have been + -- floated away. + +expr_ok primop_ok (Case scrut bndr _ alts) + = -- See Note [exprOkForSpeculation: case expressions] + expr_ok primop_ok scrut + && isUnliftedType (idType bndr) + && all (\(_,_,rhs) -> expr_ok primop_ok rhs) alts + && altsAreExhaustive alts + +expr_ok primop_ok other_expr + | (expr, args) <- collectArgs other_expr + = case stripTicksTopE (not . tickishCounts) expr of + Var f -> app_ok primop_ok f args + -- 'LitRubbish' is the only literal that can occur in the head of an + -- application and will not be matched by the above case (Var /= Lit). + Lit lit -> ASSERT( lit == rubbishLit ) True + _ -> False + +----------------------------- +app_ok :: (PrimOp -> Bool) -> Id -> [CoreExpr] -> Bool +app_ok primop_ok fun args + = case idDetails fun of + DFunId new_type -> not new_type + -- DFuns terminate, unless the dict is implemented + -- with a newtype in which case they may not + + DataConWorkId {} -> True + -- The strictness of the constructor has already + -- been expressed by its "wrapper", so we don't need + -- to take the arguments into account + + PrimOpId op + | isDivOp op + , [arg1, Lit lit] <- args + -> not (isZeroLit lit) && expr_ok primop_ok arg1 + -- Special case for dividing operations that fail + -- In general they are NOT ok-for-speculation + -- (which primop_ok will catch), but they ARE OK + -- if the divisor is definitely non-zero. + -- Often there is a literal divisor, and this + -- can get rid of a thunk in an inner loop + + | SeqOp <- op -- See Note [exprOkForSpeculation and SeqOp/DataToTagOp] + -> False -- for the special cases for SeqOp and DataToTagOp + | DataToTagOp <- op + -> False + + | otherwise + -> primop_ok op -- Check the primop itself + && and (zipWith primop_arg_ok arg_tys args) -- Check the arguments + + _other -> isUnliftedType (idType fun) -- c.f. the Var case of exprIsHNF + || idArity fun > n_val_args -- Partial apps + -- NB: even in the nullary case, do /not/ check + -- for evaluated-ness of the fun; + -- see Note [exprOkForSpeculation and evaluated variables] + where + n_val_args = valArgCount args + where + (arg_tys, _) = splitPiTys (idType fun) + + primop_arg_ok :: TyBinder -> CoreExpr -> Bool + primop_arg_ok (Named _) _ = True -- A type argument + primop_arg_ok (Anon _ ty) arg -- A term argument + | isUnliftedType ty = expr_ok primop_ok arg + | otherwise = True -- See Note [Primops with lifted arguments] + +----------------------------- +altsAreExhaustive :: [Alt b] -> Bool +-- True <=> the case alternatives are definiely exhaustive +-- False <=> they may or may not be +altsAreExhaustive [] + = False -- Should not happen +altsAreExhaustive ((con1,_,_) : alts) + = case con1 of + DEFAULT -> True + LitAlt {} -> False + DataAlt c -> alts `lengthIs` (tyConFamilySize (dataConTyCon c) - 1) + -- It is possible to have an exhaustive case that does not + -- enumerate all constructors, notably in a GADT match, but + -- we behave conservatively here -- I don't think it's important + -- enough to deserve special treatment + +-- | True of dyadic operators that can fail only if the second arg is zero! +isDivOp :: PrimOp -> Bool +-- This function probably belongs in PrimOp, or even in +-- an automagically generated file.. but it's such a +-- special case I thought I'd leave it here for now. +isDivOp IntQuotOp = True +isDivOp IntRemOp = True +isDivOp WordQuotOp = True +isDivOp WordRemOp = True +isDivOp FloatDivOp = True +isDivOp DoubleDivOp = True +isDivOp _ = False + +{- Note [exprOkForSpeculation: case expressions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +exprOkForSpeculation accepts very special case expressions. +Reason: (a ==# b) is ok-for-speculation, but the litEq rules +in PrelRules convert it (a ==# 3#) to + case a of { DEFAULT -> 0#; 3# -> 1# } +for excellent reasons described in + PrelRules Note [The litEq rule: converting equality to case]. +So, annoyingly, we want that case expression to be +ok-for-speculation too. Bother. + +But we restrict it sharply: + +* We restrict it to unlifted scrutinees. Consider this: + case x of y { + DEFAULT -> ... (let v::Int# = case y of { True -> e1 + ; False -> e2 } + in ...) ... + + Does the RHS of v satisfy the let/app invariant? Previously we said + yes, on the grounds that y is evaluated. But the binder-swap done + by SetLevels would transform the inner alternative to + DEFAULT -> ... (let v::Int# = case x of { ... } + in ...) .... + which does /not/ satisfy the let/app invariant, because x is + not evaluated. See Note [Binder-swap during float-out] + in SetLevels. To avoid this awkwardness it seems simpler + to stick to unlifted scrutinees where the issue does not + arise. + +* We restrict it to exhaustive alternatives. A non-exhaustive + case manifestly isn't ok-for-speculation. for example, + this is a valid program (albeit a slightly dodgy one) + let v = case x of { B -> ...; C -> ... } + in case x of + A -> ... + _ -> ...v...v.... + Should v be considered ok-for-speculation? Its scrutinee may be + evaluated, but the alternatives are incomplete so we should not + evaluate it strictly. + + Now, all this is for lifted types, but it'd be the same for any + finite unlifted type. We don't have many of them, but we might + add unlifted algebraic types in due course. + + +----- Historical note: #15696: -------- + Previously SetLevels used exprOkForSpeculation to guide + floating of single-alternative cases; it now uses exprIsHNF + Note [Floating single-alternative cases]. + + But in those days, consider + case e of x { DEAFULT -> + ...(case x of y + A -> ... + _ -> ...(case (case x of { B -> p; C -> p }) of + I# r -> blah)... + If SetLevels considers the inner nested case as + ok-for-speculation it can do case-floating (in SetLevels). + So we'd float to: + case e of x { DEAFULT -> + case (case x of { B -> p; C -> p }) of I# r -> + ...(case x of y + A -> ... + _ -> ...blah...)... + which is utterly bogus (seg fault); see #5453. + +----- Historical note: #3717: -------- + foo :: Int -> Int + foo 0 = 0 + foo n = (if n < 5 then 1 else 2) `seq` foo (n-1) + +In earlier GHCs, we got this: + T.$wfoo = + \ (ww :: GHC.Prim.Int#) -> + case ww of ds { + __DEFAULT -> case (case <# ds 5 of _ { + GHC.Types.False -> lvl1; + GHC.Types.True -> lvl}) + of _ { __DEFAULT -> + T.$wfoo (GHC.Prim.-# ds_XkE 1) }; + 0 -> 0 } + +Before join-points etc we could only get rid of two cases (which are +redundant) by recognising that the (case <# ds 5 of { ... }) is +ok-for-speculation, even though it has /lifted/ type. But now join +points do the job nicely. +------- End of historical note ------------ + + +Note [Primops with lifted arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Is this ok-for-speculation (see #13027)? + reallyUnsafePtrEq# a b +Well, yes. The primop accepts lifted arguments and does not +evaluate them. Indeed, in general primops are, well, primitive +and do not perform evaluation. + +Bottom line: + * In exprOkForSpeculation we simply ignore all lifted arguments. + * In the rare case of primops that /do/ evaluate their arguments, + (namely DataToTagOp and SeqOp) return False; see + Note [exprOkForSpeculation and evaluated variables] + +Note [exprOkForSpeculation and SeqOp/DataToTagOp] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Most primops with lifted arguments don't evaluate them +(see Note [Primops with lifted arguments]), so we can ignore +that argument entirely when doing exprOkForSpeculation. + +But DataToTagOp and SeqOp are exceptions to that rule. +For reasons described in Note [exprOkForSpeculation and +evaluated variables], we simply return False for them. + +Not doing this made #5129 go bad. +Lots of discussion in #15696. + +Note [exprOkForSpeculation and evaluated variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Recall that + seq# :: forall a s. a -> State# s -> (# State# s, a #) + dataToTag# :: forall a. a -> Int# +must always evaluate their first argument. + +Now consider these examples: + * case x of y { DEFAULT -> ....y.... } + Should 'y' (alone) be considered ok-for-speculation? + + * case x of y { DEFAULT -> ....f (dataToTag# y)... } + Should (dataToTag# y) be considered ok-for-spec? + +You could argue 'yes', because in the case alternative we know that +'y' is evaluated. But the binder-swap transformation, which is +extremely useful for float-out, changes these expressions to + case x of y { DEFAULT -> ....x.... } + case x of y { DEFAULT -> ....f (dataToTag# x)... } + +And now the expression does not obey the let/app invariant! Yikes! +Moreover we really might float (f (dataToTag# x)) outside the case, +and then it really, really doesn't obey the let/app invariant. + +The solution is simple: exprOkForSpeculation does not try to take +advantage of the evaluated-ness of (lifted) variables. And it returns +False (always) for DataToTagOp and SeqOp. + +Note that exprIsHNF /can/ and does take advantage of evaluated-ness; +it doesn't have the trickiness of the let/app invariant to worry about. + +************************************************************************ +* * + exprIsHNF, exprIsConLike +* * +************************************************************************ +-} + +-- Note [exprIsHNF] See also Note [exprIsCheap and exprIsHNF] +-- ~~~~~~~~~~~~~~~~ +-- | exprIsHNF returns true for expressions that are certainly /already/ +-- evaluated to /head/ normal form. This is used to decide whether it's ok +-- to change: +-- +-- > case x of _ -> e +-- +-- into: +-- +-- > e +-- +-- and to decide whether it's safe to discard a 'seq'. +-- +-- So, it does /not/ treat variables as evaluated, unless they say they are. +-- However, it /does/ treat partial applications and constructor applications +-- as values, even if their arguments are non-trivial, provided the argument +-- type is lifted. For example, both of these are values: +-- +-- > (:) (f x) (map f xs) +-- > map (...redex...) +-- +-- because 'seq' on such things completes immediately. +-- +-- For unlifted argument types, we have to be careful: +-- +-- > C (f x :: Int#) +-- +-- Suppose @f x@ diverges; then @C (f x)@ is not a value. However this can't +-- happen: see "CoreSyn#let_app_invariant". This invariant states that arguments of +-- unboxed type must be ok-for-speculation (or trivial). +exprIsHNF :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP +exprIsHNF = exprIsHNFlike isDataConWorkId isEvaldUnfolding + +-- | Similar to 'exprIsHNF' but includes CONLIKE functions as well as +-- data constructors. Conlike arguments are considered interesting by the +-- inliner. +exprIsConLike :: CoreExpr -> Bool -- True => lambda, conlike, PAP +exprIsConLike = exprIsHNFlike isConLikeId isConLikeUnfolding + +-- | Returns true for values or value-like expressions. These are lambdas, +-- constructors / CONLIKE functions (as determined by the function argument) +-- or PAPs. +-- +exprIsHNFlike :: (Var -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool +exprIsHNFlike is_con is_con_unf = is_hnf_like + where + is_hnf_like (Var v) -- NB: There are no value args at this point + = id_app_is_value v 0 -- Catches nullary constructors, + -- so that [] and () are values, for example + -- and (e.g.) primops that don't have unfoldings + || is_con_unf (idUnfolding v) + -- Check the thing's unfolding; it might be bound to a value + -- or to a guaranteed-evaluated variable (isEvaldUnfolding) + -- Contrast with Note [exprOkForSpeculation and evaluated variables] + -- We don't look through loop breakers here, which is a bit conservative + -- but otherwise I worry that if an Id's unfolding is just itself, + -- we could get an infinite loop + + is_hnf_like (Lit _) = True + is_hnf_like (Type _) = True -- Types are honorary Values; + -- we don't mind copying them + is_hnf_like (Coercion _) = True -- Same for coercions + is_hnf_like (Lam b e) = isRuntimeVar b || is_hnf_like e + is_hnf_like (Tick tickish e) = not (tickishCounts tickish) + && is_hnf_like e + -- See Note [exprIsHNF Tick] + is_hnf_like (Cast e _) = is_hnf_like e + is_hnf_like (App e a) + | isValArg a = app_is_value e 1 + | otherwise = is_hnf_like e + is_hnf_like (Let _ e) = is_hnf_like e -- Lazy let(rec)s don't affect us + is_hnf_like _ = False + + -- 'n' is the number of value args to which the expression is applied + -- And n>0: there is at least one value argument + app_is_value :: CoreExpr -> Int -> Bool + app_is_value (Var f) nva = id_app_is_value f nva + app_is_value (Tick _ f) nva = app_is_value f nva + app_is_value (Cast f _) nva = app_is_value f nva + app_is_value (App f a) nva + | isValArg a = app_is_value f (nva + 1) + | otherwise = app_is_value f nva + app_is_value _ _ = False + + id_app_is_value id n_val_args + = is_con id + || idArity id > n_val_args + || id `hasKey` absentErrorIdKey -- See Note [aBSENT_ERROR_ID] in MkCore + -- absentError behaves like an honorary data constructor + + +{- +Note [exprIsHNF Tick] + +We can discard source annotations on HNFs as long as they aren't +tick-like: + + scc c (\x . e) => \x . e + scc c (C x1..xn) => C x1..xn + +So we regard these as HNFs. Tick annotations that tick are not +regarded as HNF if the expression they surround is HNF, because the +tick is there to tell us that the expression was evaluated, so we +don't want to discard a seq on it. +-} + +-- | Can we bind this 'CoreExpr' at the top level? +exprIsTopLevelBindable :: CoreExpr -> Type -> Bool +-- See Note [CoreSyn top-level string literals] +-- Precondition: exprType expr = ty +-- Top-level literal strings can't even be wrapped in ticks +-- see Note [CoreSyn top-level string literals] in CoreSyn +exprIsTopLevelBindable expr ty + = not (isUnliftedType ty) + || exprIsTickedString expr + +-- | Check if the expression is zero or more Ticks wrapped around a literal +-- string. +exprIsTickedString :: CoreExpr -> Bool +exprIsTickedString = isJust . exprIsTickedString_maybe + +-- | Extract a literal string from an expression that is zero or more Ticks +-- wrapped around a literal string. Returns Nothing if the expression has a +-- different shape. +-- Used to "look through" Ticks in places that need to handle literal strings. +exprIsTickedString_maybe :: CoreExpr -> Maybe ByteString +exprIsTickedString_maybe (Lit (LitString bs)) = Just bs +exprIsTickedString_maybe (Tick t e) + -- we don't tick literals with CostCentre ticks, compare to mkTick + | tickishPlace t == PlaceCostCentre = Nothing + | otherwise = exprIsTickedString_maybe e +exprIsTickedString_maybe _ = Nothing + +{- +************************************************************************ +* * + Instantiating data constructors +* * +************************************************************************ + +These InstPat functions go here to avoid circularity between DataCon and Id +-} + +dataConRepInstPat :: [Unique] -> DataCon -> [Type] -> ([TyCoVar], [Id]) +dataConRepFSInstPat :: [FastString] -> [Unique] -> DataCon -> [Type] -> ([TyCoVar], [Id]) + +dataConRepInstPat = dataConInstPat (repeat ((fsLit "ipv"))) +dataConRepFSInstPat = dataConInstPat + +dataConInstPat :: [FastString] -- A long enough list of FSs to use for names + -> [Unique] -- An equally long list of uniques, at least one for each binder + -> DataCon + -> [Type] -- Types to instantiate the universally quantified tyvars + -> ([TyCoVar], [Id]) -- Return instantiated variables +-- dataConInstPat arg_fun fss us con inst_tys returns a tuple +-- (ex_tvs, arg_ids), +-- +-- ex_tvs are intended to be used as binders for existential type args +-- +-- arg_ids are indended to be used as binders for value arguments, +-- and their types have been instantiated with inst_tys and ex_tys +-- The arg_ids include both evidence and +-- programmer-specified arguments (both after rep-ing) +-- +-- Example. +-- The following constructor T1 +-- +-- data T a where +-- T1 :: forall b. Int -> b -> T(a,b) +-- ... +-- +-- has representation type +-- forall a. forall a1. forall b. (a ~ (a1,b)) => +-- Int -> b -> T a +-- +-- dataConInstPat fss us T1 (a1',b') will return +-- +-- ([a1'', b''], [c :: (a1', b')~(a1'', b''), x :: Int, y :: b'']) +-- +-- where the double-primed variables are created with the FastStrings and +-- Uniques given as fss and us +dataConInstPat fss uniqs con inst_tys + = ASSERT( univ_tvs `equalLength` inst_tys ) + (ex_bndrs, arg_ids) + where + univ_tvs = dataConUnivTyVars con + ex_tvs = dataConExTyCoVars con + arg_tys = dataConRepArgTys con + arg_strs = dataConRepStrictness con -- 1-1 with arg_tys + n_ex = length ex_tvs + + -- split the Uniques and FastStrings + (ex_uniqs, id_uniqs) = splitAt n_ex uniqs + (ex_fss, id_fss) = splitAt n_ex fss + + -- Make the instantiating substitution for universals + univ_subst = zipTvSubst univ_tvs inst_tys + + -- Make existential type variables, applying and extending the substitution + (full_subst, ex_bndrs) = mapAccumL mk_ex_var univ_subst + (zip3 ex_tvs ex_fss ex_uniqs) + + mk_ex_var :: TCvSubst -> (TyCoVar, FastString, Unique) -> (TCvSubst, TyCoVar) + mk_ex_var subst (tv, fs, uniq) = (Type.extendTCvSubstWithClone subst tv + new_tv + , new_tv) + where + new_tv | isTyVar tv + = mkTyVar (mkSysTvName uniq fs) kind + | otherwise + = mkCoVar (mkSystemVarName uniq fs) kind + kind = Type.substTyUnchecked subst (varType tv) + + -- Make value vars, instantiating types + arg_ids = zipWith4 mk_id_var id_uniqs id_fss arg_tys arg_strs + mk_id_var uniq fs ty str + = setCaseBndrEvald str $ -- See Note [Mark evaluated arguments] + mkLocalIdOrCoVar name (Type.substTy full_subst ty) + where + name = mkInternalName uniq (mkVarOccFS fs) noSrcSpan + +{- +Note [Mark evaluated arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When pattern matching on a constructor with strict fields, the binder +can have an 'evaldUnfolding'. Moreover, it *should* have one, so that +when loading an interface file unfolding like: + data T = MkT !Int + f x = case x of { MkT y -> let v::Int# = case y of I# n -> n+1 + in ... } +we don't want Lint to complain. The 'y' is evaluated, so the +case in the RHS of the binding for 'v' is fine. But only if we +*know* that 'y' is evaluated. + +c.f. add_evals in Simplify.simplAlt + +************************************************************************ +* * + Equality +* * +************************************************************************ +-} + +-- | A cheap equality test which bales out fast! +-- If it returns @True@ the arguments are definitely equal, +-- otherwise, they may or may not be equal. +-- +-- See also 'exprIsBig' +cheapEqExpr :: Expr b -> Expr b -> Bool +cheapEqExpr = cheapEqExpr' (const False) + +-- | Cheap expression equality test, can ignore ticks by type. +cheapEqExpr' :: (Tickish Id -> Bool) -> Expr b -> Expr b -> Bool +cheapEqExpr' ignoreTick = go_s + where go_s = go `on` stripTicksTopE ignoreTick + go (Var v1) (Var v2) = v1 == v2 + go (Lit lit1) (Lit lit2) = lit1 == lit2 + go (Type t1) (Type t2) = t1 `eqType` t2 + go (Coercion c1) (Coercion c2) = c1 `eqCoercion` c2 + + go (App f1 a1) (App f2 a2) + = f1 `go_s` f2 && a1 `go_s` a2 + + go (Cast e1 t1) (Cast e2 t2) + = e1 `go_s` e2 && t1 `eqCoercion` t2 + + go (Tick t1 e1) (Tick t2 e2) + = t1 == t2 && e1 `go_s` e2 + + go _ _ = False + {-# INLINE go #-} +{-# INLINE cheapEqExpr' #-} + +exprIsBig :: Expr b -> Bool +-- ^ Returns @True@ of expressions that are too big to be compared by 'cheapEqExpr' +exprIsBig (Lit _) = False +exprIsBig (Var _) = False +exprIsBig (Type _) = False +exprIsBig (Coercion _) = False +exprIsBig (Lam _ e) = exprIsBig e +exprIsBig (App f a) = exprIsBig f || exprIsBig a +exprIsBig (Cast e _) = exprIsBig e -- Hopefully coercions are not too big! +exprIsBig (Tick _ e) = exprIsBig e +exprIsBig _ = True + +eqExpr :: InScopeSet -> CoreExpr -> CoreExpr -> Bool +-- Compares for equality, modulo alpha +eqExpr in_scope e1 e2 + = go (mkRnEnv2 in_scope) e1 e2 + where + go env (Var v1) (Var v2) + | rnOccL env v1 == rnOccR env v2 + = True + + go _ (Lit lit1) (Lit lit2) = lit1 == lit2 + go env (Type t1) (Type t2) = eqTypeX env t1 t2 + go env (Coercion co1) (Coercion co2) = eqCoercionX env co1 co2 + go env (Cast e1 co1) (Cast e2 co2) = eqCoercionX env co1 co2 && go env e1 e2 + go env (App f1 a1) (App f2 a2) = go env f1 f2 && go env a1 a2 + go env (Tick n1 e1) (Tick n2 e2) = eqTickish env n1 n2 && go env e1 e2 + + go env (Lam b1 e1) (Lam b2 e2) + = eqTypeX env (varType b1) (varType b2) -- False for Id/TyVar combination + && go (rnBndr2 env b1 b2) e1 e2 + + go env (Let (NonRec v1 r1) e1) (Let (NonRec v2 r2) e2) + = go env r1 r2 -- No need to check binder types, since RHSs match + && go (rnBndr2 env v1 v2) e1 e2 + + go env (Let (Rec ps1) e1) (Let (Rec ps2) e2) + = equalLength ps1 ps2 + && all2 (go env') rs1 rs2 && go env' e1 e2 + where + (bs1,rs1) = unzip ps1 + (bs2,rs2) = unzip ps2 + env' = rnBndrs2 env bs1 bs2 + + go env (Case e1 b1 t1 a1) (Case e2 b2 t2 a2) + | null a1 -- See Note [Empty case alternatives] in TrieMap + = null a2 && go env e1 e2 && eqTypeX env t1 t2 + | otherwise + = go env e1 e2 && all2 (go_alt (rnBndr2 env b1 b2)) a1 a2 + + go _ _ _ = False + + ----------- + go_alt env (c1, bs1, e1) (c2, bs2, e2) + = c1 == c2 && go (rnBndrs2 env bs1 bs2) e1 e2 + +eqTickish :: RnEnv2 -> Tickish Id -> Tickish Id -> Bool +eqTickish env (Breakpoint lid lids) (Breakpoint rid rids) + = lid == rid && map (rnOccL env) lids == map (rnOccR env) rids +eqTickish _ l r = l == r + +-- | Finds differences between core expressions, modulo alpha and +-- renaming. Setting @top@ means that the @IdInfo@ of bindings will be +-- checked for differences as well. +diffExpr :: Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc] +diffExpr _ env (Var v1) (Var v2) | rnOccL env v1 == rnOccR env v2 = [] +diffExpr _ _ (Lit lit1) (Lit lit2) | lit1 == lit2 = [] +diffExpr _ env (Type t1) (Type t2) | eqTypeX env t1 t2 = [] +diffExpr _ env (Coercion co1) (Coercion co2) + | eqCoercionX env co1 co2 = [] +diffExpr top env (Cast e1 co1) (Cast e2 co2) + | eqCoercionX env co1 co2 = diffExpr top env e1 e2 +diffExpr top env (Tick n1 e1) e2 + | not (tickishIsCode n1) = diffExpr top env e1 e2 +diffExpr top env e1 (Tick n2 e2) + | not (tickishIsCode n2) = diffExpr top env e1 e2 +diffExpr top env (Tick n1 e1) (Tick n2 e2) + | eqTickish env n1 n2 = diffExpr top env e1 e2 + -- The error message of failed pattern matches will contain + -- generated names, which are allowed to differ. +diffExpr _ _ (App (App (Var absent) _) _) + (App (App (Var absent2) _) _) + | isBottomingId absent && isBottomingId absent2 = [] +diffExpr top env (App f1 a1) (App f2 a2) + = diffExpr top env f1 f2 ++ diffExpr top env a1 a2 +diffExpr top env (Lam b1 e1) (Lam b2 e2) + | eqTypeX env (varType b1) (varType b2) -- False for Id/TyVar combination + = diffExpr top (rnBndr2 env b1 b2) e1 e2 +diffExpr top env (Let bs1 e1) (Let bs2 e2) + = let (ds, env') = diffBinds top env (flattenBinds [bs1]) (flattenBinds [bs2]) + in ds ++ diffExpr top env' e1 e2 +diffExpr top env (Case e1 b1 t1 a1) (Case e2 b2 t2 a2) + | equalLength a1 a2 && not (null a1) || eqTypeX env t1 t2 + -- See Note [Empty case alternatives] in TrieMap + = diffExpr top env e1 e2 ++ concat (zipWith diffAlt a1 a2) + where env' = rnBndr2 env b1 b2 + diffAlt (c1, bs1, e1) (c2, bs2, e2) + | c1 /= c2 = [text "alt-cons " <> ppr c1 <> text " /= " <> ppr c2] + | otherwise = diffExpr top (rnBndrs2 env' bs1 bs2) e1 e2 +diffExpr _ _ e1 e2 + = [fsep [ppr e1, text "/=", ppr e2]] + +-- | Finds differences between core bindings, see @diffExpr@. +-- +-- The main problem here is that while we expect the binds to have the +-- same order in both lists, this is not guaranteed. To do this +-- properly we'd either have to do some sort of unification or check +-- all possible mappings, which would be seriously expensive. So +-- instead we simply match single bindings as far as we can. This +-- leaves us just with mutually recursive and/or mismatching bindings, +-- which we then speculatively match by ordering them. It's by no means +-- perfect, but gets the job done well enough. +diffBinds :: Bool -> RnEnv2 -> [(Var, CoreExpr)] -> [(Var, CoreExpr)] + -> ([SDoc], RnEnv2) +diffBinds top env binds1 = go (length binds1) env binds1 + where go _ env [] [] + = ([], env) + go fuel env binds1 binds2 + -- No binds left to compare? Bail out early. + | null binds1 || null binds2 + = (warn env binds1 binds2, env) + -- Iterated over all binds without finding a match? Then + -- try speculatively matching binders by order. + | fuel == 0 + = if not $ env `inRnEnvL` fst (head binds1) + then let env' = uncurry (rnBndrs2 env) $ unzip $ + zip (sort $ map fst binds1) (sort $ map fst binds2) + in go (length binds1) env' binds1 binds2 + -- If we have already tried that, give up + else (warn env binds1 binds2, env) + go fuel env ((bndr1,expr1):binds1) binds2 + | let matchExpr (bndr,expr) = + (not top || null (diffIdInfo env bndr bndr1)) && + null (diffExpr top (rnBndr2 env bndr1 bndr) expr1 expr) + , (binds2l, (bndr2,_):binds2r) <- break matchExpr binds2 + = go (length binds1) (rnBndr2 env bndr1 bndr2) + binds1 (binds2l ++ binds2r) + | otherwise -- No match, so push back (FIXME O(n^2)) + = go (fuel-1) env (binds1++[(bndr1,expr1)]) binds2 + go _ _ _ _ = panic "diffBinds: impossible" -- GHC isn't smart enough + + -- We have tried everything, but couldn't find a good match. So + -- now we just return the comparison results when we pair up + -- the binds in a pseudo-random order. + warn env binds1 binds2 = + concatMap (uncurry (diffBind env)) (zip binds1' binds2') ++ + unmatched "unmatched left-hand:" (drop l binds1') ++ + unmatched "unmatched right-hand:" (drop l binds2') + where binds1' = sortBy (comparing fst) binds1 + binds2' = sortBy (comparing fst) binds2 + l = min (length binds1') (length binds2') + unmatched _ [] = [] + unmatched txt bs = [text txt $$ ppr (Rec bs)] + diffBind env (bndr1,expr1) (bndr2,expr2) + | ds@(_:_) <- diffExpr top env expr1 expr2 + = locBind "in binding" bndr1 bndr2 ds + | otherwise + = diffIdInfo env bndr1 bndr2 + +-- | Find differences in @IdInfo@. We will especially check whether +-- the unfoldings match, if present (see @diffUnfold@). +diffIdInfo :: RnEnv2 -> Var -> Var -> [SDoc] +diffIdInfo env bndr1 bndr2 + | arityInfo info1 == arityInfo info2 + && cafInfo info1 == cafInfo info2 + && oneShotInfo info1 == oneShotInfo info2 + && inlinePragInfo info1 == inlinePragInfo info2 + && occInfo info1 == occInfo info2 + && demandInfo info1 == demandInfo info2 + && callArityInfo info1 == callArityInfo info2 + && levityInfo info1 == levityInfo info2 + = locBind "in unfolding of" bndr1 bndr2 $ + diffUnfold env (unfoldingInfo info1) (unfoldingInfo info2) + | otherwise + = locBind "in Id info of" bndr1 bndr2 + [fsep [pprBndr LetBind bndr1, text "/=", pprBndr LetBind bndr2]] + where info1 = idInfo bndr1; info2 = idInfo bndr2 + +-- | Find differences in unfoldings. Note that we will not check for +-- differences of @IdInfo@ in unfoldings, as this is generally +-- redundant, and can lead to an exponential blow-up in complexity. +diffUnfold :: RnEnv2 -> Unfolding -> Unfolding -> [SDoc] +diffUnfold _ NoUnfolding NoUnfolding = [] +diffUnfold _ BootUnfolding BootUnfolding = [] +diffUnfold _ (OtherCon cs1) (OtherCon cs2) | cs1 == cs2 = [] +diffUnfold env (DFunUnfolding bs1 c1 a1) + (DFunUnfolding bs2 c2 a2) + | c1 == c2 && equalLength bs1 bs2 + = concatMap (uncurry (diffExpr False env')) (zip a1 a2) + where env' = rnBndrs2 env bs1 bs2 +diffUnfold env (CoreUnfolding t1 _ _ v1 cl1 wf1 x1 g1) + (CoreUnfolding t2 _ _ v2 cl2 wf2 x2 g2) + | v1 == v2 && cl1 == cl2 + && wf1 == wf2 && x1 == x2 && g1 == g2 + = diffExpr False env t1 t2 +diffUnfold _ uf1 uf2 + = [fsep [ppr uf1, text "/=", ppr uf2]] + +-- | Add location information to diff messages +locBind :: String -> Var -> Var -> [SDoc] -> [SDoc] +locBind loc b1 b2 diffs = map addLoc diffs + where addLoc d = d $$ nest 2 (parens (text loc <+> bindLoc)) + bindLoc | b1 == b2 = ppr b1 + | otherwise = ppr b1 <> char '/' <> ppr b2 + +{- +************************************************************************ +* * + Eta reduction +* * +************************************************************************ + +Note [Eta reduction conditions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We try for eta reduction here, but *only* if we get all the way to an +trivial expression. We don't want to remove extra lambdas unless we +are going to avoid allocating this thing altogether. + +There are some particularly delicate points here: + +* We want to eta-reduce if doing so leaves a trivial expression, + *including* a cast. For example + \x. f |> co --> f |> co + (provided co doesn't mention x) + +* Eta reduction is not valid in general: + \x. bot /= bot + This matters, partly for old-fashioned correctness reasons but, + worse, getting it wrong can yield a seg fault. Consider + f = \x.f x + h y = case (case y of { True -> f `seq` True; False -> False }) of + True -> ...; False -> ... + + If we (unsoundly) eta-reduce f to get f=f, the strictness analyser + says f=bottom, and replaces the (f `seq` True) with just + (f `cast` unsafe-co). BUT, as thing stand, 'f' got arity 1, and it + *keeps* arity 1 (perhaps also wrongly). So CorePrep eta-expands + the definition again, so that it does not termninate after all. + Result: seg-fault because the boolean case actually gets a function value. + See #1947. + + So it's important to do the right thing. + +* Note [Arity care]: we need to be careful if we just look at f's + arity. Currently (Dec07), f's arity is visible in its own RHS (see + Note [Arity robustness] in SimplEnv) so we must *not* trust the + arity when checking that 'f' is a value. Otherwise we will + eta-reduce + f = \x. f x + to + f = f + Which might change a terminating program (think (f `seq` e)) to a + non-terminating one. So we check for being a loop breaker first. + + However for GlobalIds we can look at the arity; and for primops we + must, since they have no unfolding. + +* Regardless of whether 'f' is a value, we always want to + reduce (/\a -> f a) to f + This came up in a RULE: foldr (build (/\a -> g a)) + did not match foldr (build (/\b -> ...something complex...)) + The type checker can insert these eta-expanded versions, + with both type and dictionary lambdas; hence the slightly + ad-hoc isDictId + +* Never *reduce* arity. For example + f = \xy. g x y + Then if h has arity 1 we don't want to eta-reduce because then + f's arity would decrease, and that is bad + +These delicacies are why we don't use exprIsTrivial and exprIsHNF here. +Alas. + +Note [Eta reduction with casted arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + (\(x:t3). f (x |> g)) :: t3 -> t2 + where + f :: t1 -> t2 + g :: t3 ~ t1 +This should be eta-reduced to + + f |> (sym g -> t2) + +So we need to accumulate a coercion, pushing it inward (past +variable arguments only) thus: + f (x |> co_arg) |> co --> (f |> (sym co_arg -> co)) x + f (x:t) |> co --> (f |> (t -> co)) x + f @ a |> co --> (f |> (forall a.co)) @ a + f @ (g:t1~t2) |> co --> (f |> (t1~t2 => co)) @ (g:t1~t2) +These are the equations for ok_arg. + +It's true that we could also hope to eta reduce these: + (\xy. (f x |> g) y) + (\xy. (f x y) |> g) +But the simplifier pushes those casts outwards, so we don't +need to address that here. +-} + +tryEtaReduce :: [Var] -> CoreExpr -> Maybe CoreExpr +tryEtaReduce bndrs body + = go (reverse bndrs) body (mkRepReflCo (exprType body)) + where + incoming_arity = count isId bndrs + + go :: [Var] -- Binders, innermost first, types [a3,a2,a1] + -> CoreExpr -- Of type tr + -> Coercion -- Of type tr ~ ts + -> Maybe CoreExpr -- Of type a1 -> a2 -> a3 -> ts + -- See Note [Eta reduction with casted arguments] + -- for why we have an accumulating coercion + go [] fun co + | ok_fun fun + , let used_vars = exprFreeVars fun `unionVarSet` tyCoVarsOfCo co + , not (any (`elemVarSet` used_vars) bndrs) + = Just (mkCast fun co) -- Check for any of the binders free in the result + -- including the accumulated coercion + + go bs (Tick t e) co + | tickishFloatable t + = fmap (Tick t) $ go bs e co + -- Float app ticks: \x -> Tick t (e x) ==> Tick t e + + go (b : bs) (App fun arg) co + | Just (co', ticks) <- ok_arg b arg co + = fmap (flip (foldr mkTick) ticks) $ go bs fun co' + -- Float arg ticks: \x -> e (Tick t x) ==> Tick t e + + go _ _ _ = Nothing -- Failure! + + --------------- + -- Note [Eta reduction conditions] + ok_fun (App fun (Type {})) = ok_fun fun + ok_fun (Cast fun _) = ok_fun fun + ok_fun (Tick _ expr) = ok_fun expr + ok_fun (Var fun_id) = ok_fun_id fun_id || all ok_lam bndrs + ok_fun _fun = False + + --------------- + ok_fun_id fun = fun_arity fun >= incoming_arity + + --------------- + fun_arity fun -- See Note [Arity care] + | isLocalId fun + , isStrongLoopBreaker (idOccInfo fun) = 0 + | arity > 0 = arity + | isEvaldUnfolding (idUnfolding fun) = 1 + -- See Note [Eta reduction of an eval'd function] + | otherwise = 0 + where + arity = idArity fun + + --------------- + ok_lam v = isTyVar v || isEvVar v + + --------------- + ok_arg :: Var -- Of type bndr_t + -> CoreExpr -- Of type arg_t + -> Coercion -- Of kind (t1~t2) + -> Maybe (Coercion -- Of type (arg_t -> t1 ~ bndr_t -> t2) + -- (and similarly for tyvars, coercion args) + , [Tickish Var]) + -- See Note [Eta reduction with casted arguments] + ok_arg bndr (Type ty) co + | Just tv <- getTyVar_maybe ty + , bndr == tv = Just (mkHomoForAllCos [tv] co, []) + ok_arg bndr (Var v) co + | bndr == v = let reflCo = mkRepReflCo (idType bndr) + in Just (mkFunCo Representational reflCo co, []) + ok_arg bndr (Cast e co_arg) co + | (ticks, Var v) <- stripTicksTop tickishFloatable e + , bndr == v + = Just (mkFunCo Representational (mkSymCo co_arg) co, ticks) + -- The simplifier combines multiple casts into one, + -- so we can have a simple-minded pattern match here + ok_arg bndr (Tick t arg) co + | tickishFloatable t, Just (co', ticks) <- ok_arg bndr arg co + = Just (co', t:ticks) + + ok_arg _ _ _ = Nothing + +{- +Note [Eta reduction of an eval'd function] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In Haskell it is not true that f = \x. f x +because f might be bottom, and 'seq' can distinguish them. + +But it *is* true that f = f `seq` \x. f x +and we'd like to simplify the latter to the former. This amounts +to the rule that + * when there is just *one* value argument, + * f is not bottom +we can eta-reduce \x. f x ===> f + +This turned up in #7542. + + +************************************************************************ +* * +\subsection{Determining non-updatable right-hand-sides} +* * +************************************************************************ + +Top-level constructor applications can usually be allocated +statically, but they can't if the constructor, or any of the +arguments, come from another DLL (because we can't refer to static +labels in other DLLs). + +If this happens we simply make the RHS into an updatable thunk, +and 'execute' it rather than allocating it statically. +-} + +-- | This function is called only on *top-level* right-hand sides. +-- Returns @True@ if the RHS can be allocated statically in the output, +-- with no thunks involved at all. +rhsIsStatic + :: Platform + -> (Name -> Bool) -- Which names are dynamic + -> (LitNumType -> Integer -> Maybe CoreExpr) + -- Desugaring for some literals (disgusting) + -- C.f. Note [Disgusting computation of CafRefs] in TidyPgm + -> CoreExpr -> Bool +-- It's called (i) in TidyPgm.hasCafRefs to decide if the rhs is, or +-- refers to, CAFs; (ii) in CoreToStg to decide whether to put an +-- update flag on it and (iii) in DsExpr to decide how to expand +-- list literals +-- +-- The basic idea is that rhsIsStatic returns True only if the RHS is +-- (a) a value lambda +-- (b) a saturated constructor application with static args +-- +-- BUT watch out for +-- (i) Any cross-DLL references kill static-ness completely +-- because they must be 'executed' not statically allocated +-- ("DLL" here really only refers to Windows DLLs, on other platforms, +-- this is not necessary) +-- +-- (ii) We treat partial applications as redexes, because in fact we +-- make a thunk for them that runs and builds a PAP +-- at run-time. The only applications that are treated as +-- static are *saturated* applications of constructors. + +-- We used to try to be clever with nested structures like this: +-- ys = (:) w ((:) w []) +-- on the grounds that CorePrep will flatten ANF-ise it later. +-- But supporting this special case made the function much more +-- complicated, because the special case only applies if there are no +-- enclosing type lambdas: +-- ys = /\ a -> Foo (Baz ([] a)) +-- Here the nested (Baz []) won't float out to top level in CorePrep. +-- +-- But in fact, even without -O, nested structures at top level are +-- flattened by the simplifier, so we don't need to be super-clever here. +-- +-- Examples +-- +-- f = \x::Int. x+7 TRUE +-- p = (True,False) TRUE +-- +-- d = (fst p, False) FALSE because there's a redex inside +-- (this particular one doesn't happen but...) +-- +-- h = D# (1.0## /## 2.0##) FALSE (redex again) +-- n = /\a. Nil a TRUE +-- +-- t = /\a. (:) (case w a of ...) (Nil a) FALSE (redex) +-- +-- +-- This is a bit like CoreUtils.exprIsHNF, with the following differences: +-- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC) +-- +-- b) (C x xs), where C is a constructor is updatable if the application is +-- dynamic +-- +-- c) don't look through unfolding of f in (f x). + +rhsIsStatic platform is_dynamic_name cvt_literal rhs = is_static False rhs + where + is_static :: Bool -- True <=> in a constructor argument; must be atomic + -> CoreExpr -> Bool + + is_static False (Lam b e) = isRuntimeVar b || is_static False e + is_static in_arg (Tick n e) = not (tickishIsCode n) + && is_static in_arg e + is_static in_arg (Cast e _) = is_static in_arg e + is_static _ (Coercion {}) = True -- Behaves just like a literal + is_static in_arg (Lit (LitNumber nt i _)) = case cvt_literal nt i of + Just e -> is_static in_arg e + Nothing -> True + is_static _ (Lit (LitLabel {})) = False + is_static _ (Lit _) = True + -- A LitLabel (foreign import "&foo") in an argument + -- prevents a constructor application from being static. The + -- reason is that it might give rise to unresolvable symbols + -- in the object file: under Linux, references to "weak" + -- symbols from the data segment give rise to "unresolvable + -- relocation" errors at link time This might be due to a bug + -- in the linker, but we'll work around it here anyway. + -- SDM 24/2/2004 + + is_static in_arg other_expr = go other_expr 0 + where + go (Var f) n_val_args + | (platformOS platform /= OSMinGW32) || + not (is_dynamic_name (idName f)) + = saturated_data_con f n_val_args + || (in_arg && n_val_args == 0) + -- A naked un-applied variable is *not* deemed a static RHS + -- E.g. f = g + -- Reason: better to update so that the indirection gets shorted + -- out, and the true value will be seen + -- NB: if you change this, you'll break the invariant that THUNK_STATICs + -- are always updatable. If you do so, make sure that non-updatable + -- ones have enough space for their static link field! + + go (App f a) n_val_args + | isTypeArg a = go f n_val_args + | not in_arg && is_static True a = go f (n_val_args + 1) + -- The (not in_arg) checks that we aren't in a constructor argument; + -- if we are, we don't allow (value) applications of any sort + -- + -- NB. In case you wonder, args are sometimes not atomic. eg. + -- x = D# (1.0## /## 2.0##) + -- can't float because /## can fail. + + go (Tick n f) n_val_args = not (tickishIsCode n) && go f n_val_args + go (Cast e _) n_val_args = go e n_val_args + go _ _ = False + + saturated_data_con f n_val_args + = case isDataConWorkId_maybe f of + Just dc -> n_val_args == dataConRepArity dc + Nothing -> False + +{- +************************************************************************ +* * +\subsection{Type utilities} +* * +************************************************************************ +-} + +-- | True if the type has no non-bottom elements, e.g. when it is an empty +-- datatype, or a GADT with non-satisfiable type parameters, e.g. Int :~: Bool. +-- See Note [Bottoming expressions] +-- +-- See Note [No alternatives lint check] for another use of this function. +isEmptyTy :: Type -> Bool +isEmptyTy ty + -- Data types where, given the particular type parameters, no data + -- constructor matches, are empty. + -- This includes data types with no constructors, e.g. Data.Void.Void. + | Just (tc, inst_tys) <- splitTyConApp_maybe ty + , Just dcs <- tyConDataCons_maybe tc + , all (dataConCannotMatch inst_tys) dcs + = True + | otherwise + = False + +{- +***************************************************** +* +* StaticPtr +* +***************************************************** +-} + +-- | @collectMakeStaticArgs (makeStatic t srcLoc e)@ yields +-- @Just (makeStatic, t, srcLoc, e)@. +-- +-- Returns @Nothing@ for every other expression. +collectMakeStaticArgs + :: CoreExpr -> Maybe (CoreExpr, Type, CoreExpr, CoreExpr) +collectMakeStaticArgs e + | (fun@(Var b), [Type t, loc, arg], _) <- collectArgsTicks (const True) e + , idName b == makeStaticName = Just (fun, t, loc, arg) +collectMakeStaticArgs _ = Nothing + +{- +************************************************************************ +* * +\subsection{Join points} +* * +************************************************************************ +-} + +-- | Does this binding bind a join point (or a recursive group of join points)? +isJoinBind :: CoreBind -> Bool +isJoinBind (NonRec b _) = isJoinId b +isJoinBind (Rec ((b, _) : _)) = isJoinId b +isJoinBind _ = False diff --git a/compiler/coreSyn/MkCore.hs b/compiler/coreSyn/MkCore.hs new file mode 100644 --- /dev/null +++ b/compiler/coreSyn/MkCore.hs @@ -0,0 +1,911 @@ +{-# LANGUAGE CPP #-} + +-- | Handy functions for creating much Core syntax +module MkCore ( + -- * Constructing normal syntax + mkCoreLet, mkCoreLets, + mkCoreApp, mkCoreApps, mkCoreConApps, + mkCoreLams, mkWildCase, mkIfThenElse, + mkWildValBinder, mkWildEvBinder, + sortQuantVars, castBottomExpr, + + -- * Constructing boxed literals + mkWordExpr, mkWordExprWord, + mkIntExpr, mkIntExprInt, + mkIntegerExpr, mkNaturalExpr, + mkFloatExpr, mkDoubleExpr, + mkCharExpr, mkStringExpr, mkStringExprFS, mkStringExprFSWith, + + -- * Floats + FloatBind(..), wrapFloat, wrapFloats, floatBindings, + + -- * Constructing small tuples + mkCoreVarTup, mkCoreVarTupTy, mkCoreTup, mkCoreUbxTup, + mkCoreTupBoxity, unitExpr, + + -- * Constructing big tuples + mkBigCoreVarTup, mkBigCoreVarTup1, + mkBigCoreVarTupTy, mkBigCoreTupTy, + mkBigCoreTup, + + -- * Deconstructing small tuples + mkSmallTupleSelector, mkSmallTupleCase, + + -- * Deconstructing big tuples + mkTupleSelector, mkTupleSelector1, mkTupleCase, + + -- * Constructing list expressions + mkNilExpr, mkConsExpr, mkListExpr, + mkFoldrExpr, mkBuildExpr, + + -- * Constructing Maybe expressions + mkNothingExpr, mkJustExpr, + + -- * Error Ids + mkRuntimeErrorApp, mkImpossibleExpr, mkAbsentErrorApp, errorIds, + rEC_CON_ERROR_ID, rUNTIME_ERROR_ID, + nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, + pAT_ERROR_ID, rEC_SEL_ERROR_ID, aBSENT_ERROR_ID, + tYPE_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import Id +import Var ( EvVar, setTyVarUnique ) + +import CoreSyn +import CoreUtils ( exprType, needsCaseBinding, bindNonRec ) +import Literal +import HscTypes + +import TysWiredIn +import PrelNames + +import HsUtils ( mkChunkified, chunkify ) +import Type +import Coercion ( isCoVar ) +import TysPrim +import DataCon ( DataCon, dataConWorkId ) +import IdInfo +import Demand +import Name hiding ( varName ) +import Outputable +import FastString +import UniqSupply +import BasicTypes +import Util +import DynFlags +import Data.List + +import Data.Char ( ord ) +import Control.Monad.Fail as MonadFail ( MonadFail ) + +infixl 4 `mkCoreApp`, `mkCoreApps` + +{- +************************************************************************ +* * +\subsection{Basic CoreSyn construction} +* * +************************************************************************ +-} +sortQuantVars :: [Var] -> [Var] +-- Sort the variables, putting type and covars first, in scoped order, +-- and then other Ids +-- It is a deterministic sort, meaining it doesn't look at the values of +-- Uniques. For explanation why it's important See Note [Unique Determinism] +-- in Unique. +sortQuantVars vs = sorted_tcvs ++ ids + where + (tcvs, ids) = partition (isTyVar <||> isCoVar) vs + sorted_tcvs = scopedSort tcvs + +-- | Bind a binding group over an expression, using a @let@ or @case@ as +-- appropriate (see "CoreSyn#let_app_invariant") +mkCoreLet :: CoreBind -> CoreExpr -> CoreExpr +mkCoreLet (NonRec bndr rhs) body -- See Note [CoreSyn let/app invariant] + = bindNonRec bndr rhs body +mkCoreLet bind body + = Let bind body + +-- | Bind a list of binding groups over an expression. The leftmost binding +-- group becomes the outermost group in the resulting expression +mkCoreLets :: [CoreBind] -> CoreExpr -> CoreExpr +mkCoreLets binds body = foldr mkCoreLet body binds + +-- | Construct an expression which represents the application of one expression +-- paired with its type to an argument. The result is paired with its type. This +-- function is not exported and used in the definition of 'mkCoreApp' and +-- 'mkCoreApps'. +-- Respects the let/app invariant by building a case expression where necessary +-- See CoreSyn Note [CoreSyn let/app invariant] +mkCoreAppTyped :: SDoc -> (CoreExpr, Type) -> CoreExpr -> (CoreExpr, Type) +mkCoreAppTyped _ (fun, fun_ty) (Type ty) + = (App fun (Type ty), piResultTy fun_ty ty) +mkCoreAppTyped _ (fun, fun_ty) (Coercion co) + = (App fun (Coercion co), res_ty) + where + (_, res_ty) = splitFunTy fun_ty +mkCoreAppTyped d (fun, fun_ty) arg + = ASSERT2( isFunTy fun_ty, ppr fun $$ ppr arg $$ d ) + (mk_val_app fun arg arg_ty res_ty, res_ty) + where + (arg_ty, res_ty) = splitFunTy fun_ty + +-- | Construct an expression which represents the application of one expression +-- to the other +-- Respects the let/app invariant by building a case expression where necessary +-- See CoreSyn Note [CoreSyn let/app invariant] +mkCoreApp :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr +mkCoreApp s fun arg + = fst $ mkCoreAppTyped s (fun, exprType fun) arg + +-- | Construct an expression which represents the application of a number of +-- expressions to another. The leftmost expression in the list is applied first +-- Respects the let/app invariant by building a case expression where necessary +-- See CoreSyn Note [CoreSyn let/app invariant] +mkCoreApps :: CoreExpr -> [CoreExpr] -> CoreExpr +mkCoreApps fun args + = fst $ + foldl' (mkCoreAppTyped doc_string) (fun, fun_ty) args + where + doc_string = ppr fun_ty $$ ppr fun $$ ppr args + fun_ty = exprType fun + +-- | Construct an expression which represents the application of a number of +-- expressions to that of a data constructor expression. The leftmost expression +-- in the list is applied first +mkCoreConApps :: DataCon -> [CoreExpr] -> CoreExpr +mkCoreConApps con args = mkCoreApps (Var (dataConWorkId con)) args + +mk_val_app :: CoreExpr -> CoreExpr -> Type -> Type -> CoreExpr +-- Build an application (e1 e2), +-- or a strict binding (case e2 of x -> e1 x) +-- using the latter when necessary to respect the let/app invariant +-- See Note [CoreSyn let/app invariant] +mk_val_app fun arg arg_ty res_ty + | not (needsCaseBinding arg_ty arg) + = App fun arg -- The vastly common case + + | otherwise + = Case arg arg_id res_ty [(DEFAULT,[],App fun (Var arg_id))] + where + arg_id = mkWildValBinder arg_ty + -- Lots of shadowing, but it doesn't matter, + -- because 'fun ' should not have a free wild-id + -- + -- This is Dangerous. But this is the only place we play this + -- game, mk_val_app returns an expression that does not have + -- a free wild-id. So the only thing that can go wrong + -- is if you take apart this case expression, and pass a + -- fragment of it as the fun part of a 'mk_val_app'. + +----------- +mkWildEvBinder :: PredType -> EvVar +mkWildEvBinder pred = mkWildValBinder pred + +-- | Make a /wildcard binder/. This is typically used when you need a binder +-- that you expect to use only at a *binding* site. Do not use it at +-- occurrence sites because it has a single, fixed unique, and it's very +-- easy to get into difficulties with shadowing. That's why it is used so little. +-- See Note [WildCard binders] in SimplEnv +mkWildValBinder :: Type -> Id +mkWildValBinder ty = mkLocalIdOrCoVar wildCardName ty + +mkWildCase :: CoreExpr -> Type -> Type -> [CoreAlt] -> CoreExpr +-- Make a case expression whose case binder is unused +-- The alts should not have any occurrences of WildId +mkWildCase scrut scrut_ty res_ty alts + = Case scrut (mkWildValBinder scrut_ty) res_ty alts + +mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr +mkIfThenElse guard then_expr else_expr +-- Not going to be refining, so okay to take the type of the "then" clause + = mkWildCase guard boolTy (exprType then_expr) + [ (DataAlt falseDataCon, [], else_expr), -- Increasing order of tag! + (DataAlt trueDataCon, [], then_expr) ] + +castBottomExpr :: CoreExpr -> Type -> CoreExpr +-- (castBottomExpr e ty), assuming that 'e' diverges, +-- return an expression of type 'ty' +-- See Note [Empty case alternatives] in CoreSyn +castBottomExpr e res_ty + | e_ty `eqType` res_ty = e + | otherwise = Case e (mkWildValBinder e_ty) res_ty [] + where + e_ty = exprType e + +{- +The functions from this point don't really do anything cleverer than +their counterparts in CoreSyn, but they are here for consistency +-} + +-- | Create a lambda where the given expression has a number of variables +-- bound over it. The leftmost binder is that bound by the outermost +-- lambda in the result +mkCoreLams :: [CoreBndr] -> CoreExpr -> CoreExpr +mkCoreLams = mkLams + +{- +************************************************************************ +* * +\subsection{Making literals} +* * +************************************************************************ +-} + +-- | Create a 'CoreExpr' which will evaluate to the given @Int@ +mkIntExpr :: DynFlags -> Integer -> CoreExpr -- Result = I# i :: Int +mkIntExpr dflags i = mkCoreConApps intDataCon [mkIntLit dflags i] + +-- | Create a 'CoreExpr' which will evaluate to the given @Int@ +mkIntExprInt :: DynFlags -> Int -> CoreExpr -- Result = I# i :: Int +mkIntExprInt dflags i = mkCoreConApps intDataCon [mkIntLitInt dflags i] + +-- | Create a 'CoreExpr' which will evaluate to the a @Word@ with the given value +mkWordExpr :: DynFlags -> Integer -> CoreExpr +mkWordExpr dflags w = mkCoreConApps wordDataCon [mkWordLit dflags w] + +-- | Create a 'CoreExpr' which will evaluate to the given @Word@ +mkWordExprWord :: DynFlags -> Word -> CoreExpr +mkWordExprWord dflags w = mkCoreConApps wordDataCon [mkWordLitWord dflags w] + +-- | Create a 'CoreExpr' which will evaluate to the given @Integer@ +mkIntegerExpr :: MonadThings m => Integer -> m CoreExpr -- Result :: Integer +mkIntegerExpr i = do t <- lookupTyCon integerTyConName + return (Lit (mkLitInteger i (mkTyConTy t))) + +-- | Create a 'CoreExpr' which will evaluate to the given @Natural@ +mkNaturalExpr :: MonadThings m => Integer -> m CoreExpr +mkNaturalExpr i = do t <- lookupTyCon naturalTyConName + return (Lit (mkLitNatural i (mkTyConTy t))) + +-- | Create a 'CoreExpr' which will evaluate to the given @Float@ +mkFloatExpr :: Float -> CoreExpr +mkFloatExpr f = mkCoreConApps floatDataCon [mkFloatLitFloat f] + +-- | Create a 'CoreExpr' which will evaluate to the given @Double@ +mkDoubleExpr :: Double -> CoreExpr +mkDoubleExpr d = mkCoreConApps doubleDataCon [mkDoubleLitDouble d] + + +-- | Create a 'CoreExpr' which will evaluate to the given @Char@ +mkCharExpr :: Char -> CoreExpr -- Result = C# c :: Int +mkCharExpr c = mkCoreConApps charDataCon [mkCharLit c] + +-- | Create a 'CoreExpr' which will evaluate to the given @String@ +mkStringExpr :: MonadThings m => String -> m CoreExpr -- Result :: String + +-- | Create a 'CoreExpr' which will evaluate to a string morally equivalent to the given @FastString@ +mkStringExprFS :: MonadThings m => FastString -> m CoreExpr -- Result :: String + +mkStringExpr str = mkStringExprFS (mkFastString str) + +mkStringExprFS = mkStringExprFSWith lookupId + +mkStringExprFSWith :: Monad m => (Name -> m Id) -> FastString -> m CoreExpr +mkStringExprFSWith lookupM str + | nullFS str + = return (mkNilExpr charTy) + + | all safeChar chars + = do unpack_id <- lookupM unpackCStringName + return (App (Var unpack_id) lit) + + | otherwise + = do unpack_utf8_id <- lookupM unpackCStringUtf8Name + return (App (Var unpack_utf8_id) lit) + + where + chars = unpackFS str + safeChar c = ord c >= 1 && ord c <= 0x7F + lit = Lit (LitString (bytesFS str)) + +{- +************************************************************************ +* * +\subsection{Tuple constructors} +* * +************************************************************************ +-} + +{- +Creating tuples and their types for Core expressions + +@mkBigCoreVarTup@ builds a tuple; the inverse to @mkTupleSelector@. + +* If it has only one element, it is the identity function. + +* If there are more elements than a big tuple can have, it nests + the tuples. + +Note [Flattening one-tuples] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This family of functions creates a tuple of variables/expressions/types. + mkCoreTup [e1,e2,e3] = (e1,e2,e3) +What if there is just one variable/expression/type in the argument? +We could do one of two things: + +* Flatten it out, so that + mkCoreTup [e1] = e1 + +* Build a one-tuple (see Note [One-tuples] in TysWiredIn) + mkCoreTup1 [e1] = Unit e1 + We use a suffix "1" to indicate this. + +Usually we want the former, but occasionally the latter. +-} + +-- | Build a small tuple holding the specified variables +-- One-tuples are flattened; see Note [Flattening one-tuples] +mkCoreVarTup :: [Id] -> CoreExpr +mkCoreVarTup ids = mkCoreTup (map Var ids) + +-- | Build the type of a small tuple that holds the specified variables +-- One-tuples are flattened; see Note [Flattening one-tuples] +mkCoreVarTupTy :: [Id] -> Type +mkCoreVarTupTy ids = mkBoxedTupleTy (map idType ids) + +-- | Build a small tuple holding the specified expressions +-- One-tuples are flattened; see Note [Flattening one-tuples] +mkCoreTup :: [CoreExpr] -> CoreExpr +mkCoreTup [] = Var unitDataConId +mkCoreTup [c] = c +mkCoreTup cs = mkCoreConApps (tupleDataCon Boxed (length cs)) + (map (Type . exprType) cs ++ cs) + +-- | Build a small unboxed tuple holding the specified expressions, +-- with the given types. The types must be the types of the expressions. +-- Do not include the RuntimeRep specifiers; this function calculates them +-- for you. +-- Does /not/ flatten one-tuples; see Note [Flattening one-tuples] +mkCoreUbxTup :: [Type] -> [CoreExpr] -> CoreExpr +mkCoreUbxTup tys exps + = ASSERT( tys `equalLength` exps) + mkCoreConApps (tupleDataCon Unboxed (length tys)) + (map (Type . getRuntimeRep) tys ++ map Type tys ++ exps) + +-- | Make a core tuple of the given boxity +mkCoreTupBoxity :: Boxity -> [CoreExpr] -> CoreExpr +mkCoreTupBoxity Boxed exps = mkCoreTup exps +mkCoreTupBoxity Unboxed exps = mkCoreUbxTup (map exprType exps) exps + +-- | Build a big tuple holding the specified variables +-- One-tuples are flattened; see Note [Flattening one-tuples] +mkBigCoreVarTup :: [Id] -> CoreExpr +mkBigCoreVarTup ids = mkBigCoreTup (map Var ids) + +mkBigCoreVarTup1 :: [Id] -> CoreExpr +-- Same as mkBigCoreVarTup, but one-tuples are NOT flattened +-- see Note [Flattening one-tuples] +mkBigCoreVarTup1 [id] = mkCoreConApps (tupleDataCon Boxed 1) + [Type (idType id), Var id] +mkBigCoreVarTup1 ids = mkBigCoreTup (map Var ids) + +-- | Build the type of a big tuple that holds the specified variables +-- One-tuples are flattened; see Note [Flattening one-tuples] +mkBigCoreVarTupTy :: [Id] -> Type +mkBigCoreVarTupTy ids = mkBigCoreTupTy (map idType ids) + +-- | Build a big tuple holding the specified expressions +-- One-tuples are flattened; see Note [Flattening one-tuples] +mkBigCoreTup :: [CoreExpr] -> CoreExpr +mkBigCoreTup = mkChunkified mkCoreTup + +-- | Build the type of a big tuple that holds the specified type of thing +-- One-tuples are flattened; see Note [Flattening one-tuples] +mkBigCoreTupTy :: [Type] -> Type +mkBigCoreTupTy = mkChunkified mkBoxedTupleTy + +-- | The unit expression +unitExpr :: CoreExpr +unitExpr = Var unitDataConId + +{- +************************************************************************ +* * +\subsection{Tuple destructors} +* * +************************************************************************ +-} + +-- | Builds a selector which scrutises the given +-- expression and extracts the one name from the list given. +-- If you want the no-shadowing rule to apply, the caller +-- is responsible for making sure that none of these names +-- are in scope. +-- +-- If there is just one 'Id' in the tuple, then the selector is +-- just the identity. +-- +-- If necessary, we pattern match on a \"big\" tuple. +mkTupleSelector, mkTupleSelector1 + :: [Id] -- ^ The 'Id's to pattern match the tuple against + -> Id -- ^ The 'Id' to select + -> Id -- ^ A variable of the same type as the scrutinee + -> CoreExpr -- ^ Scrutinee + -> CoreExpr -- ^ Selector expression + +-- mkTupleSelector [a,b,c,d] b v e +-- = case e of v { +-- (p,q) -> case p of p { +-- (a,b) -> b }} +-- We use 'tpl' vars for the p,q, since shadowing does not matter. +-- +-- In fact, it's more convenient to generate it innermost first, getting +-- +-- case (case e of v +-- (p,q) -> p) of p +-- (a,b) -> b +mkTupleSelector vars the_var scrut_var scrut + = mk_tup_sel (chunkify vars) the_var + where + mk_tup_sel [vars] the_var = mkSmallTupleSelector vars the_var scrut_var scrut + mk_tup_sel vars_s the_var = mkSmallTupleSelector group the_var tpl_v $ + mk_tup_sel (chunkify tpl_vs) tpl_v + where + tpl_tys = [mkBoxedTupleTy (map idType gp) | gp <- vars_s] + tpl_vs = mkTemplateLocals tpl_tys + [(tpl_v, group)] = [(tpl,gp) | (tpl,gp) <- zipEqual "mkTupleSelector" tpl_vs vars_s, + the_var `elem` gp ] +-- ^ 'mkTupleSelector1' is like 'mkTupleSelector' +-- but one-tuples are NOT flattened (see Note [Flattening one-tuples]) +mkTupleSelector1 vars the_var scrut_var scrut + | [_] <- vars + = mkSmallTupleSelector1 vars the_var scrut_var scrut + | otherwise + = mkTupleSelector vars the_var scrut_var scrut + +-- | Like 'mkTupleSelector' but for tuples that are guaranteed +-- never to be \"big\". +-- +-- > mkSmallTupleSelector [x] x v e = [| e |] +-- > mkSmallTupleSelector [x,y,z] x v e = [| case e of v { (x,y,z) -> x } |] +mkSmallTupleSelector, mkSmallTupleSelector1 + :: [Id] -- The tuple args + -> Id -- The selected one + -> Id -- A variable of the same type as the scrutinee + -> CoreExpr -- Scrutinee + -> CoreExpr +mkSmallTupleSelector [var] should_be_the_same_var _ scrut + = ASSERT(var == should_be_the_same_var) + scrut -- Special case for 1-tuples +mkSmallTupleSelector vars the_var scrut_var scrut + = mkSmallTupleSelector1 vars the_var scrut_var scrut + +-- ^ 'mkSmallTupleSelector1' is like 'mkSmallTupleSelector' +-- but one-tuples are NOT flattened (see Note [Flattening one-tuples]) +mkSmallTupleSelector1 vars the_var scrut_var scrut + = ASSERT( notNull vars ) + Case scrut scrut_var (idType the_var) + [(DataAlt (tupleDataCon Boxed (length vars)), vars, Var the_var)] + +-- | A generalization of 'mkTupleSelector', allowing the body +-- of the case to be an arbitrary expression. +-- +-- To avoid shadowing, we use uniques to invent new variables. +-- +-- If necessary we pattern match on a \"big\" tuple. +mkTupleCase :: UniqSupply -- ^ For inventing names of intermediate variables + -> [Id] -- ^ The tuple identifiers to pattern match on + -> CoreExpr -- ^ Body of the case + -> Id -- ^ A variable of the same type as the scrutinee + -> CoreExpr -- ^ Scrutinee + -> CoreExpr +-- ToDo: eliminate cases where none of the variables are needed. +-- +-- mkTupleCase uniqs [a,b,c,d] body v e +-- = case e of v { (p,q) -> +-- case p of p { (a,b) -> +-- case q of q { (c,d) -> +-- body }}} +mkTupleCase uniqs vars body scrut_var scrut + = mk_tuple_case uniqs (chunkify vars) body + where + -- This is the case where don't need any nesting + mk_tuple_case _ [vars] body + = mkSmallTupleCase vars body scrut_var scrut + + -- This is the case where we must make nest tuples at least once + mk_tuple_case us vars_s body + = let (us', vars', body') = foldr one_tuple_case (us, [], body) vars_s + in mk_tuple_case us' (chunkify vars') body' + + one_tuple_case chunk_vars (us, vs, body) + = let (uniq, us') = takeUniqFromSupply us + scrut_var = mkSysLocal (fsLit "ds") uniq + (mkBoxedTupleTy (map idType chunk_vars)) + body' = mkSmallTupleCase chunk_vars body scrut_var (Var scrut_var) + in (us', scrut_var:vs, body') + +-- | As 'mkTupleCase', but for a tuple that is small enough to be guaranteed +-- not to need nesting. +mkSmallTupleCase + :: [Id] -- ^ The tuple args + -> CoreExpr -- ^ Body of the case + -> Id -- ^ A variable of the same type as the scrutinee + -> CoreExpr -- ^ Scrutinee + -> CoreExpr + +mkSmallTupleCase [var] body _scrut_var scrut + = bindNonRec var scrut body +mkSmallTupleCase vars body scrut_var scrut +-- One branch no refinement? + = Case scrut scrut_var (exprType body) + [(DataAlt (tupleDataCon Boxed (length vars)), vars, body)] + +{- +************************************************************************ +* * + Floats +* * +************************************************************************ +-} + +data FloatBind + = FloatLet CoreBind + | FloatCase CoreExpr Id AltCon [Var] + -- case e of y { C ys -> ... } + -- See Note [Floating single-alternative cases] in SetLevels + +instance Outputable FloatBind where + ppr (FloatLet b) = text "LET" <+> ppr b + ppr (FloatCase e b c bs) = hang (text "CASE" <+> ppr e <+> ptext (sLit "of") <+> ppr b) + 2 (ppr c <+> ppr bs) + +wrapFloat :: FloatBind -> CoreExpr -> CoreExpr +wrapFloat (FloatLet defns) body = Let defns body +wrapFloat (FloatCase e b con bs) body = Case e b (exprType body) [(con, bs, body)] + +-- | Applies the floats from right to left. That is @wrapFloats [b1, b2, …, bn] +-- u = let b1 in let b2 in … in let bn in u@ +wrapFloats :: [FloatBind] -> CoreExpr -> CoreExpr +wrapFloats floats expr = foldr wrapFloat expr floats + +bindBindings :: CoreBind -> [Var] +bindBindings (NonRec b _) = [b] +bindBindings (Rec bnds) = map fst bnds + +floatBindings :: FloatBind -> [Var] +floatBindings (FloatLet bnd) = bindBindings bnd +floatBindings (FloatCase _ b _ bs) = b:bs + +{- +************************************************************************ +* * +\subsection{Common list manipulation expressions} +* * +************************************************************************ + +Call the constructor Ids when building explicit lists, so that they +interact well with rules. +-} + +-- | Makes a list @[]@ for lists of the specified type +mkNilExpr :: Type -> CoreExpr +mkNilExpr ty = mkCoreConApps nilDataCon [Type ty] + +-- | Makes a list @(:)@ for lists of the specified type +mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr +mkConsExpr ty hd tl = mkCoreConApps consDataCon [Type ty, hd, tl] + +-- | Make a list containing the given expressions, where the list has the given type +mkListExpr :: Type -> [CoreExpr] -> CoreExpr +mkListExpr ty xs = foldr (mkConsExpr ty) (mkNilExpr ty) xs + +-- | Make a fully applied 'foldr' expression +mkFoldrExpr :: MonadThings m + => Type -- ^ Element type of the list + -> Type -- ^ Fold result type + -> CoreExpr -- ^ "Cons" function expression for the fold + -> CoreExpr -- ^ "Nil" expression for the fold + -> CoreExpr -- ^ List expression being folded acress + -> m CoreExpr +mkFoldrExpr elt_ty result_ty c n list = do + foldr_id <- lookupId foldrName + return (Var foldr_id `App` Type elt_ty + `App` Type result_ty + `App` c + `App` n + `App` list) + +-- | Make a 'build' expression applied to a locally-bound worker function +mkBuildExpr :: (MonadFail.MonadFail m, MonadThings m, MonadUnique m) + => Type -- ^ Type of list elements to be built + -> ((Id, Type) -> (Id, Type) -> m CoreExpr) -- ^ Function that, given information about the 'Id's + -- of the binders for the build worker function, returns + -- the body of that worker + -> m CoreExpr +mkBuildExpr elt_ty mk_build_inside = do + [n_tyvar] <- newTyVars [alphaTyVar] + let n_ty = mkTyVarTy n_tyvar + c_ty = mkVisFunTys [elt_ty, n_ty] n_ty + [c, n] <- sequence [mkSysLocalM (fsLit "c") c_ty, mkSysLocalM (fsLit "n") n_ty] + + build_inside <- mk_build_inside (c, c_ty) (n, n_ty) + + build_id <- lookupId buildName + return $ Var build_id `App` Type elt_ty `App` mkLams [n_tyvar, c, n] build_inside + where + newTyVars tyvar_tmpls = do + uniqs <- getUniquesM + return (zipWith setTyVarUnique tyvar_tmpls uniqs) + +{- +************************************************************************ +* * + Manipulating Maybe data type +* * +************************************************************************ +-} + + +-- | Makes a Nothing for the specified type +mkNothingExpr :: Type -> CoreExpr +mkNothingExpr ty = mkConApp nothingDataCon [Type ty] + +-- | Makes a Just from a value of the specified type +mkJustExpr :: Type -> CoreExpr -> CoreExpr +mkJustExpr ty val = mkConApp justDataCon [Type ty, val] + + +{- +************************************************************************ +* * + Error expressions +* * +************************************************************************ +-} + +mkRuntimeErrorApp + :: Id -- Should be of type (forall a. Addr# -> a) + -- where Addr# points to a UTF8 encoded string + -> Type -- The type to instantiate 'a' + -> String -- The string to print + -> CoreExpr + +mkRuntimeErrorApp err_id res_ty err_msg + = mkApps (Var err_id) [ Type (getRuntimeRep res_ty) + , Type res_ty, err_string ] + where + err_string = Lit (mkLitString err_msg) + +mkImpossibleExpr :: Type -> CoreExpr +mkImpossibleExpr res_ty + = mkRuntimeErrorApp rUNTIME_ERROR_ID res_ty "Impossible case alternative" + +{- +************************************************************************ +* * + Error Ids +* * +************************************************************************ + +GHC randomly injects these into the code. + +@patError@ is just a version of @error@ for pattern-matching +failures. It knows various ``codes'' which expand to longer +strings---this saves space! + +@absentErr@ is a thing we put in for ``absent'' arguments. They jolly +well shouldn't be yanked on, but if one is, then you will get a +friendly message from @absentErr@ (rather than a totally random +crash). + +@parError@ is a special version of @error@ which the compiler does +not know to be a bottoming Id. It is used in the @_par_@ and @_seq_@ +templates, but we don't ever expect to generate code for it. +-} + +errorIds :: [Id] +errorIds + = [ rUNTIME_ERROR_ID, + nON_EXHAUSTIVE_GUARDS_ERROR_ID, + nO_METHOD_BINDING_ERROR_ID, + pAT_ERROR_ID, + rEC_CON_ERROR_ID, + rEC_SEL_ERROR_ID, + aBSENT_ERROR_ID, + tYPE_ERROR_ID -- Used with Opt_DeferTypeErrors, see #10284 + ] + +recSelErrorName, runtimeErrorName, absentErrorName :: Name +recConErrorName, patErrorName :: Name +nonExhaustiveGuardsErrorName, noMethodBindingErrorName :: Name +typeErrorName :: Name +absentSumFieldErrorName :: Name + +recSelErrorName = err_nm "recSelError" recSelErrorIdKey rEC_SEL_ERROR_ID +absentErrorName = err_nm "absentError" absentErrorIdKey aBSENT_ERROR_ID +absentSumFieldErrorName = err_nm "absentSumFieldError" absentSumFieldErrorIdKey + aBSENT_SUM_FIELD_ERROR_ID +runtimeErrorName = err_nm "runtimeError" runtimeErrorIdKey rUNTIME_ERROR_ID +recConErrorName = err_nm "recConError" recConErrorIdKey rEC_CON_ERROR_ID +patErrorName = err_nm "patError" patErrorIdKey pAT_ERROR_ID +typeErrorName = err_nm "typeError" typeErrorIdKey tYPE_ERROR_ID + +noMethodBindingErrorName = err_nm "noMethodBindingError" + noMethodBindingErrorIdKey nO_METHOD_BINDING_ERROR_ID +nonExhaustiveGuardsErrorName = err_nm "nonExhaustiveGuardsError" + nonExhaustiveGuardsErrorIdKey nON_EXHAUSTIVE_GUARDS_ERROR_ID + +err_nm :: String -> Unique -> Id -> Name +err_nm str uniq id = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit str) uniq id + +rEC_SEL_ERROR_ID, rUNTIME_ERROR_ID, rEC_CON_ERROR_ID :: Id +pAT_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID :: Id +tYPE_ERROR_ID, aBSENT_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID :: Id +rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrorName +rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorName +rEC_CON_ERROR_ID = mkRuntimeErrorId recConErrorName +pAT_ERROR_ID = mkRuntimeErrorId patErrorName +nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId noMethodBindingErrorName +nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorName +tYPE_ERROR_ID = mkRuntimeErrorId typeErrorName + +-- Note [aBSENT_SUM_FIELD_ERROR_ID] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Absent argument error for unused unboxed sum fields are different than absent +-- error used in dummy worker functions (see `mkAbsentErrorApp`): +-- +-- - `absentSumFieldError` can't take arguments because it's used in unarise for +-- unused pointer fields in unboxed sums, and applying an argument would +-- require allocating a thunk. +-- +-- - `absentSumFieldError` can't be CAFFY because that would mean making some +-- non-CAFFY definitions that use unboxed sums CAFFY in unarise. +-- +-- To make `absentSumFieldError` non-CAFFY we get a stable pointer to it in +-- RtsStartup.c and mark it as non-CAFFY here. +-- +-- Getting this wrong causes hard-to-debug runtime issues, see #15038. +-- +-- TODO: Remove stable pointer hack after fixing #9718. +-- However, we should still be careful about not making things CAFFY just +-- because they use unboxed sums. Unboxed objects are supposed to be +-- efficient, and none of the other unboxed literals make things CAFFY. + +aBSENT_SUM_FIELD_ERROR_ID + = mkVanillaGlobalWithInfo absentSumFieldErrorName + (mkSpecForAllTys [alphaTyVar] (mkTyVarTy alphaTyVar)) -- forall a . a + (vanillaIdInfo `setStrictnessInfo` mkClosedStrictSig [] botRes + `setArityInfo` 0 + `setCafInfo` NoCafRefs) -- #15038 + +mkRuntimeErrorId :: Name -> Id +-- Error function +-- with type: forall (r:RuntimeRep) (a:TYPE r). Addr# -> a +-- with arity: 1 +-- which diverges after being given one argument +-- The Addr# is expected to be the address of +-- a UTF8-encoded error string +mkRuntimeErrorId name + = mkVanillaGlobalWithInfo name runtimeErrorTy bottoming_info + where + bottoming_info = vanillaIdInfo `setStrictnessInfo` strict_sig + `setArityInfo` 1 + -- Make arity and strictness agree + + -- Do *not* mark them as NoCafRefs, because they can indeed have + -- CAF refs. For example, pAT_ERROR_ID calls GHC.Err.untangle, + -- which has some CAFs + -- In due course we may arrange that these error-y things are + -- regarded by the GC as permanently live, in which case we + -- can give them NoCaf info. As it is, any function that calls + -- any pc_bottoming_Id will itself have CafRefs, which bloats + -- SRTs. + + strict_sig = mkClosedStrictSig [evalDmd] botRes + +runtimeErrorTy :: Type +-- forall (rr :: RuntimeRep) (a :: rr). Addr# -> a +-- See Note [Error and friends have an "open-tyvar" forall] +runtimeErrorTy = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar] + (mkVisFunTy addrPrimTy openAlphaTy) + +{- Note [Error and friends have an "open-tyvar" forall] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +'error' and 'undefined' have types + error :: forall (v :: RuntimeRep) (a :: TYPE v). String -> a + undefined :: forall (v :: RuntimeRep) (a :: TYPE v). a +Notice the runtime-representation polymorphism. This ensures that +"error" can be instantiated at unboxed as well as boxed types. +This is OK because it never returns, so the return type is irrelevant. + + +************************************************************************ +* * + aBSENT_ERROR_ID +* * +************************************************************************ + +Note [aBSENT_ERROR_ID] +~~~~~~~~~~~~~~~~~~~~~~ +We use aBSENT_ERROR_ID to build dummy values in workers. E.g. + + f x = (case x of (a,b) -> b) + 1::Int + +The demand analyser figures ot that only the second component of x is +used, and does a w/w split thus + + f x = case x of (a,b) -> $wf b + + $wf b = let a = absentError "blah" + x = (a,b) + in + +After some simplification, the (absentError "blah") thunk goes away. + +------ Tricky wrinkle ------- +#14285 had, roughly + + data T a = MkT a !a + {-# INLINABLE f #-} + f x = case x of MkT a b -> g (MkT b a) + +It turned out that g didn't use the second component, and hence f doesn't use +the first. But the stable-unfolding for f looks like + \x. case x of MkT a b -> g ($WMkT b a) +where $WMkT is the wrapper for MkT that evaluates its arguments. We +apply the same w/w split to this unfolding (see Note [Worker-wrapper +for INLINEABLE functions] in WorkWrap) so the template ends up like + \b. let a = absentError "blah" + x = MkT a b + in case x of MkT a b -> g ($WMkT b a) + +After doing case-of-known-constructor, and expanding $WMkT we get + \b -> g (case absentError "blah" of a -> MkT b a) + +Yikes! That bogusly appears to evaluate the absentError! + +This is extremely tiresome. Another way to think of this is that, in +Core, it is an invariant that a strict data contructor, like MkT, must +be applied only to an argument in HNF. So (absentError "blah") had +better be non-bottom. + +So the "solution" is to add a special case for absentError to exprIsHNFlike. +This allows Simplify.rebuildCase, in the Note [Case to let transformation] +branch, to convert the case on absentError into a let. We also make +absentError *not* be diverging, unlike the other error-ids, so that we +can be sure not to remove the case branches before converting the case to +a let. + +If, by some bug or bizarre happenstance, we ever call absentError, we should +throw an exception. This should never happen, of course, but we definitely +can't return anything. e.g. if somehow we had + case absentError "foo" of + Nothing -> ... + Just x -> ... +then if we return, the case expression will select a field and continue. +Seg fault city. Better to throw an exception. (Even though we've said +it is in HNF :-) + +It might seem a bit surprising that seq on absentError is simply erased + + absentError "foo" `seq` x ==> x + +but that should be okay; since there's no pattern match we can't really +be relying on anything from it. +-} + +aBSENT_ERROR_ID + = mkVanillaGlobalWithInfo absentErrorName absent_ty arity_info + where + absent_ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTy addrPrimTy alphaTy) + -- Not runtime-rep polymorphic. aBSENT_ERROR_ID is only used for + -- lifted-type things; see Note [Absent errors] in WwLib + arity_info = vanillaIdInfo `setArityInfo` 1 + -- NB: no bottoming strictness info, unlike other error-ids. + -- See Note [aBSENT_ERROR_ID] + +mkAbsentErrorApp :: Type -- The type to instantiate 'a' + -> String -- The string to print + -> CoreExpr + +mkAbsentErrorApp res_ty err_msg + = mkApps (Var aBSENT_ERROR_ID) [ Type res_ty, err_string ] + where + err_string = Lit (mkLitString err_msg) diff --git a/compiler/coreSyn/PprCore.hs b/compiler/coreSyn/PprCore.hs new file mode 100644 --- /dev/null +++ b/compiler/coreSyn/PprCore.hs @@ -0,0 +1,620 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1996-1998 + + +Printing of Core syntax +-} + +{-# LANGUAGE MultiWayIf #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module PprCore ( + pprCoreExpr, pprParendExpr, + pprCoreBinding, pprCoreBindings, pprCoreAlt, + pprCoreBindingWithSize, pprCoreBindingsWithSize, + pprRules, pprOptCo + ) where + +import GhcPrelude + +import CoreSyn +import CoreStats (exprStats) +import Literal( pprLiteral ) +import Name( pprInfixName, pprPrefixName ) +import Var +import Id +import IdInfo +import Demand +import DataCon +import TyCon +import Type +import Coercion +import DynFlags +import BasicTypes +import Maybes +import Util +import Outputable +import FastString +import SrcLoc ( pprUserRealSpan ) + +{- +************************************************************************ +* * +\subsection{Public interfaces for Core printing (excluding instances)} +* * +************************************************************************ + +@pprParendCoreExpr@ puts parens around non-atomic Core expressions. +-} + +pprCoreBindings :: OutputableBndr b => [Bind b] -> SDoc +pprCoreBinding :: OutputableBndr b => Bind b -> SDoc +pprCoreExpr :: OutputableBndr b => Expr b -> SDoc +pprParendExpr :: OutputableBndr b => Expr b -> SDoc + +pprCoreBindings = pprTopBinds noAnn +pprCoreBinding = pprTopBind noAnn + +pprCoreBindingsWithSize :: [CoreBind] -> SDoc +pprCoreBindingWithSize :: CoreBind -> SDoc + +pprCoreBindingsWithSize = pprTopBinds sizeAnn +pprCoreBindingWithSize = pprTopBind sizeAnn + +instance OutputableBndr b => Outputable (Bind b) where + ppr bind = ppr_bind noAnn bind + +instance OutputableBndr b => Outputable (Expr b) where + ppr expr = pprCoreExpr expr + +{- +************************************************************************ +* * +\subsection{The guts} +* * +************************************************************************ +-} + +-- | A function to produce an annotation for a given right-hand-side +type Annotation b = Expr b -> SDoc + +-- | Annotate with the size of the right-hand-side +sizeAnn :: CoreExpr -> SDoc +sizeAnn e = text "-- RHS size:" <+> ppr (exprStats e) + +-- | No annotation +noAnn :: Expr b -> SDoc +noAnn _ = empty + +pprTopBinds :: OutputableBndr a + => Annotation a -- ^ generate an annotation to place before the + -- binding + -> [Bind a] -- ^ bindings to show + -> SDoc -- ^ the pretty result +pprTopBinds ann binds = vcat (map (pprTopBind ann) binds) + +pprTopBind :: OutputableBndr a => Annotation a -> Bind a -> SDoc +pprTopBind ann (NonRec binder expr) + = ppr_binding ann (binder,expr) $$ blankLine + +pprTopBind _ (Rec []) + = text "Rec { }" +pprTopBind ann (Rec (b:bs)) + = vcat [text "Rec {", + ppr_binding ann b, + vcat [blankLine $$ ppr_binding ann b | b <- bs], + text "end Rec }", + blankLine] + +ppr_bind :: OutputableBndr b => Annotation b -> Bind b -> SDoc + +ppr_bind ann (NonRec val_bdr expr) = ppr_binding ann (val_bdr, expr) +ppr_bind ann (Rec binds) = vcat (map pp binds) + where + pp bind = ppr_binding ann bind <> semi + +ppr_binding :: OutputableBndr b => Annotation b -> (b, Expr b) -> SDoc +ppr_binding ann (val_bdr, expr) + = sdocWithDynFlags $ \dflags -> + vcat [ ann expr + , if gopt Opt_SuppressTypeSignatures dflags + then empty + else pprBndr LetBind val_bdr + , pp_bind + ] + where + pp_bind = case bndrIsJoin_maybe val_bdr of + Nothing -> pp_normal_bind + Just ar -> pp_join_bind ar + + pp_normal_bind = hang (ppr val_bdr) 2 (equals <+> pprCoreExpr expr) + + -- For a join point of join arity n, we want to print j = \x1 ... xn -> e + -- as "j x1 ... xn = e" to differentiate when a join point returns a + -- lambda (the first rendering looks like a nullary join point returning + -- an n-argument function). + pp_join_bind join_arity + | bndrs `lengthAtLeast` join_arity + = hang (ppr val_bdr <+> sep (map (pprBndr LambdaBind) lhs_bndrs)) + 2 (equals <+> pprCoreExpr rhs) + | otherwise -- Yikes! A join-binding with too few lambda + -- Lint will complain, but we don't want to crash + -- the pretty-printer else we can't see what's wrong + -- So refer to printing j = e + = pp_normal_bind + where + (bndrs, body) = collectBinders expr + lhs_bndrs = take join_arity bndrs + rhs = mkLams (drop join_arity bndrs) body + +pprParendExpr expr = ppr_expr parens expr +pprCoreExpr expr = ppr_expr noParens expr + +noParens :: SDoc -> SDoc +noParens pp = pp + +pprOptCo :: Coercion -> SDoc +-- Print a coercion optionally; i.e. honouring -dsuppress-coercions +pprOptCo co = sdocWithDynFlags $ \dflags -> + if gopt Opt_SuppressCoercions dflags + then angleBrackets (text "Co:" <> int (coercionSize co)) + else parens (sep [ppr co, dcolon <+> ppr (coercionType co)]) + +ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc + -- The function adds parens in context that need + -- an atomic value (e.g. function args) + +ppr_expr add_par (Var name) + | isJoinId name = add_par ((text "jump") <+> ppr name) + | otherwise = ppr name +ppr_expr add_par (Type ty) = add_par (text "TYPE:" <+> ppr ty) -- Weird +ppr_expr add_par (Coercion co) = add_par (text "CO:" <+> ppr co) +ppr_expr add_par (Lit lit) = pprLiteral add_par lit + +ppr_expr add_par (Cast expr co) + = add_par $ sep [pprParendExpr expr, text "`cast`" <+> pprOptCo co] + +ppr_expr add_par expr@(Lam _ _) + = let + (bndrs, body) = collectBinders expr + in + add_par $ + hang (text "\\" <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow) + 2 (pprCoreExpr body) + +ppr_expr add_par expr@(App {}) + = sdocWithDynFlags $ \dflags -> + case collectArgs expr of { (fun, args) -> + let + pp_args = sep (map pprArg args) + val_args = dropWhile isTypeArg args -- Drop the type arguments for tuples + pp_tup_args = pprWithCommas pprCoreExpr val_args + args' + | gopt Opt_SuppressTypeApplications dflags = val_args + | otherwise = args + parens + | null args' = id + | otherwise = add_par + in + case fun of + Var f -> case isDataConWorkId_maybe f of + -- Notice that we print the *worker* + -- for tuples in paren'd format. + Just dc | saturated + , Just sort <- tyConTuple_maybe tc + -> tupleParens sort pp_tup_args + where + tc = dataConTyCon dc + saturated = val_args `lengthIs` idArity f + + _ -> parens (hang fun_doc 2 pp_args) + where + fun_doc | isJoinId f = text "jump" <+> ppr f + | otherwise = ppr f + + _ -> parens (hang (pprParendExpr fun) 2 pp_args) + } + +ppr_expr add_par (Case expr var ty [(con,args,rhs)]) + = sdocWithDynFlags $ \dflags -> + if gopt Opt_PprCaseAsLet dflags + then add_par $ -- See Note [Print case as let] + sep [ sep [ text "let! {" + <+> ppr_case_pat con args + <+> text "~" + <+> ppr_bndr var + , text "<-" <+> ppr_expr id expr + <+> text "} in" ] + , pprCoreExpr rhs + ] + else add_par $ + sep [sep [sep [ text "case" <+> pprCoreExpr expr + , whenPprDebug (text "return" <+> ppr ty) + , text "of" <+> ppr_bndr var + ] + , char '{' <+> ppr_case_pat con args <+> arrow + ] + , pprCoreExpr rhs + , char '}' + ] + where + ppr_bndr = pprBndr CaseBind + +ppr_expr add_par (Case expr var ty alts) + = add_par $ + sep [sep [text "case" + <+> pprCoreExpr expr + <+> whenPprDebug (text "return" <+> ppr ty), + text "of" <+> ppr_bndr var <+> char '{'], + nest 2 (vcat (punctuate semi (map pprCoreAlt alts))), + char '}' + ] + where + ppr_bndr = pprBndr CaseBind + + +-- special cases: let ... in let ... +-- ("disgusting" SLPJ) + +{- +ppr_expr add_par (Let bind@(NonRec val_bdr rhs@(Let _ _)) body) + = add_par $ + vcat [ + hsep [text "let {", (pprBndr LetBind val_bdr $$ ppr val_bndr), equals], + nest 2 (pprCoreExpr rhs), + text "} in", + pprCoreExpr body ] + +ppr_expr add_par (Let bind@(NonRec val_bdr rhs) expr@(Let _ _)) + = add_par + (hang (text "let {") + 2 (hsep [ppr_binding (val_bdr,rhs), + text "} in"]) + $$ + pprCoreExpr expr) +-} + + +-- General case (recursive case, too) +ppr_expr add_par (Let bind expr) + = add_par $ + sep [hang (keyword bind <+> char '{') 2 (ppr_bind noAnn bind <+> text "} in"), + pprCoreExpr expr] + where + keyword (NonRec b _) + | isJust (bndrIsJoin_maybe b) = text "join" + | otherwise = text "let" + keyword (Rec pairs) + | ((b,_):_) <- pairs + , isJust (bndrIsJoin_maybe b) = text "joinrec" + | otherwise = text "letrec" + +ppr_expr add_par (Tick tickish expr) + = sdocWithDynFlags $ \dflags -> + if gopt Opt_SuppressTicks dflags + then ppr_expr add_par expr + else add_par (sep [ppr tickish, pprCoreExpr expr]) + +pprCoreAlt :: OutputableBndr a => (AltCon, [a] , Expr a) -> SDoc +pprCoreAlt (con, args, rhs) + = hang (ppr_case_pat con args <+> arrow) 2 (pprCoreExpr rhs) + +ppr_case_pat :: OutputableBndr a => AltCon -> [a] -> SDoc +ppr_case_pat (DataAlt dc) args + | Just sort <- tyConTuple_maybe tc + = tupleParens sort (pprWithCommas ppr_bndr args) + where + ppr_bndr = pprBndr CasePatBind + tc = dataConTyCon dc + +ppr_case_pat con args + = ppr con <+> (fsep (map ppr_bndr args)) + where + ppr_bndr = pprBndr CasePatBind + + +-- | Pretty print the argument in a function application. +pprArg :: OutputableBndr a => Expr a -> SDoc +pprArg (Type ty) + = sdocWithDynFlags $ \dflags -> + if gopt Opt_SuppressTypeApplications dflags + then empty + else text "@" <+> pprParendType ty +pprArg (Coercion co) = text "@~" <+> pprOptCo co +pprArg expr = pprParendExpr expr + +{- +Note [Print case as let] +~~~~~~~~~~~~~~~~~~~~~~~~ +Single-branch case expressions are very common: + case x of y { I# x' -> + case p of q { I# p' -> ... } } +These are, in effect, just strict let's, with pattern matching. +With -dppr-case-as-let we print them as such: + let! { I# x' ~ y <- x } in + let! { I# p' ~ q <- p } in ... + + +Other printing bits-and-bobs used with the general @pprCoreBinding@ +and @pprCoreExpr@ functions. + + +Note [Binding-site specific printing] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +pprCoreBinder and pprTypedLamBinder receive a BindingSite argument to adjust +the information printed. + +Let-bound binders are printed with their full type and idInfo. + +Case-bound variables (both the case binder and pattern variables) are printed +without a type and without their unfolding. + +Furthermore, a dead case-binder is completely ignored, while otherwise, dead +binders are printed as "_". +-} + +-- These instances are sadly orphans + +instance OutputableBndr Var where + pprBndr = pprCoreBinder + pprInfixOcc = pprInfixName . varName + pprPrefixOcc = pprPrefixName . varName + bndrIsJoin_maybe = isJoinId_maybe + +instance Outputable b => OutputableBndr (TaggedBndr b) where + pprBndr _ b = ppr b -- Simple + pprInfixOcc b = ppr b + pprPrefixOcc b = ppr b + bndrIsJoin_maybe (TB b _) = isJoinId_maybe b + +pprCoreBinder :: BindingSite -> Var -> SDoc +pprCoreBinder LetBind binder + | isTyVar binder = pprKindedTyVarBndr binder + | otherwise = pprTypedLetBinder binder $$ + ppIdInfo binder (idInfo binder) + +-- Lambda bound type variables are preceded by "@" +pprCoreBinder bind_site bndr + = getPprStyle $ \ sty -> + pprTypedLamBinder bind_site (debugStyle sty) bndr + +pprUntypedBinder :: Var -> SDoc +pprUntypedBinder binder + | isTyVar binder = text "@" <+> ppr binder -- NB: don't print kind + | otherwise = pprIdBndr binder + +pprTypedLamBinder :: BindingSite -> Bool -> Var -> SDoc +-- For lambda and case binders, show the unfolding info (usually none) +pprTypedLamBinder bind_site debug_on var + = sdocWithDynFlags $ \dflags -> + case () of + _ + | not debug_on -- Show case-bound wild binders only if debug is on + , CaseBind <- bind_site + , isDeadBinder var -> empty + + | not debug_on -- Even dead binders can be one-shot + , isDeadBinder var -> char '_' <+> ppWhen (isId var) + (pprIdBndrInfo (idInfo var)) + + | not debug_on -- No parens, no kind info + , CaseBind <- bind_site -> pprUntypedBinder var + + | not debug_on + , CasePatBind <- bind_site -> pprUntypedBinder var + + | suppress_sigs dflags -> pprUntypedBinder var + + | isTyVar var -> parens (pprKindedTyVarBndr var) + + | otherwise -> parens (hang (pprIdBndr var) + 2 (vcat [ dcolon <+> pprType (idType var) + , pp_unf])) + where + suppress_sigs = gopt Opt_SuppressTypeSignatures + + unf_info = unfoldingInfo (idInfo var) + pp_unf | hasSomeUnfolding unf_info = text "Unf=" <> ppr unf_info + | otherwise = empty + +pprTypedLetBinder :: Var -> SDoc +-- Print binder with a type or kind signature (not paren'd) +pprTypedLetBinder binder + = sdocWithDynFlags $ \dflags -> + case () of + _ + | isTyVar binder -> pprKindedTyVarBndr binder + | gopt Opt_SuppressTypeSignatures dflags -> pprIdBndr binder + | otherwise -> hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder)) + +pprKindedTyVarBndr :: TyVar -> SDoc +-- Print a type variable binder with its kind (but not if *) +pprKindedTyVarBndr tyvar + = text "@" <+> pprTyVar tyvar + +-- pprIdBndr does *not* print the type +-- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness +pprIdBndr :: Id -> SDoc +pprIdBndr id = ppr id <+> pprIdBndrInfo (idInfo id) + +pprIdBndrInfo :: IdInfo -> SDoc +pprIdBndrInfo info + = sdocWithDynFlags $ \dflags -> + ppUnless (gopt Opt_SuppressIdInfo dflags) $ + info `seq` doc -- The seq is useful for poking on black holes + where + prag_info = inlinePragInfo info + occ_info = occInfo info + dmd_info = demandInfo info + lbv_info = oneShotInfo info + + has_prag = not (isDefaultInlinePragma prag_info) + has_occ = not (isManyOccs occ_info) + has_dmd = not $ isTopDmd dmd_info + has_lbv = not (hasNoOneShotInfo lbv_info) + + doc = showAttributes + [ (has_prag, text "InlPrag=" <> pprInlineDebug prag_info) + , (has_occ, text "Occ=" <> ppr occ_info) + , (has_dmd, text "Dmd=" <> ppr dmd_info) + , (has_lbv , text "OS=" <> ppr lbv_info) + ] + +{- +----------------------------------------------------- +-- IdDetails and IdInfo +----------------------------------------------------- +-} + +ppIdInfo :: Id -> IdInfo -> SDoc +ppIdInfo id info + = sdocWithDynFlags $ \dflags -> + ppUnless (gopt Opt_SuppressIdInfo dflags) $ + showAttributes + [ (True, pp_scope <> ppr (idDetails id)) + , (has_arity, text "Arity=" <> int arity) + , (has_called_arity, text "CallArity=" <> int called_arity) + , (has_caf_info, text "Caf=" <> ppr caf_info) + , (has_str_info, text "Str=" <> pprStrictness str_info) + , (has_unf, text "Unf=" <> ppr unf_info) + , (not (null rules), text "RULES:" <+> vcat (map pprRule rules)) + ] -- Inline pragma, occ, demand, one-shot info + -- printed out with all binders (when debug is on); + -- see PprCore.pprIdBndr + where + pp_scope | isGlobalId id = text "GblId" + | isExportedId id = text "LclIdX" + | otherwise = text "LclId" + + arity = arityInfo info + has_arity = arity /= 0 + + called_arity = callArityInfo info + has_called_arity = called_arity /= 0 + + caf_info = cafInfo info + has_caf_info = not (mayHaveCafRefs caf_info) + + str_info = strictnessInfo info + has_str_info = not (isTopSig str_info) + + unf_info = unfoldingInfo info + has_unf = hasSomeUnfolding unf_info + + rules = ruleInfoRules (ruleInfo info) + +showAttributes :: [(Bool,SDoc)] -> SDoc +showAttributes stuff + | null docs = empty + | otherwise = brackets (sep (punctuate comma docs)) + where + docs = [d | (True,d) <- stuff] + +{- +----------------------------------------------------- +-- Unfolding and UnfoldingGuidance +----------------------------------------------------- +-} + +instance Outputable UnfoldingGuidance where + ppr UnfNever = text "NEVER" + ppr (UnfWhen { ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }) + = text "ALWAYS_IF" <> + parens (text "arity=" <> int arity <> comma <> + text "unsat_ok=" <> ppr unsat_ok <> comma <> + text "boring_ok=" <> ppr boring_ok) + ppr (UnfIfGoodArgs { ug_args = cs, ug_size = size, ug_res = discount }) + = hsep [ text "IF_ARGS", + brackets (hsep (map int cs)), + int size, + int discount ] + +instance Outputable UnfoldingSource where + ppr InlineCompulsory = text "Compulsory" + ppr InlineStable = text "InlineStable" + ppr InlineRhs = text "" + +instance Outputable Unfolding where + ppr NoUnfolding = text "No unfolding" + ppr BootUnfolding = text "No unfolding (from boot)" + ppr (OtherCon cs) = text "OtherCon" <+> ppr cs + ppr (DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args }) + = hang (text "DFun:" <+> ptext (sLit "\\") + <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow) + 2 (ppr con <+> sep (map ppr args)) + ppr (CoreUnfolding { uf_src = src + , uf_tmpl=rhs, uf_is_top=top, uf_is_value=hnf + , uf_is_conlike=conlike, uf_is_work_free=wf + , uf_expandable=exp, uf_guidance=g }) + = text "Unf" <> braces (pp_info $$ pp_rhs) + where + pp_info = fsep $ punctuate comma + [ text "Src=" <> ppr src + , text "TopLvl=" <> ppr top + , text "Value=" <> ppr hnf + , text "ConLike=" <> ppr conlike + , text "WorkFree=" <> ppr wf + , text "Expandable=" <> ppr exp + , text "Guidance=" <> ppr g ] + pp_tmpl = sdocWithDynFlags $ \dflags -> + ppUnless (gopt Opt_SuppressUnfoldings dflags) $ + text "Tmpl=" <+> ppr rhs + pp_rhs | isStableSource src = pp_tmpl + | otherwise = empty + -- Don't print the RHS or we get a quadratic + -- blowup in the size of the printout! + +{- +----------------------------------------------------- +-- Rules +----------------------------------------------------- +-} + +instance Outputable CoreRule where + ppr = pprRule + +pprRules :: [CoreRule] -> SDoc +pprRules rules = vcat (map pprRule rules) + +pprRule :: CoreRule -> SDoc +pprRule (BuiltinRule { ru_fn = fn, ru_name = name}) + = text "Built in rule for" <+> ppr fn <> colon <+> doubleQuotes (ftext name) + +pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn, + ru_bndrs = tpl_vars, ru_args = tpl_args, + ru_rhs = rhs }) + = hang (doubleQuotes (ftext name) <+> ppr act) + 4 (sep [text "forall" <+> + sep (map (pprCoreBinder LambdaBind) tpl_vars) <> dot, + nest 2 (ppr fn <+> sep (map pprArg tpl_args)), + nest 2 (text "=" <+> pprCoreExpr rhs) + ]) + +{- +----------------------------------------------------- +-- Tickish +----------------------------------------------------- +-} + +instance Outputable id => Outputable (Tickish id) where + ppr (HpcTick modl ix) = + hcat [text "hpc<", + ppr modl, comma, + ppr ix, + text ">"] + ppr (Breakpoint ix vars) = + hcat [text "break<", + ppr ix, + text ">", + parens (hcat (punctuate comma (map ppr vars)))] + ppr (ProfNote { profNoteCC = cc, + profNoteCount = tick, + profNoteScope = scope }) = + case (tick,scope) of + (True,True) -> hcat [text "scctick<", ppr cc, char '>'] + (True,False) -> hcat [text "tick<", ppr cc, char '>'] + _ -> hcat [text "scc<", ppr cc, char '>'] + ppr (SourceNote span _) = + hcat [ text "src<", pprUserRealSpan True span, char '>'] + diff --git a/compiler/deSugar/PmExpr.hs b/compiler/deSugar/PmExpr.hs new file mode 100644 --- /dev/null +++ b/compiler/deSugar/PmExpr.hs @@ -0,0 +1,466 @@ +{- +Author: George Karachalias + +Haskell expressions (as used by the pattern matching checker) and utilities. +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE ViewPatterns #-} + +module PmExpr ( + PmExpr(..), PmLit(..), SimpleEq, ComplexEq, toComplex, eqPmLit, + truePmExpr, falsePmExpr, isTruePmExpr, isFalsePmExpr, isNotPmExprOther, + lhsExprToPmExpr, hsExprToPmExpr, substComplexEq, filterComplex, + pprPmExprWithParens, runPmPprM + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import BasicTypes (SourceText) +import FastString (FastString, unpackFS) +import HsSyn +import Id +import Name +import NameSet +import DataCon +import ConLike +import TcType (isStringTy) +import TysWiredIn +import Outputable +import Util +import SrcLoc + +import Data.Maybe (mapMaybe) +import Data.List (groupBy, sortBy, nubBy) +import Control.Monad.Trans.State.Lazy + +{- +%************************************************************************ +%* * + Lifted Expressions +%* * +%************************************************************************ +-} + +{- Note [PmExprOther in PmExpr] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Since there is no plan to extend the (currently pretty naive) term oracle in +the near future, instead of playing with the verbose (HsExpr Id), we lift it to +PmExpr. All expressions the term oracle does not handle are wrapped by the +constructor PmExprOther. Note that we do not perform substitution in +PmExprOther. Because of this, we do not even print PmExprOther, since they may +refer to variables that are otherwise substituted away. +-} + +-- ---------------------------------------------------------------------------- +-- ** Types + +-- | Lifted expressions for pattern match checking. +data PmExpr = PmExprVar Name + | PmExprCon ConLike [PmExpr] + | PmExprLit PmLit + | PmExprEq PmExpr PmExpr -- Syntactic equality + | PmExprOther (HsExpr GhcTc) -- Note [PmExprOther in PmExpr] + + +mkPmExprData :: DataCon -> [PmExpr] -> PmExpr +mkPmExprData dc args = PmExprCon (RealDataCon dc) args + +-- | Literals (simple and overloaded ones) for pattern match checking. +data PmLit = PmSLit (HsLit GhcTc) -- simple + | PmOLit Bool {- is it negated? -} (HsOverLit GhcTc) -- overloaded + +-- | Equality between literals for pattern match checking. +eqPmLit :: PmLit -> PmLit -> Bool +eqPmLit (PmSLit l1) (PmSLit l2) = l1 == l2 +eqPmLit (PmOLit b1 l1) (PmOLit b2 l2) = b1 == b2 && l1 == l2 + -- See Note [Undecidable Equality for Overloaded Literals] +eqPmLit _ _ = False + +{- Note [Undecidable Equality for Overloaded Literals] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Equality on overloaded literals is undecidable in the general case. Consider +the following example: + + instance Num Bool where + ... + fromInteger 0 = False -- C-like representation of booleans + fromInteger _ = True + + f :: Bool -> () + f 1 = () -- Clause A + f 2 = () -- Clause B + +Clause B is redundant but to detect this, we should be able to solve the +constraint: False ~ (fromInteger 2 ~ fromInteger 1) which means that we +have to look through function `fromInteger`, whose implementation could +be anything. This poses difficulties for: + +1. The expressive power of the check. + We cannot expect a reasonable implementation of pattern matching to detect + that fromInteger 2 ~ fromInteger 1 is True, unless we unfold function + fromInteger. This puts termination at risk and is undecidable in the + general case. + +2. Performance. + Having an unresolved constraint False ~ (fromInteger 2 ~ fromInteger 1) + lying around could become expensive really fast. Ticket #11161 illustrates + how heavy use of overloaded literals can generate plenty of those + constraints, effectively undermining the term oracle's performance. + +3. Error nessages/Warnings. + What should our message for `f` above be? A reasonable approach would be + to issue: + + Pattern matches are (potentially) redundant: + f 2 = ... under the assumption that 1 == 2 + + but seems to complex and confusing for the user. + +We choose to treat overloaded literals that look different as different. The +impact of this is the following: + + * Redundancy checking is rather conservative, since it cannot see that clause + B above is redundant. + + * We have instant equality check for overloaded literals (we do not rely on + the term oracle which is rather expensive, both in terms of performance and + memory). This significantly improves the performance of functions `covered` + `uncovered` and `divergent` in deSugar/Check.hs and effectively addresses + #11161. + + * The warnings issued are simpler. + + * We do not play on the safe side, strictly speaking. The assumption that + 1 /= 2 makes the redundancy check more conservative but at the same time + makes its dual (exhaustiveness check) unsafe. This we can live with, mainly + for two reasons: + 1. At the moment we do not use the results of the check during compilation + where this would be a disaster (could result in runtime errors even if + our function was deemed exhaustive). + 2. Pattern matcing on literals can never be considered exhaustive unless we + have a catch-all clause. Hence, this assumption affects mainly the + appearance of the warnings and is, in practice safe. +-} + +nubPmLit :: [PmLit] -> [PmLit] +nubPmLit = nubBy eqPmLit + +-- | Term equalities +type SimpleEq = (Id, PmExpr) -- We always use this orientation +type ComplexEq = (PmExpr, PmExpr) + +-- | Lift a `SimpleEq` to a `ComplexEq` +toComplex :: SimpleEq -> ComplexEq +toComplex (x,e) = (PmExprVar (idName x), e) + +-- | Expression `True' +truePmExpr :: PmExpr +truePmExpr = mkPmExprData trueDataCon [] + +-- | Expression `False' +falsePmExpr :: PmExpr +falsePmExpr = mkPmExprData falseDataCon [] + +-- ---------------------------------------------------------------------------- +-- ** Predicates on PmExpr + +-- | Check if an expression is lifted or not +isNotPmExprOther :: PmExpr -> Bool +isNotPmExprOther (PmExprOther _) = False +isNotPmExprOther _expr = True + +-- | Check whether a literal is negated +isNegatedPmLit :: PmLit -> Bool +isNegatedPmLit (PmOLit b _) = b +isNegatedPmLit _other_lit = False + +-- | Check whether a PmExpr is syntactically equal to term `True'. +isTruePmExpr :: PmExpr -> Bool +isTruePmExpr (PmExprCon c []) = c == RealDataCon trueDataCon +isTruePmExpr _other_expr = False + +-- | Check whether a PmExpr is syntactically equal to term `False'. +isFalsePmExpr :: PmExpr -> Bool +isFalsePmExpr (PmExprCon c []) = c == RealDataCon falseDataCon +isFalsePmExpr _other_expr = False + +-- | Check whether a PmExpr is syntactically e +isNilPmExpr :: PmExpr -> Bool +isNilPmExpr (PmExprCon c _) = c == RealDataCon nilDataCon +isNilPmExpr _other_expr = False + +-- | Check whether a PmExpr is syntactically equal to (x == y). +-- Since (==) is overloaded and can have an arbitrary implementation, we use +-- the PmExprEq constructor to represent only equalities with non-overloaded +-- literals where it coincides with a syntactic equality check. +isPmExprEq :: PmExpr -> Maybe (PmExpr, PmExpr) +isPmExprEq (PmExprEq e1 e2) = Just (e1,e2) +isPmExprEq _other_expr = Nothing + +-- | Check if a DataCon is (:). +isConsDataCon :: DataCon -> Bool +isConsDataCon con = consDataCon == con + +-- ---------------------------------------------------------------------------- +-- ** Substitution in PmExpr + +-- | We return a boolean along with the expression. Hence, if substitution was +-- a no-op, we know that the expression still cannot progress. +substPmExpr :: Name -> PmExpr -> PmExpr -> (PmExpr, Bool) +substPmExpr x e1 e = + case e of + PmExprVar z | x == z -> (e1, True) + | otherwise -> (e, False) + PmExprCon c ps -> let (ps', bs) = mapAndUnzip (substPmExpr x e1) ps + in (PmExprCon c ps', or bs) + PmExprEq ex ey -> let (ex', bx) = substPmExpr x e1 ex + (ey', by) = substPmExpr x e1 ey + in (PmExprEq ex' ey', bx || by) + _other_expr -> (e, False) -- The rest are terminals (We silently ignore + -- Other). See Note [PmExprOther in PmExpr] + +-- | Substitute in a complex equality. We return (Left eq) if the substitution +-- affected the equality or (Right eq) if nothing happened. +substComplexEq :: Name -> PmExpr -> ComplexEq -> Either ComplexEq ComplexEq +substComplexEq x e (ex, ey) + | bx || by = Left (ex', ey') + | otherwise = Right (ex', ey') + where + (ex', bx) = substPmExpr x e ex + (ey', by) = substPmExpr x e ey + +-- ----------------------------------------------------------------------- +-- ** Lift source expressions (HsExpr Id) to PmExpr + +lhsExprToPmExpr :: LHsExpr GhcTc -> PmExpr +lhsExprToPmExpr (dL->L _ e) = hsExprToPmExpr e + +hsExprToPmExpr :: HsExpr GhcTc -> PmExpr + +hsExprToPmExpr (HsVar _ x) = PmExprVar (idName (unLoc x)) +hsExprToPmExpr (HsConLikeOut _ c) = PmExprVar (conLikeName c) + +-- Desugar literal strings as a list of characters. For other literal values, +-- keep it as it is. +-- See `translatePat` in Check.hs (the `NPat` and `LitPat` case), and +-- Note [Translate Overloaded Literal for Exhaustiveness Checking]. +hsExprToPmExpr (HsOverLit _ olit) + | OverLit (OverLitTc False ty) (HsIsString src s) _ <- olit, isStringTy ty + = stringExprToList src s + | otherwise = PmExprLit (PmOLit False olit) +hsExprToPmExpr (HsLit _ lit) + | HsString src s <- lit + = stringExprToList src s + | otherwise = PmExprLit (PmSLit lit) + +hsExprToPmExpr e@(NegApp _ (dL->L _ neg_expr) _) + | PmExprLit (PmOLit False olit) <- hsExprToPmExpr neg_expr + -- NB: DON'T simply @(NegApp (NegApp olit))@ as @x@. when extension + -- @RebindableSyntax@ enabled, (-(-x)) may not equals to x. + = PmExprLit (PmOLit True olit) + | otherwise = PmExprOther e + +hsExprToPmExpr (HsPar _ (dL->L _ e)) = hsExprToPmExpr e + +hsExprToPmExpr e@(ExplicitTuple _ ps boxity) + | all tupArgPresent ps = mkPmExprData tuple_con tuple_args + | otherwise = PmExprOther e + where + tuple_con = tupleDataCon boxity (length ps) + tuple_args = [ lhsExprToPmExpr e | (dL->L _ (Present _ e)) <- ps ] + +hsExprToPmExpr e@(ExplicitList _ mb_ol elems) + | Nothing <- mb_ol = foldr cons nil (map lhsExprToPmExpr elems) + | otherwise = PmExprOther e {- overloaded list: No PmExprApp -} + where + cons x xs = mkPmExprData consDataCon [x,xs] + nil = mkPmExprData nilDataCon [] + +-- we want this but we would have to make everything monadic :/ +-- ./compiler/deSugar/DsMonad.hs:397:dsLookupDataCon :: Name -> DsM DataCon +-- +-- hsExprToPmExpr (RecordCon c _ binds) = do +-- con <- dsLookupDataCon (unLoc c) +-- args <- mapM lhsExprToPmExpr (hsRecFieldsArgs binds) +-- return (PmExprCon con args) +hsExprToPmExpr e@(RecordCon {}) = PmExprOther e + +hsExprToPmExpr (HsTick _ _ e) = lhsExprToPmExpr e +hsExprToPmExpr (HsBinTick _ _ _ e) = lhsExprToPmExpr e +hsExprToPmExpr (HsTickPragma _ _ _ _ e) = lhsExprToPmExpr e +hsExprToPmExpr (HsSCC _ _ _ e) = lhsExprToPmExpr e +hsExprToPmExpr (HsCoreAnn _ _ _ e) = lhsExprToPmExpr e +hsExprToPmExpr (ExprWithTySig _ e _) = lhsExprToPmExpr e +hsExprToPmExpr (HsWrap _ _ e) = hsExprToPmExpr e +hsExprToPmExpr e = PmExprOther e -- the rest are not handled by the oracle + +stringExprToList :: SourceText -> FastString -> PmExpr +stringExprToList src s = foldr cons nil (map charToPmExpr (unpackFS s)) + where + cons x xs = mkPmExprData consDataCon [x,xs] + nil = mkPmExprData nilDataCon [] + charToPmExpr c = PmExprLit (PmSLit (HsChar src c)) + +{- +%************************************************************************ +%* * + Pretty printing +%* * +%************************************************************************ +-} + +{- 1. Literals +~~~~~~~~~~~~~~ +Starting with a function definition like: + + f :: Int -> Bool + f 5 = True + f 6 = True + +The uncovered set looks like: + { var |> False == (var == 5), False == (var == 6) } + +Yet, we would like to print this nicely as follows: + x , where x not one of {5,6} + +Function `filterComplex' takes the set of residual constraints and packs +together the negative constraints that refer to the same variable so we can do +just this. Since these variables will be shown to the programmer, we also give +them better names (t1, t2, ..), hence the SDoc in PmNegLitCt. + +2. Residual Constraints +~~~~~~~~~~~~~~~~~~~~~~~ +Unhandled constraints that refer to HsExpr are typically ignored by the solver +(it does not even substitute in HsExpr so they are even printed as wildcards). +Additionally, the oracle returns a substitution if it succeeds so we apply this +substitution to the vectors before printing them out (see function `pprOne' in +Check.hs) to be more precice. +-} + +-- ----------------------------------------------------------------------------- +-- ** Transform residual constraints in appropriate form for pretty printing + +type PmNegLitCt = (Name, (SDoc, [PmLit])) + +filterComplex :: [ComplexEq] -> [PmNegLitCt] +filterComplex = zipWith rename nameList . map mkGroup + . groupBy name . sortBy order . mapMaybe isNegLitCs + where + order x y = compare (fst x) (fst y) + name x y = fst x == fst y + mkGroup l = (fst (head l), nubPmLit $ map snd l) + rename new (old, lits) = (old, (new, lits)) + + isNegLitCs (e1,e2) + | isFalsePmExpr e1, Just (x,y) <- isPmExprEq e2 = isNegLitCs' x y + | isFalsePmExpr e2, Just (x,y) <- isPmExprEq e1 = isNegLitCs' x y + | otherwise = Nothing + + isNegLitCs' (PmExprVar x) (PmExprLit l) = Just (x, l) + isNegLitCs' (PmExprLit l) (PmExprVar x) = Just (x, l) + isNegLitCs' _ _ = Nothing + + -- 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)..] ] + +-- ---------------------------------------------------------------------------- + +runPmPprM :: PmPprM a -> [PmNegLitCt] -> (a, [(SDoc,[PmLit])]) +runPmPprM m lit_env = (result, mapMaybe is_used lit_env) + where + (result, (_lit_env, used)) = runState m (lit_env, emptyNameSet) + + is_used (x,(name, lits)) + | elemNameSet x used = Just (name, lits) + | otherwise = Nothing + +type PmPprM a = State ([PmNegLitCt], NameSet) a +-- (the first part of the state is read only. make it a reader?) + +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 lookup x negated of + Just (new, _) -> Just new + Nothing -> Nothing + +-- | 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 (PmExprEq _ _) = return underscore -- don't show +pprPmExpr (PmExprOther _) = return underscore -- don't show + +needsParens :: PmExpr -> Bool +needsParens (PmExprVar {}) = False +needsParens (PmExprLit l) = isNegatedPmLit l +needsParens (PmExprEq {}) = False -- will become a wildcard +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) + +pprPmExprWithParens :: PmExpr -> PmPprM SDoc +pprPmExprWithParens expr + | needsParens expr = parens <$> pprPmExpr expr + | otherwise = pprPmExpr expr + +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 + + -- 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 + + list = list_elements 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 + | conLikeIsInfix cl = case args of + [x, y] -> do x' <- pprPmExprWithParens x + y' <- pprPmExprWithParens y + return (x' <+> ppr cl <+> y') + -- can it be infix but have more than two arguments? + list -> pprPanic "pprPmExprCon:" (ppr list) + | null args = return (ppr cl) + | otherwise = do args' <- mapM pprPmExprWithParens args + return (fsep (ppr cl : args')) + +instance Outputable PmLit where + ppr (PmSLit l) = pmPprHsLit l + ppr (PmOLit neg l) = (if neg then char '-' else empty) <> ppr l + +-- not really useful for pmexprs per se +instance Outputable PmExpr where + ppr e = fst $ runPmPprM (pprPmExpr e) [] diff --git a/compiler/ghci/ByteCodeTypes.hs b/compiler/ghci/ByteCodeTypes.hs new file mode 100644 --- /dev/null +++ b/compiler/ghci/ByteCodeTypes.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE MagicHash, RecordWildCards, GeneralizedNewtypeDeriving #-} +-- +-- (c) The University of Glasgow 2002-2006 +-- + +-- | Bytecode assembler types +module ByteCodeTypes + ( CompiledByteCode(..), seqCompiledByteCode, FFIInfo(..) + , UnlinkedBCO(..), BCOPtr(..), BCONPtr(..) + , ItblEnv, ItblPtr(..) + , CgBreakInfo(..) + , ModBreaks (..), BreakIndex, emptyModBreaks + , CCostCentre + ) where + +import GhcPrelude + +import FastString +import Id +import Name +import NameEnv +import Outputable +import PrimOp +import SizedSeq +import Type +import SrcLoc +import GHCi.BreakArray +import GHCi.RemoteTypes +import GHCi.FFI +import Control.DeepSeq + +import Foreign +import Data.Array +import Data.Array.Base ( UArray(..) ) +import Data.ByteString (ByteString) +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import GHC.Exts.Heap +import GHC.Stack.CCS + +-- ----------------------------------------------------------------------------- +-- Compiled Byte Code + +data CompiledByteCode = CompiledByteCode + { bc_bcos :: [UnlinkedBCO] -- Bunch of interpretable bindings + , bc_itbls :: ItblEnv -- A mapping from DataCons to their itbls + , bc_ffis :: [FFIInfo] -- ffi blocks we allocated + , bc_strs :: [RemotePtr ()] -- malloc'd strings + , bc_breaks :: Maybe ModBreaks -- breakpoint info (Nothing if we're not + -- creating breakpoints, for some reason) + } + -- ToDo: we're not tracking strings that we malloc'd +newtype FFIInfo = FFIInfo (RemotePtr C_ffi_cif) + deriving (Show, NFData) + +instance Outputable CompiledByteCode where + ppr CompiledByteCode{..} = ppr bc_bcos + +-- Not a real NFData instance, because ModBreaks contains some things +-- we can't rnf +seqCompiledByteCode :: CompiledByteCode -> () +seqCompiledByteCode CompiledByteCode{..} = + rnf bc_bcos `seq` + rnf (nameEnvElts bc_itbls) `seq` + rnf bc_ffis `seq` + rnf bc_strs `seq` + rnf (fmap seqModBreaks bc_breaks) + +type ItblEnv = NameEnv (Name, ItblPtr) + -- We need the Name in the range so we know which + -- elements to filter out when unloading a module + +newtype ItblPtr = ItblPtr (RemotePtr StgInfoTable) + deriving (Show, NFData) + +data UnlinkedBCO + = UnlinkedBCO { + unlinkedBCOName :: !Name, + unlinkedBCOArity :: {-# UNPACK #-} !Int, + unlinkedBCOInstrs :: !(UArray Int Word16), -- insns + unlinkedBCOBitmap :: !(UArray Int Word64), -- bitmap + unlinkedBCOLits :: !(SizedSeq BCONPtr), -- non-ptrs + unlinkedBCOPtrs :: !(SizedSeq BCOPtr) -- ptrs + } + +instance NFData UnlinkedBCO where + rnf UnlinkedBCO{..} = + rnf unlinkedBCOLits `seq` + rnf unlinkedBCOPtrs + +data BCOPtr + = BCOPtrName !Name + | BCOPtrPrimOp !PrimOp + | BCOPtrBCO !UnlinkedBCO + | BCOPtrBreakArray -- a pointer to this module's BreakArray + +instance NFData BCOPtr where + rnf (BCOPtrBCO bco) = rnf bco + rnf x = x `seq` () + +data BCONPtr + = BCONPtrWord {-# UNPACK #-} !Word + | BCONPtrLbl !FastString + | BCONPtrItbl !Name + | BCONPtrStr !ByteString + +instance NFData BCONPtr where + rnf x = x `seq` () + +-- | Information about a breakpoint that we know at code-generation time +data CgBreakInfo + = CgBreakInfo + { cgb_vars :: [(Id,Word16)] + , cgb_resty :: Type + } + +-- Not a real NFData instance because we can't rnf Id or Type +seqCgBreakInfo :: CgBreakInfo -> () +seqCgBreakInfo CgBreakInfo{..} = + rnf (map snd cgb_vars) `seq` + seqType cgb_resty + +instance Outputable UnlinkedBCO where + ppr (UnlinkedBCO nm _arity _insns _bitmap lits ptrs) + = sep [text "BCO", ppr nm, text "with", + ppr (sizeSS lits), text "lits", + ppr (sizeSS ptrs), text "ptrs" ] + +instance Outputable CgBreakInfo where + ppr info = text "CgBreakInfo" <+> + parens (ppr (cgb_vars info) <+> + ppr (cgb_resty info)) + +-- ----------------------------------------------------------------------------- +-- Breakpoints + +-- | Breakpoint index +type BreakIndex = Int + +-- | C CostCentre type +data CCostCentre + +-- | All the information about the breakpoints for a module +data ModBreaks + = ModBreaks + { modBreaks_flags :: ForeignRef BreakArray + -- ^ The array of flags, one per breakpoint, + -- indicating which breakpoints are enabled. + , modBreaks_locs :: !(Array BreakIndex SrcSpan) + -- ^ An array giving the source span of each breakpoint. + , modBreaks_vars :: !(Array BreakIndex [OccName]) + -- ^ An array giving the names of the free variables at each breakpoint. + , modBreaks_decls :: !(Array BreakIndex [String]) + -- ^ An array giving the names of the declarations enclosing each breakpoint. + , modBreaks_ccs :: !(Array BreakIndex (RemotePtr CostCentre)) + -- ^ Array pointing to cost centre for each breakpoint + , modBreaks_breakInfo :: IntMap CgBreakInfo + -- ^ info about each breakpoint from the bytecode generator + } + +seqModBreaks :: ModBreaks -> () +seqModBreaks ModBreaks{..} = + rnf modBreaks_flags `seq` + rnf modBreaks_locs `seq` + rnf modBreaks_vars `seq` + rnf modBreaks_decls `seq` + rnf modBreaks_ccs `seq` + rnf (fmap seqCgBreakInfo modBreaks_breakInfo) + +-- | Construct an empty ModBreaks +emptyModBreaks :: ModBreaks +emptyModBreaks = ModBreaks + { modBreaks_flags = error "ModBreaks.modBreaks_array not initialised" + -- ToDo: can we avoid this? + , modBreaks_locs = array (0,-1) [] + , modBreaks_vars = array (0,-1) [] + , modBreaks_decls = array (0,-1) [] + , modBreaks_ccs = array (0,-1) [] + , modBreaks_breakInfo = IntMap.empty + } diff --git a/compiler/ghci/keepCAFsForGHCi.c b/compiler/ghci/keepCAFsForGHCi.c new file mode 100644 --- /dev/null +++ b/compiler/ghci/keepCAFsForGHCi.c @@ -0,0 +1,15 @@ +#include "Rts.h" + +// This file is only included in the dynamic library. +// It contains an __attribute__((constructor)) function (run prior to main()) +// which sets the keepCAFs flag in the RTS, before any Haskell code is run. +// This is required so that GHCi can use dynamic libraries instead of HSxyz.o +// files. + +static void keepCAFsForGHCi(void) __attribute__((constructor)); + +static void keepCAFsForGHCi(void) +{ + keepCAFs = 1; +} + diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs new file mode 100644 --- /dev/null +++ b/compiler/hsSyn/HsBinds.hs @@ -0,0 +1,1316 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[HsBinds]{Abstract syntax: top-level bindings and signatures} + +Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@. +-} + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] + -- in module PlaceHolder +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeFamilies #-} + +module HsBinds where + +import GhcPrelude + +import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr, + MatchGroup, pprFunBind, + GRHSs, pprPatBind ) +import {-# SOURCE #-} HsPat ( LPat ) + +import HsExtension +import HsTypes +import PprCore () +import CoreSyn +import TcEvidence +import Type +import NameSet +import BasicTypes +import Outputable +import SrcLoc +import Var +import Bag +import FastString +import BooleanFormula (LBooleanFormula) +import DynFlags + +import Data.Data hiding ( Fixity ) +import Data.List hiding ( foldr ) +import Data.Ord + +{- +************************************************************************ +* * +\subsection{Bindings: @BindGroup@} +* * +************************************************************************ + +Global bindings (where clauses) +-} + +-- During renaming, we need bindings where the left-hand sides +-- have been renamed but the right-hand sides have not. +-- the ...LR datatypes are parametrized by two id types, +-- one for the left and one for the right. +-- Other than during renaming, these will be the same. + +-- | Haskell Local Bindings +type HsLocalBinds id = HsLocalBindsLR id id + +-- | Located Haskell local bindings +type LHsLocalBinds id = Located (HsLocalBinds id) + +-- | Haskell Local Bindings with separate Left and Right identifier types +-- +-- Bindings in a 'let' expression +-- or a 'where' clause +data HsLocalBindsLR idL idR + = HsValBinds + (XHsValBinds idL idR) + (HsValBindsLR idL idR) + -- ^ Haskell Value Bindings + + -- There should be no pattern synonyms in the HsValBindsLR + -- These are *local* (not top level) bindings + -- The parser accepts them, however, leaving the + -- renamer to report them + + | HsIPBinds + (XHsIPBinds idL idR) + (HsIPBinds idR) + -- ^ Haskell Implicit Parameter Bindings + + | EmptyLocalBinds (XEmptyLocalBinds idL idR) + -- ^ Empty Local Bindings + + | XHsLocalBindsLR + (XXHsLocalBindsLR idL idR) + +type instance XHsValBinds (GhcPass pL) (GhcPass pR) = NoExt +type instance XHsIPBinds (GhcPass pL) (GhcPass pR) = NoExt +type instance XEmptyLocalBinds (GhcPass pL) (GhcPass pR) = NoExt +type instance XXHsLocalBindsLR (GhcPass pL) (GhcPass pR) = NoExt + +type LHsLocalBindsLR idL idR = Located (HsLocalBindsLR idL idR) + + +-- | Haskell Value Bindings +type HsValBinds id = HsValBindsLR id id + +-- | Haskell Value bindings with separate Left and Right identifier types +-- (not implicit parameters) +-- Used for both top level and nested bindings +-- May contain pattern synonym bindings +data HsValBindsLR idL idR + = -- | Value Bindings In + -- + -- Before renaming RHS; idR is always RdrName + -- Not dependency analysed + -- Recursive by default + ValBinds + (XValBinds idL idR) + (LHsBindsLR idL idR) [LSig idR] + + -- | Value Bindings Out + -- + -- After renaming RHS; idR can be Name or Id Dependency analysed, + -- later bindings in the list may depend on earlier ones. + | XValBindsLR + (XXValBindsLR idL idR) + +-- --------------------------------------------------------------------- +-- Deal with ValBindsOut + +-- TODO: make this the only type for ValBinds +data NHsValBindsLR idL + = NValBinds + [(RecFlag, LHsBinds idL)] + [LSig GhcRn] + +type instance XValBinds (GhcPass pL) (GhcPass pR) = NoExt +type instance XXValBindsLR (GhcPass pL) (GhcPass pR) + = NHsValBindsLR (GhcPass pL) + +-- --------------------------------------------------------------------- + +-- | Located Haskell Binding +type LHsBind id = LHsBindLR id id + +-- | Located Haskell Bindings +type LHsBinds id = LHsBindsLR id id + +-- | Haskell Binding +type HsBind id = HsBindLR id id + +-- | Located Haskell Bindings with separate Left and Right identifier types +type LHsBindsLR idL idR = Bag (LHsBindLR idL idR) + +-- | Located Haskell Binding with separate Left and Right identifier types +type LHsBindLR idL idR = Located (HsBindLR idL idR) + +{- Note [FunBind vs PatBind] + ~~~~~~~~~~~~~~~~~~~~~~~~~ +The distinction between FunBind and PatBind is a bit subtle. FunBind covers +patterns which resemble function bindings and simple variable bindings. + + f x = e + f !x = e + f = e + !x = e -- FunRhs has SrcStrict + x `f` y = e -- FunRhs has Infix + +The actual patterns and RHSs of a FunBind are encoding in fun_matches. +The m_ctxt field of each Match in fun_matches will be FunRhs and carries +two bits of information about the match, + + * The mc_fixity field on each Match describes the fixity of the + function binder in that match. E.g. this is legal: + f True False = e1 + True `f` True = e2 + + * The mc_strictness field is used /only/ for nullary FunBinds: ones + with one Match, which has no pats. For these, it describes whether + the match is decorated with a bang (e.g. `!x = e`). + +By contrast, PatBind represents data constructor patterns, as well as a few +other interesting cases. Namely, + + Just x = e + (x) = e + x :: Ty = e +-} + +-- | Haskell Binding with separate Left and Right id's +data HsBindLR idL idR + = -- | Function-like Binding + -- + -- FunBind is used for both functions @f x = e@ + -- and variables @f = \x -> e@ + -- and strict variables @!x = x + 1@ + -- + -- Reason 1: Special case for type inference: see 'TcBinds.tcMonoBinds'. + -- + -- Reason 2: Instance decls can only have FunBinds, which is convenient. + -- If you change this, you'll need to change e.g. rnMethodBinds + -- + -- But note that the form @f :: a->a = ...@ + -- parses as a pattern binding, just like + -- @(f :: a -> a) = ... @ + -- + -- Strict bindings have their strictness recorded in the 'SrcStrictness' of their + -- 'MatchContext'. See Note [FunBind vs PatBind] for + -- details about the relationship between FunBind and PatBind. + -- + -- 'ApiAnnotation.AnnKeywordId's + -- + -- - 'ApiAnnotation.AnnFunId', attached to each element of fun_matches + -- + -- - 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere', + -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose', + + -- For details on above see note [Api annotations] in ApiAnnotation + FunBind { + + fun_ext :: XFunBind idL idR, -- ^ After the renamer, this contains + -- the locally-bound + -- free variables of this defn. + -- See Note [Bind free vars] + + fun_id :: Located (IdP idL), -- Note [fun_id in Match] in HsExpr + + fun_matches :: MatchGroup idR (LHsExpr idR), -- ^ The payload + + fun_co_fn :: HsWrapper, -- ^ Coercion from the type of the MatchGroup to the type of + -- the Id. Example: + -- + -- @ + -- f :: Int -> forall a. a -> a + -- f x y = y + -- @ + -- + -- Then the MatchGroup will have type (Int -> a' -> a') + -- (with a free type variable a'). The coercion will take + -- a CoreExpr of this type and convert it to a CoreExpr of + -- type Int -> forall a'. a' -> a' + -- Notice that the coercion captures the free a'. + + fun_tick :: [Tickish Id] -- ^ Ticks to put on the rhs, if any + } + + -- | Pattern Binding + -- + -- The pattern is never a simple variable; + -- That case is done by FunBind. + -- See Note [FunBind vs PatBind] for details about the + -- relationship between FunBind and PatBind. + + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang', + -- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere', + -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose', + + -- For details on above see note [Api annotations] in ApiAnnotation + | PatBind { + pat_ext :: XPatBind idL idR, -- ^ See Note [Bind free vars] + pat_lhs :: LPat idL, + pat_rhs :: GRHSs idR (LHsExpr idR), + pat_ticks :: ([Tickish Id], [[Tickish Id]]) + -- ^ Ticks to put on the rhs, if any, and ticks to put on + -- the bound variables. + } + + -- | Variable Binding + -- + -- Dictionary binding and suchlike. + -- All VarBinds are introduced by the type checker + | VarBind { + var_ext :: XVarBind idL idR, + var_id :: IdP idL, + var_rhs :: LHsExpr idR, -- ^ Located only for consistency + var_inline :: Bool -- ^ True <=> inline this binding regardless + -- (used for implication constraints only) + } + + -- | Abstraction Bindings + | AbsBinds { -- Binds abstraction; TRANSLATION + abs_ext :: XAbsBinds idL idR, + abs_tvs :: [TyVar], + abs_ev_vars :: [EvVar], -- ^ Includes equality constraints + + -- | AbsBinds only gets used when idL = idR after renaming, + -- but these need to be idL's for the collect... code in HsUtil + -- to have the right type + abs_exports :: [ABExport idL], + + -- | Evidence bindings + -- Why a list? See TcInstDcls + -- Note [Typechecking plan for instance declarations] + abs_ev_binds :: [TcEvBinds], + + -- | Typechecked user bindings + abs_binds :: LHsBinds idL, + + abs_sig :: Bool -- See Note [The abs_sig field of AbsBinds] + } + + -- | Patterns Synonym Binding + | PatSynBind + (XPatSynBind idL idR) + (PatSynBind idL idR) + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern', + -- 'ApiAnnotation.AnnLarrow','ApiAnnotation.AnnEqual', + -- 'ApiAnnotation.AnnWhere' + -- 'ApiAnnotation.AnnOpen' @'{'@,'ApiAnnotation.AnnClose' @'}'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + + | XHsBindsLR (XXHsBindsLR idL idR) + +data NPatBindTc = NPatBindTc { + pat_fvs :: NameSet, -- ^ Free variables + pat_rhs_ty :: Type -- ^ Type of the GRHSs + } deriving Data + +type instance XFunBind (GhcPass pL) GhcPs = NoExt +type instance XFunBind (GhcPass pL) GhcRn = NameSet -- Free variables +type instance XFunBind (GhcPass pL) GhcTc = NameSet -- Free variables + +type instance XPatBind GhcPs (GhcPass pR) = NoExt +type instance XPatBind GhcRn (GhcPass pR) = NameSet -- Free variables +type instance XPatBind GhcTc (GhcPass pR) = NPatBindTc + +type instance XVarBind (GhcPass pL) (GhcPass pR) = NoExt +type instance XAbsBinds (GhcPass pL) (GhcPass pR) = NoExt +type instance XPatSynBind (GhcPass pL) (GhcPass pR) = NoExt +type instance XXHsBindsLR (GhcPass pL) (GhcPass pR) = NoExt + + + -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds] + -- + -- Creates bindings for (polymorphic, overloaded) poly_f + -- in terms of monomorphic, non-overloaded mono_f + -- + -- Invariants: + -- 1. 'binds' binds mono_f + -- 2. ftvs is a subset of tvs + -- 3. ftvs includes all tyvars free in ds + -- + -- See Note [AbsBinds] + +-- | Abtraction Bindings Export +data ABExport p + = ABE { abe_ext :: XABE p + , abe_poly :: IdP p -- ^ Any INLINE pragma is attached to this Id + , abe_mono :: IdP p + , abe_wrap :: HsWrapper -- ^ See Note [ABExport wrapper] + -- Shape: (forall abs_tvs. abs_ev_vars => abe_mono) ~ abe_poly + , abe_prags :: TcSpecPrags -- ^ SPECIALISE pragmas + } + | XABExport (XXABExport p) + +type instance XABE (GhcPass p) = NoExt +type instance XXABExport (GhcPass p) = NoExt + + +-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern', +-- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnLarrow' +-- 'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen' @'{'@, +-- 'ApiAnnotation.AnnClose' @'}'@, + +-- For details on above see note [Api annotations] in ApiAnnotation + +-- | Pattern Synonym binding +data PatSynBind idL idR + = PSB { psb_ext :: XPSB idL idR, -- ^ Post renaming, FVs. + -- See Note [Bind free vars] + psb_id :: Located (IdP idL), -- ^ Name of the pattern synonym + psb_args :: HsPatSynDetails (Located (IdP idR)), + -- ^ Formal parameter names + psb_def :: LPat idR, -- ^ Right-hand side + psb_dir :: HsPatSynDir idR -- ^ Directionality + } + | XPatSynBind (XXPatSynBind idL idR) + +type instance XPSB (GhcPass idL) GhcPs = NoExt +type instance XPSB (GhcPass idL) GhcRn = NameSet +type instance XPSB (GhcPass idL) GhcTc = NameSet + +type instance XXPatSynBind (GhcPass idL) (GhcPass idR) = NoExt + +{- +Note [AbsBinds] +~~~~~~~~~~~~~~~ +The AbsBinds constructor is used in the output of the type checker, to +record *typechecked* and *generalised* bindings. Specifically + + AbsBinds { abs_tvs = tvs + , abs_ev_vars = [d1,d2] + , abs_exports = [ABE { abe_poly = fp, abe_mono = fm + , abe_wrap = fwrap } + ABE { slly for g } ] + , abs_ev_binds = DBINDS + , abs_binds = BIND[fm,gm] } + +where 'BIND' binds the monomorphic Ids 'fm' and 'gm', means + + fp = fwrap [/\ tvs. \d1 d2. letrec { DBINDS ] + [ ; BIND[fm,gm] } ] + [ in fm ] + + gp = ...same again, with gm instead of fm + +The 'fwrap' is an impedence-matcher that typically does nothing; see +Note [ABExport wrapper]. + +This is a pretty bad translation, because it duplicates all the bindings. +So the desugarer tries to do a better job: + + fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of + (fm,gm) -> fm + ..ditto for gp.. + + tp = /\ [a,b] -> \ [d1,d2] -> letrec { DBINDS; BIND } + in (fm,gm) + +In general: + + * abs_tvs are the type variables over which the binding group is + generalised + * abs_ev_var are the evidence variables (usually dictionaries) + over which the binding group is generalised + * abs_binds are the monomorphic bindings + * abs_ex_binds are the evidence bindings that wrap the abs_binds + * abs_exports connects the monomorphic Ids bound by abs_binds + with the polymorphic Ids bound by the AbsBinds itself. + +For example, consider a module M, with this top-level binding, where +there is no type signature for M.reverse, + M.reverse [] = [] + M.reverse (x:xs) = M.reverse xs ++ [x] + +In Hindley-Milner, a recursive binding is typechecked with the +*recursive* uses being *monomorphic*. So after typechecking *and* +desugaring we will get something like this + + M.reverse :: forall a. [a] -> [a] + = /\a. letrec + reverse :: [a] -> [a] = \xs -> case xs of + [] -> [] + (x:xs) -> reverse xs ++ [x] + in reverse + +Notice that 'M.reverse' is polymorphic as expected, but there is a local +definition for plain 'reverse' which is *monomorphic*. The type variable +'a' scopes over the entire letrec. + +That's after desugaring. What about after type checking but before +desugaring? That's where AbsBinds comes in. It looks like this: + + AbsBinds { abs_tvs = [a] + , abs_ev_vars = [] + , abs_exports = [ABE { abe_poly = M.reverse :: forall a. [a] -> [a], + , abe_mono = reverse :: [a] -> [a]}] + , abs_ev_binds = {} + , abs_binds = { reverse :: [a] -> [a] + = \xs -> case xs of + [] -> [] + (x:xs) -> reverse xs ++ [x] } } + +Here, + + * abs_tvs says what type variables are abstracted over the binding + group, just 'a' in this case. + * abs_binds is the *monomorphic* bindings of the group + * abs_exports describes how to get the polymorphic Id 'M.reverse' + from the monomorphic one 'reverse' + +Notice that the *original* function (the polymorphic one you thought +you were defining) appears in the abe_poly field of the +abs_exports. The bindings in abs_binds are for fresh, local, Ids with +a *monomorphic* Id. + +If there is a group of mutually recursive (see Note [Polymorphic +recursion]) functions without type signatures, we get one AbsBinds +with the monomorphic versions of the bindings in abs_binds, and one +element of abe_exports for each variable bound in the mutually +recursive group. This is true even for pattern bindings. Example: + (f,g) = (\x -> x, f) +After type checking we get + AbsBinds { abs_tvs = [a] + , abs_exports = [ ABE { abe_poly = M.f :: forall a. a -> a + , abe_mono = f :: a -> a } + , ABE { abe_poly = M.g :: forall a. a -> a + , abe_mono = g :: a -> a }] + , abs_binds = { (f,g) = (\x -> x, f) } + +Note [Polymorphic recursion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + Rec { f x = ...(g ef)... + + ; g :: forall a. [a] -> [a] + ; g y = ...(f eg)... } + +These bindings /are/ mutually recursive (f calls g, and g calls f). +But we can use the type signature for g to break the recursion, +like this: + + 1. Add g :: forall a. [a] -> [a] to the type environment + + 2. Typecheck the definition of f, all by itself, + including generalising it to find its most general + type, say f :: forall b. b -> b -> [b] + + 3. Extend the type environment with that type for f + + 4. Typecheck the definition of g, all by itself, + checking that it has the type claimed by its signature + +Steps 2 and 4 each generate a separate AbsBinds, so we end +up with + Rec { AbsBinds { ...for f ... } + ; AbsBinds { ...for g ... } } + +This approach allows both f and to call each other +polymorphically, even though only g has a signature. + +We get an AbsBinds that encompasses multiple source-program +bindings only when + * Each binding in the group has at least one binder that + lacks a user type signature + * The group forms a strongly connected component + + +Note [The abs_sig field of AbsBinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The abs_sig field supports a couple of special cases for bindings. +Consider + + x :: Num a => (# a, a #) + x = (# 3, 4 #) + +The general desugaring for AbsBinds would give + + x = /\a. \ ($dNum :: Num a) -> + letrec xm = (# fromInteger $dNum 3, fromInteger $dNum 4 #) in + xm + +But that has an illegal let-binding for an unboxed tuple. In this +case we'd prefer to generate the (more direct) + + x = /\ a. \ ($dNum :: Num a) -> + (# fromInteger $dNum 3, fromInteger $dNum 4 #) + +A similar thing happens with representation-polymorphic defns +(#11405): + + undef :: forall (r :: RuntimeRep) (a :: TYPE r). HasCallStack => a + undef = error "undef" + +Again, the vanilla desugaring gives a local let-binding for a +representation-polymorphic (undefm :: a), which is illegal. But +again we can desugar without a let: + + undef = /\ a. \ (d:HasCallStack) -> error a d "undef" + +The abs_sig field supports this direct desugaring, with no local +let-bining. When abs_sig = True + + * the abs_binds is single FunBind + + * the abs_exports is a singleton + + * we have a complete type sig for binder + and hence the abs_binds is non-recursive + (it binds the mono_id but refers to the poly_id + +These properties are exploited in DsBinds.dsAbsBinds to +generate code without a let-binding. + +Note [ABExport wrapper] +~~~~~~~~~~~~~~~~~~~~~~~ +Consider + (f,g) = (\x.x, \y.y) +This ultimately desugars to something like this: + tup :: forall a b. (a->a, b->b) + tup = /\a b. (\x:a.x, \y:b.y) + f :: forall a. a -> a + f = /\a. case tup a Any of + (fm::a->a,gm:Any->Any) -> fm + ...similarly for g... + +The abe_wrap field deals with impedance-matching between + (/\a b. case tup a b of { (f,g) -> f }) +and the thing we really want, which may have fewer type +variables. The action happens in TcBinds.mkExport. + +Note [Bind free vars] +~~~~~~~~~~~~~~~~~~~~~ +The bind_fvs field of FunBind and PatBind records the free variables +of the definition. It is used for the following purposes + +a) Dependency analysis prior to type checking + (see TcBinds.tc_group) + +b) Deciding whether we can do generalisation of the binding + (see TcBinds.decideGeneralisationPlan) + +c) Deciding whether the binding can be used in static forms + (see TcExpr.checkClosedInStaticForm for the HsStatic case and + TcBinds.isClosedBndrGroup). + +Specifically, + + * bind_fvs includes all free vars that are defined in this module + (including top-level things and lexically scoped type variables) + + * bind_fvs excludes imported vars; this is just to keep the set smaller + + * Before renaming, and after typechecking, the field is unused; + it's just an error thunk +-} + +instance (idL ~ GhcPass pl, idR ~ GhcPass pr, + OutputableBndrId idL, OutputableBndrId idR) + => Outputable (HsLocalBindsLR idL idR) where + ppr (HsValBinds _ bs) = ppr bs + ppr (HsIPBinds _ bs) = ppr bs + ppr (EmptyLocalBinds _) = empty + ppr (XHsLocalBindsLR x) = ppr x + +instance (idL ~ GhcPass pl, idR ~ GhcPass pr, + OutputableBndrId idL, OutputableBndrId idR) + => Outputable (HsValBindsLR idL idR) where + ppr (ValBinds _ binds sigs) + = pprDeclList (pprLHsBindsForUser binds sigs) + + ppr (XValBindsLR (NValBinds sccs sigs)) + = getPprStyle $ \ sty -> + if debugStyle sty then -- Print with sccs showing + vcat (map ppr sigs) $$ vcat (map ppr_scc sccs) + else + pprDeclList (pprLHsBindsForUser (unionManyBags (map snd sccs)) sigs) + where + ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds + pp_rec Recursive = text "rec" + pp_rec NonRecursive = text "nonrec" + +pprLHsBinds :: (OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR)) + => LHsBindsLR (GhcPass idL) (GhcPass idR) -> SDoc +pprLHsBinds binds + | isEmptyLHsBinds binds = empty + | otherwise = pprDeclList (map ppr (bagToList binds)) + +pprLHsBindsForUser :: (OutputableBndrId (GhcPass idL), + OutputableBndrId (GhcPass idR), + OutputableBndrId (GhcPass id2)) + => LHsBindsLR (GhcPass idL) (GhcPass idR) -> [LSig (GhcPass id2)] -> [SDoc] +-- pprLHsBindsForUser is different to pprLHsBinds because +-- a) No braces: 'let' and 'where' include a list of HsBindGroups +-- and we don't want several groups of bindings each +-- with braces around +-- b) Sort by location before printing +-- c) Include signatures +pprLHsBindsForUser binds sigs + = map snd (sort_by_loc decls) + where + + decls :: [(SrcSpan, SDoc)] + decls = [(loc, ppr sig) | L loc sig <- sigs] ++ + [(loc, ppr bind) | L loc bind <- bagToList binds] + + sort_by_loc decls = sortBy (comparing fst) decls + +pprDeclList :: [SDoc] -> SDoc -- Braces with a space +-- Print a bunch of declarations +-- One could choose { d1; d2; ... }, using 'sep' +-- or d1 +-- d2 +-- .. +-- using vcat +-- At the moment we chose the latter +-- Also we do the 'pprDeeperList' thing. +pprDeclList ds = pprDeeperList vcat ds + +------------ +emptyLocalBinds :: HsLocalBindsLR (GhcPass a) (GhcPass b) +emptyLocalBinds = EmptyLocalBinds noExt + +-- AZ:These functions do not seem to be used at all? +isEmptyLocalBindsTc :: HsLocalBindsLR (GhcPass a) GhcTc -> Bool +isEmptyLocalBindsTc (HsValBinds _ ds) = isEmptyValBinds ds +isEmptyLocalBindsTc (HsIPBinds _ ds) = isEmptyIPBindsTc ds +isEmptyLocalBindsTc (EmptyLocalBinds _) = True +isEmptyLocalBindsTc (XHsLocalBindsLR _) = True + +isEmptyLocalBindsPR :: HsLocalBindsLR (GhcPass a) (GhcPass b) -> Bool +isEmptyLocalBindsPR (HsValBinds _ ds) = isEmptyValBinds ds +isEmptyLocalBindsPR (HsIPBinds _ ds) = isEmptyIPBindsPR ds +isEmptyLocalBindsPR (EmptyLocalBinds _) = True +isEmptyLocalBindsPR (XHsLocalBindsLR _) = True + +eqEmptyLocalBinds :: HsLocalBindsLR a b -> Bool +eqEmptyLocalBinds (EmptyLocalBinds _) = True +eqEmptyLocalBinds _ = False + +isEmptyValBinds :: HsValBindsLR (GhcPass a) (GhcPass b) -> Bool +isEmptyValBinds (ValBinds _ ds sigs) = isEmptyLHsBinds ds && null sigs +isEmptyValBinds (XValBindsLR (NValBinds ds sigs)) = null ds && null sigs + +emptyValBindsIn, emptyValBindsOut :: HsValBindsLR (GhcPass a) (GhcPass b) +emptyValBindsIn = ValBinds noExt emptyBag [] +emptyValBindsOut = XValBindsLR (NValBinds [] []) + +emptyLHsBinds :: LHsBindsLR idL idR +emptyLHsBinds = emptyBag + +isEmptyLHsBinds :: LHsBindsLR idL idR -> Bool +isEmptyLHsBinds = isEmptyBag + +------------ +plusHsValBinds :: HsValBinds (GhcPass a) -> HsValBinds (GhcPass a) + -> HsValBinds(GhcPass a) +plusHsValBinds (ValBinds _ ds1 sigs1) (ValBinds _ ds2 sigs2) + = ValBinds noExt (ds1 `unionBags` ds2) (sigs1 ++ sigs2) +plusHsValBinds (XValBindsLR (NValBinds ds1 sigs1)) + (XValBindsLR (NValBinds ds2 sigs2)) + = XValBindsLR (NValBinds (ds1 ++ ds2) (sigs1 ++ sigs2)) +plusHsValBinds _ _ + = panic "HsBinds.plusHsValBinds" + +instance (idL ~ GhcPass pl, idR ~ GhcPass pr, + OutputableBndrId idL, OutputableBndrId idR) + => Outputable (HsBindLR idL idR) where + ppr mbind = ppr_monobind mbind + +ppr_monobind :: (OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR)) + => HsBindLR (GhcPass idL) (GhcPass idR) -> SDoc + +ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss }) + = pprPatBind pat grhss +ppr_monobind (VarBind { var_id = var, var_rhs = rhs }) + = sep [pprBndr CasePatBind var, nest 2 $ equals <+> pprExpr (unLoc rhs)] +ppr_monobind (FunBind { fun_id = fun, + fun_co_fn = wrap, + fun_matches = matches, + fun_tick = ticks }) + = pprTicks empty (if null ticks then empty + else text "-- ticks = " <> ppr ticks) + $$ whenPprDebug (pprBndr LetBind (unLoc fun)) + $$ pprFunBind matches + $$ whenPprDebug (ppr wrap) +ppr_monobind (PatSynBind _ psb) = ppr psb +ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars + , abs_exports = exports, abs_binds = val_binds + , abs_ev_binds = ev_binds }) + = sdocWithDynFlags $ \ dflags -> + if gopt Opt_PrintTypecheckerElaboration dflags then + -- Show extra information (bug number: #10662) + hang (text "AbsBinds" <+> brackets (interpp'SP tyvars) + <+> brackets (interpp'SP dictvars)) + 2 $ braces $ vcat + [ text "Exports:" <+> + brackets (sep (punctuate comma (map ppr exports))) + , text "Exported types:" <+> + vcat [pprBndr LetBind (abe_poly ex) | ex <- exports] + , text "Binds:" <+> pprLHsBinds val_binds + , text "Evidence:" <+> ppr ev_binds ] + else + pprLHsBinds val_binds +ppr_monobind (XHsBindsLR x) = ppr x + +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (ABExport p) where + ppr (ABE { abe_wrap = wrap, abe_poly = gbl, abe_mono = lcl, abe_prags = prags }) + = vcat [ ppr gbl <+> text "<=" <+> ppr lcl + , nest 2 (pprTcSpecPrags prags) + , nest 2 (text "wrap:" <+> ppr wrap)] + ppr (XABExport x) = ppr x + +instance (idR ~ GhcPass pr,OutputableBndrId idL, OutputableBndrId idR, + Outputable (XXPatSynBind idL idR)) + => Outputable (PatSynBind idL idR) where + ppr (PSB{ psb_id = (L _ psyn), psb_args = details, psb_def = pat, + psb_dir = dir }) + = ppr_lhs <+> ppr_rhs + where + ppr_lhs = text "pattern" <+> ppr_details + ppr_simple syntax = syntax <+> ppr pat + + ppr_details = case details of + InfixCon v1 v2 -> hsep [ppr v1, pprInfixOcc psyn, ppr v2] + PrefixCon vs -> hsep (pprPrefixOcc psyn : map ppr vs) + RecCon vs -> pprPrefixOcc psyn + <> braces (sep (punctuate comma (map ppr vs))) + + ppr_rhs = case dir of + Unidirectional -> ppr_simple (text "<-") + ImplicitBidirectional -> ppr_simple equals + ExplicitBidirectional mg -> ppr_simple (text "<-") <+> ptext (sLit "where") $$ + (nest 2 $ pprFunBind mg) + ppr (XPatSynBind x) = ppr x + +pprTicks :: SDoc -> SDoc -> SDoc +-- Print stuff about ticks only when -dppr-debug is on, to avoid +-- them appearing in error messages (from the desugarer); see # 3263 +-- Also print ticks in dumpStyle, so that -ddump-hpc actually does +-- something useful. +pprTicks pp_no_debug pp_when_debug + = getPprStyle (\ sty -> if debugStyle sty || dumpStyle sty + then pp_when_debug + else pp_no_debug) + +{- +************************************************************************ +* * + Implicit parameter bindings +* * +************************************************************************ +-} + +-- | Haskell Implicit Parameter Bindings +data HsIPBinds id + = IPBinds + (XIPBinds id) + [LIPBind id] + -- TcEvBinds -- Only in typechecker output; binds + -- -- uses of the implicit parameters + | XHsIPBinds (XXHsIPBinds id) + +type instance XIPBinds GhcPs = NoExt +type instance XIPBinds GhcRn = NoExt +type instance XIPBinds GhcTc = TcEvBinds -- binds uses of the + -- implicit parameters + + +type instance XXHsIPBinds (GhcPass p) = NoExt + +isEmptyIPBindsPR :: HsIPBinds (GhcPass p) -> Bool +isEmptyIPBindsPR (IPBinds _ is) = null is +isEmptyIPBindsPR (XHsIPBinds _) = True + +isEmptyIPBindsTc :: HsIPBinds GhcTc -> Bool +isEmptyIPBindsTc (IPBinds ds is) = null is && isEmptyTcEvBinds ds +isEmptyIPBindsTc (XHsIPBinds _) = True + +-- | Located Implicit Parameter Binding +type LIPBind id = Located (IPBind id) +-- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when in a +-- list + +-- For details on above see note [Api annotations] in ApiAnnotation + +-- | Implicit parameter bindings. +-- +-- These bindings start off as (Left "x") in the parser and stay +-- that way until after type-checking when they are replaced with +-- (Right d), where "d" is the name of the dictionary holding the +-- evidence for the implicit parameter. +-- +-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual' + +-- For details on above see note [Api annotations] in ApiAnnotation +data IPBind id + = IPBind + (XCIPBind id) + (Either (Located HsIPName) (IdP id)) + (LHsExpr id) + | XIPBind (XXIPBind id) + +type instance XCIPBind (GhcPass p) = NoExt +type instance XXIPBind (GhcPass p) = NoExt + +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (HsIPBinds p) where + ppr (IPBinds ds bs) = pprDeeperList vcat (map ppr bs) + $$ whenPprDebug (ppr ds) + ppr (XHsIPBinds x) = ppr x + +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (IPBind p) where + ppr (IPBind _ lr rhs) = name <+> equals <+> pprExpr (unLoc rhs) + where name = case lr of + Left (L _ ip) -> pprBndr LetBind ip + Right id -> pprBndr LetBind id + ppr (XIPBind x) = ppr x + +{- +************************************************************************ +* * +\subsection{@Sig@: type signatures and value-modifying user pragmas} +* * +************************************************************************ + +It is convenient to lump ``value-modifying'' user-pragmas (e.g., +``specialise this function to these four types...'') in with type +signatures. Then all the machinery to move them into place, etc., +serves for both. +-} + +-- | Located Signature +type LSig pass = Located (Sig pass) + +-- | Signatures and pragmas +data Sig pass + = -- | An ordinary type signature + -- + -- > f :: Num a => a -> a + -- + -- After renaming, this list of Names contains the named + -- wildcards brought into scope by this signature. For a signature + -- @_ -> _a -> Bool@, the renamer will leave the unnamed wildcard @_@ + -- untouched, and the named wildcard @_a@ is then replaced with + -- fresh meta vars in the type. Their names are stored in the type + -- signature that brought them into scope, in this third field to be + -- more specific. + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon', + -- 'ApiAnnotation.AnnComma' + + -- For details on above see note [Api annotations] in ApiAnnotation + TypeSig + (XTypeSig pass) + [Located (IdP pass)] -- LHS of the signature; e.g. f,g,h :: blah + (LHsSigWcType pass) -- RHS of the signature; can have wildcards + + -- | A pattern synonym type signature + -- + -- > pattern Single :: () => (Show a) => a -> [a] + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnPattern', + -- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnForall' + -- 'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow' + + -- For details on above see note [Api annotations] in ApiAnnotation + | PatSynSig (XPatSynSig pass) [Located (IdP pass)] (LHsSigType pass) + -- P :: forall a b. Req => Prov => ty + + -- | A signature for a class method + -- False: ordinary class-method signature + -- True: generic-default class method signature + -- e.g. class C a where + -- op :: a -> a -- Ordinary + -- default op :: Eq a => a -> a -- Generic default + -- No wildcards allowed here + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDefault', + -- 'ApiAnnotation.AnnDcolon' + | ClassOpSig (XClassOpSig pass) Bool [Located (IdP pass)] (LHsSigType pass) + + -- | A type signature in generated code, notably the code + -- generated for record selectors. We simply record + -- the desired Id itself, replete with its name, type + -- and IdDetails. Otherwise it's just like a type + -- signature: there should be an accompanying binding + | IdSig (XIdSig pass) Id + + -- | An ordinary fixity declaration + -- + -- > infixl 8 *** + -- + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnInfix', + -- 'ApiAnnotation.AnnVal' + + -- For details on above see note [Api annotations] in ApiAnnotation + | FixSig (XFixSig pass) (FixitySig pass) + + -- | An inline pragma + -- + -- > {#- INLINE f #-} + -- + -- - 'ApiAnnotation.AnnKeywordId' : + -- 'ApiAnnotation.AnnOpen' @'{-\# INLINE'@ and @'['@, + -- 'ApiAnnotation.AnnClose','ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnVal','ApiAnnotation.AnnTilde', + -- 'ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + | InlineSig (XInlineSig pass) + (Located (IdP pass)) -- Function name + InlinePragma -- Never defaultInlinePragma + + -- | A specialisation pragma + -- + -- > {-# SPECIALISE f :: Int -> Int #-} + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnOpen' @'{-\# SPECIALISE'@ and @'['@, + -- 'ApiAnnotation.AnnTilde', + -- 'ApiAnnotation.AnnVal', + -- 'ApiAnnotation.AnnClose' @']'@ and @'\#-}'@, + -- 'ApiAnnotation.AnnDcolon' + + -- For details on above see note [Api annotations] in ApiAnnotation + | SpecSig (XSpecSig pass) + (Located (IdP pass)) -- Specialise a function or datatype ... + [LHsSigType pass] -- ... to these types + InlinePragma -- The pragma on SPECIALISE_INLINE form. + -- If it's just defaultInlinePragma, then we said + -- SPECIALISE, not SPECIALISE_INLINE + + -- | A specialisation pragma for instance declarations only + -- + -- > {-# SPECIALISE instance Eq [Int] #-} + -- + -- (Class tys); should be a specialisation of the + -- current instance declaration + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnInstance','ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + | SpecInstSig (XSpecInstSig pass) SourceText (LHsSigType pass) + -- Note [Pragma source text] in BasicTypes + + -- | A minimal complete definition pragma + -- + -- > {-# MINIMAL a | (b, c | (d | e)) #-} + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnVbar','ApiAnnotation.AnnComma', + -- 'ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + | MinimalSig (XMinimalSig pass) + SourceText (LBooleanFormula (Located (IdP pass))) + -- Note [Pragma source text] in BasicTypes + + -- | A "set cost centre" pragma for declarations + -- + -- > {-# SCC funName #-} + -- + -- or + -- + -- > {-# SCC funName "cost_centre_name" #-} + + | SCCFunSig (XSCCFunSig pass) + SourceText -- Note [Pragma source text] in BasicTypes + (Located (IdP pass)) -- Function name + (Maybe (Located StringLiteral)) + -- | A complete match pragma + -- + -- > {-# COMPLETE C, D [:: T] #-} + -- + -- Used to inform the pattern match checker about additional + -- complete matchings which, for example, arise from pattern + -- synonym definitions. + | CompleteMatchSig (XCompleteMatchSig pass) + SourceText + (Located [Located (IdP pass)]) + (Maybe (Located (IdP pass))) + | XSig (XXSig pass) + +type instance XTypeSig (GhcPass p) = NoExt +type instance XPatSynSig (GhcPass p) = NoExt +type instance XClassOpSig (GhcPass p) = NoExt +type instance XIdSig (GhcPass p) = NoExt +type instance XFixSig (GhcPass p) = NoExt +type instance XInlineSig (GhcPass p) = NoExt +type instance XSpecSig (GhcPass p) = NoExt +type instance XSpecInstSig (GhcPass p) = NoExt +type instance XMinimalSig (GhcPass p) = NoExt +type instance XSCCFunSig (GhcPass p) = NoExt +type instance XCompleteMatchSig (GhcPass p) = NoExt +type instance XXSig (GhcPass p) = NoExt + +-- | Located Fixity Signature +type LFixitySig pass = Located (FixitySig pass) + +-- | Fixity Signature +data FixitySig pass = FixitySig (XFixitySig pass) [Located (IdP pass)] Fixity + | XFixitySig (XXFixitySig pass) + +type instance XFixitySig (GhcPass p) = NoExt +type instance XXFixitySig (GhcPass p) = NoExt + +-- | Type checker Specialisation Pragmas +-- +-- 'TcSpecPrags' conveys @SPECIALISE@ pragmas from the type checker to the desugarer +data TcSpecPrags + = IsDefaultMethod -- ^ Super-specialised: a default method should + -- be macro-expanded at every call site + | SpecPrags [LTcSpecPrag] + deriving Data + +-- | Located Type checker Specification Pragmas +type LTcSpecPrag = Located TcSpecPrag + +-- | Type checker Specification Pragma +data TcSpecPrag + = SpecPrag + Id + HsWrapper + InlinePragma + -- ^ The Id to be specialised, a wrapper that specialises the + -- polymorphic function, and inlining spec for the specialised function + deriving Data + +noSpecPrags :: TcSpecPrags +noSpecPrags = SpecPrags [] + +hasSpecPrags :: TcSpecPrags -> Bool +hasSpecPrags (SpecPrags ps) = not (null ps) +hasSpecPrags IsDefaultMethod = False + +isDefaultMethod :: TcSpecPrags -> Bool +isDefaultMethod IsDefaultMethod = True +isDefaultMethod (SpecPrags {}) = False + + +isFixityLSig :: LSig name -> Bool +isFixityLSig (L _ (FixSig {})) = True +isFixityLSig _ = False + +isTypeLSig :: LSig name -> Bool -- Type signatures +isTypeLSig (L _(TypeSig {})) = True +isTypeLSig (L _(ClassOpSig {})) = True +isTypeLSig (L _(IdSig {})) = True +isTypeLSig _ = False + +isSpecLSig :: LSig name -> Bool +isSpecLSig (L _(SpecSig {})) = True +isSpecLSig _ = False + +isSpecInstLSig :: LSig name -> Bool +isSpecInstLSig (L _ (SpecInstSig {})) = True +isSpecInstLSig _ = False + +isPragLSig :: LSig name -> Bool +-- Identifies pragmas +isPragLSig (L _ (SpecSig {})) = True +isPragLSig (L _ (InlineSig {})) = True +isPragLSig (L _ (SCCFunSig {})) = True +isPragLSig (L _ (CompleteMatchSig {})) = True +isPragLSig _ = False + +isInlineLSig :: LSig name -> Bool +-- Identifies inline pragmas +isInlineLSig (L _ (InlineSig {})) = True +isInlineLSig _ = False + +isMinimalLSig :: LSig name -> Bool +isMinimalLSig (L _ (MinimalSig {})) = True +isMinimalLSig _ = False + +isSCCFunSig :: LSig name -> Bool +isSCCFunSig (L _ (SCCFunSig {})) = True +isSCCFunSig _ = False + +isCompleteMatchSig :: LSig name -> Bool +isCompleteMatchSig (L _ (CompleteMatchSig {} )) = True +isCompleteMatchSig _ = False + +hsSigDoc :: Sig name -> SDoc +hsSigDoc (TypeSig {}) = text "type signature" +hsSigDoc (PatSynSig {}) = text "pattern synonym signature" +hsSigDoc (ClassOpSig _ is_deflt _ _) + | is_deflt = text "default type signature" + | otherwise = text "class method signature" +hsSigDoc (IdSig {}) = text "id signature" +hsSigDoc (SpecSig {}) = text "SPECIALISE pragma" +hsSigDoc (InlineSig _ _ prag) = ppr (inlinePragmaSpec prag) <+> text "pragma" +hsSigDoc (SpecInstSig {}) = text "SPECIALISE instance pragma" +hsSigDoc (FixSig {}) = text "fixity declaration" +hsSigDoc (MinimalSig {}) = text "MINIMAL pragma" +hsSigDoc (SCCFunSig {}) = text "SCC pragma" +hsSigDoc (CompleteMatchSig {}) = text "COMPLETE pragma" +hsSigDoc (XSig {}) = text "XSIG TTG extension" + +{- +Check if signatures overlap; this is used when checking for duplicate +signatures. Since some of the signatures contain a list of names, testing for +equality is not enough -- we have to check if they overlap. +-} + +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (Sig p) where + ppr sig = ppr_sig sig + +ppr_sig :: (OutputableBndrId (GhcPass p)) => Sig (GhcPass p) -> SDoc +ppr_sig (TypeSig _ vars ty) = pprVarSig (map unLoc vars) (ppr ty) +ppr_sig (ClassOpSig _ is_deflt vars ty) + | is_deflt = text "default" <+> pprVarSig (map unLoc vars) (ppr ty) + | otherwise = pprVarSig (map unLoc vars) (ppr ty) +ppr_sig (IdSig _ id) = pprVarSig [id] (ppr (varType id)) +ppr_sig (FixSig _ fix_sig) = ppr fix_sig +ppr_sig (SpecSig _ var ty inl@(InlinePragma { inl_inline = spec })) + = pragSrcBrackets (inl_src inl) pragmaSrc (pprSpec (unLoc var) + (interpp'SP ty) inl) + where + pragmaSrc = case spec of + NoUserInline -> "{-# SPECIALISE" + _ -> "{-# SPECIALISE_INLINE" +ppr_sig (InlineSig _ var inl) + = pragSrcBrackets (inl_src inl) "{-# INLINE" (pprInline inl + <+> pprPrefixOcc (unLoc var)) +ppr_sig (SpecInstSig _ src ty) + = pragSrcBrackets src "{-# SPECIALISE" (text "instance" <+> ppr ty) +ppr_sig (MinimalSig _ src bf) + = pragSrcBrackets src "{-# MINIMAL" (pprMinimalSig bf) +ppr_sig (PatSynSig _ names sig_ty) + = text "pattern" <+> pprVarSig (map unLoc names) (ppr sig_ty) +ppr_sig (SCCFunSig _ src fn mlabel) + = pragSrcBrackets src "{-# SCC" (ppr fn <+> maybe empty ppr mlabel ) +ppr_sig (CompleteMatchSig _ src cs mty) + = pragSrcBrackets src "{-# COMPLETE" + ((hsep (punctuate comma (map ppr (unLoc cs)))) + <+> opt_sig) + where + opt_sig = maybe empty ((\t -> dcolon <+> ppr t) . unLoc) mty +ppr_sig (XSig x) = ppr x + +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (FixitySig p) where + ppr (FixitySig _ names fixity) = sep [ppr fixity, pprops] + where + pprops = hsep $ punctuate comma (map (pprInfixOcc . unLoc) names) + ppr (XFixitySig x) = ppr x + +pragBrackets :: SDoc -> SDoc +pragBrackets doc = text "{-#" <+> doc <+> text "#-}" + +-- | Using SourceText in case the pragma was spelled differently or used mixed +-- case +pragSrcBrackets :: SourceText -> String -> SDoc -> SDoc +pragSrcBrackets (SourceText src) _ doc = text src <+> doc <+> text "#-}" +pragSrcBrackets NoSourceText alt doc = text alt <+> doc <+> text "#-}" + +pprVarSig :: (OutputableBndr id) => [id] -> SDoc -> SDoc +pprVarSig vars pp_ty = sep [pprvars <+> dcolon, nest 2 pp_ty] + where + pprvars = hsep $ punctuate comma (map pprPrefixOcc vars) + +pprSpec :: (OutputableBndr id) => id -> SDoc -> InlinePragma -> SDoc +pprSpec var pp_ty inl = pp_inl <+> pprVarSig [var] pp_ty + where + pp_inl | isDefaultInlinePragma inl = empty + | otherwise = pprInline inl + +pprTcSpecPrags :: TcSpecPrags -> SDoc +pprTcSpecPrags IsDefaultMethod = text "" +pprTcSpecPrags (SpecPrags ps) = vcat (map (ppr . unLoc) ps) + +instance Outputable TcSpecPrag where + ppr (SpecPrag var _ inl) + = text "SPECIALIZE" <+> pprSpec var (text "") inl + +pprMinimalSig :: (OutputableBndr name) + => LBooleanFormula (Located name) -> SDoc +pprMinimalSig (L _ bf) = ppr (fmap unLoc bf) + +{- +************************************************************************ +* * +\subsection[PatSynBind]{A pattern synonym definition} +* * +************************************************************************ +-} + +-- | Haskell Pattern Synonym Details +type HsPatSynDetails arg = HsConDetails arg [RecordPatSynField arg] + +-- See Note [Record PatSyn Fields] +-- | Record Pattern Synonym Field +data RecordPatSynField a + = RecordPatSynField { + recordPatSynSelectorId :: a -- Selector name visible in rest of the file + , recordPatSynPatVar :: a + -- Filled in by renamer, the name used internally + -- by the pattern + } deriving Data + + + +{- +Note [Record PatSyn Fields] + +Consider the following two pattern synonyms. + +pattern P x y = ([x,True], [y,'v']) +pattern Q{ x, y } =([x,True], [y,'v']) + +In P, we just have two local binders, x and y. + +In Q, we have local binders but also top-level record selectors +x :: ([Bool], [Char]) -> Bool and similarly for y. + +It would make sense to support record-like syntax + +pattern Q{ x=x1, y=y1 } = ([x1,True], [y1,'v']) + +when we have a different name for the local and top-level binder +the distinction between the two names clear + +-} +instance Functor RecordPatSynField where + fmap f (RecordPatSynField { recordPatSynSelectorId = visible + , recordPatSynPatVar = hidden }) + = RecordPatSynField { recordPatSynSelectorId = f visible + , recordPatSynPatVar = f hidden } + +instance Outputable a => Outputable (RecordPatSynField a) where + ppr (RecordPatSynField { recordPatSynSelectorId = v }) = ppr v + +instance Foldable RecordPatSynField where + foldMap f (RecordPatSynField { recordPatSynSelectorId = visible + , recordPatSynPatVar = hidden }) + = f visible `mappend` f hidden + +instance Traversable RecordPatSynField where + traverse f (RecordPatSynField { recordPatSynSelectorId =visible + , recordPatSynPatVar = hidden }) + = (\ sel_id pat_var -> RecordPatSynField { recordPatSynSelectorId = sel_id + , recordPatSynPatVar = pat_var }) + <$> f visible <*> f hidden + + +-- | Haskell Pattern Synonym Direction +data HsPatSynDir id + = Unidirectional + | ImplicitBidirectional + | ExplicitBidirectional (MatchGroup id (LHsExpr id)) diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs new file mode 100644 --- /dev/null +++ b/compiler/hsSyn/HsDecls.hs @@ -0,0 +1,2412 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, + DeriveTraversable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] + -- in module PlaceHolder +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Abstract syntax of global declarations. +-- +-- Definitions for: @SynDecl@ and @ConDecl@, @ClassDecl@, +-- @InstDecl@, @DefaultDecl@ and @ForeignDecl@. +module HsDecls ( + -- * Toplevel declarations + HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving, LHsFunDep, + HsDerivingClause(..), LHsDerivingClause, NewOrData(..), newOrDataToFlavour, + + -- ** Class or type declarations + TyClDecl(..), LTyClDecl, DataDeclRn(..), + TyClGroup(..), mkTyClGroup, emptyTyClGroup, + tyClGroupTyClDecls, tyClGroupInstDecls, tyClGroupRoleDecls, + isClassDecl, isDataDecl, isSynDecl, tcdName, + isFamilyDecl, isTypeFamilyDecl, isDataFamilyDecl, + isOpenTypeFamilyInfo, isClosedTypeFamilyInfo, + tyFamInstDeclName, tyFamInstDeclLName, + countTyClDecls, pprTyClDeclFlavour, + tyClDeclLName, tyClDeclTyVars, + hsDeclHasCusk, famDeclHasCusk, + FamilyDecl(..), LFamilyDecl, + + -- ** Instance declarations + InstDecl(..), LInstDecl, FamilyInfo(..), + TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts, + DataFamInstDecl(..), LDataFamInstDecl, + pprDataFamInstFlavour, pprHsFamInstLHS, + FamInstEqn, LFamInstEqn, FamEqn(..), + TyFamInstEqn, LTyFamInstEqn, TyFamDefltEqn, LTyFamDefltEqn, + HsTyPats, + LClsInstDecl, ClsInstDecl(..), + + -- ** Standalone deriving declarations + DerivDecl(..), LDerivDecl, + -- ** Deriving strategies + DerivStrategy(..), LDerivStrategy, derivStrategyName, + -- ** @RULE@ declarations + LRuleDecls,RuleDecls(..),RuleDecl(..),LRuleDecl,HsRuleRn(..), + RuleBndr(..),LRuleBndr, + collectRuleBndrSigTys, + flattenRuleDecls, pprFullRuleName, + -- ** @default@ declarations + DefaultDecl(..), LDefaultDecl, + -- ** Template haskell declaration splice + SpliceExplicitFlag(..), + SpliceDecl(..), LSpliceDecl, + -- ** Foreign function interface declarations + ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..), + CImportSpec(..), + -- ** Data-constructor declarations + ConDecl(..), LConDecl, + HsConDeclDetails, hsConDeclArgTys, hsConDeclTheta, + getConNames, getConArgs, + -- ** Document comments + DocDecl(..), LDocDecl, docDeclDoc, + -- ** Deprecations + WarnDecl(..), LWarnDecl, + WarnDecls(..), LWarnDecls, + -- ** Annotations + AnnDecl(..), LAnnDecl, + AnnProvenance(..), annProvenanceName_maybe, + -- ** Role annotations + RoleAnnotDecl(..), LRoleAnnotDecl, roleAnnotDeclName, + -- ** Injective type families + FamilyResultSig(..), LFamilyResultSig, InjectivityAnn(..), LInjectivityAnn, + resultVariableName, + + -- * Grouping + HsGroup(..), emptyRdrGroup, emptyRnGroup, appendGroups, hsGroupInstDecls + + ) where + +-- friends: +import GhcPrelude + +import {-# SOURCE #-} HsExpr( HsExpr, HsSplice, pprExpr, + pprSpliceDecl ) + -- Because Expr imports Decls via HsBracket + +import HsBinds +import HsTypes +import HsDoc +import TyCon +import BasicTypes +import Coercion +import ForeignCall +import HsExtension +import NameSet + +-- others: +import Class +import Outputable +import Util +import SrcLoc +import Type + +import Bag +import Maybes +import Data.Data hiding (TyCon,Fixity, Infix) + +{- +************************************************************************ +* * +\subsection[HsDecl]{Declarations} +* * +************************************************************************ +-} + +type LHsDecl p = Located (HsDecl p) + -- ^ When in a list this may have + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' + -- + +-- For details on above see note [Api annotations] in ApiAnnotation + +-- | A Haskell Declaration +data HsDecl p + = TyClD (XTyClD p) (TyClDecl p) -- ^ Type or Class Declaration + | InstD (XInstD p) (InstDecl p) -- ^ Instance declaration + | DerivD (XDerivD p) (DerivDecl p) -- ^ Deriving declaration + | ValD (XValD p) (HsBind p) -- ^ Value declaration + | SigD (XSigD p) (Sig p) -- ^ Signature declaration + | DefD (XDefD p) (DefaultDecl p) -- ^ 'default' declaration + | ForD (XForD p) (ForeignDecl p) -- ^ Foreign declaration + | WarningD (XWarningD p) (WarnDecls p) -- ^ Warning declaration + | AnnD (XAnnD p) (AnnDecl p) -- ^ Annotation declaration + | RuleD (XRuleD p) (RuleDecls p) -- ^ Rule declaration + | SpliceD (XSpliceD p) (SpliceDecl p) -- ^ Splice declaration + -- (Includes quasi-quotes) + | DocD (XDocD p) (DocDecl) -- ^ Documentation comment declaration + | RoleAnnotD (XRoleAnnotD p) (RoleAnnotDecl p) -- ^Role annotation declaration + | XHsDecl (XXHsDecl p) + +type instance XTyClD (GhcPass _) = NoExt +type instance XInstD (GhcPass _) = NoExt +type instance XDerivD (GhcPass _) = NoExt +type instance XValD (GhcPass _) = NoExt +type instance XSigD (GhcPass _) = NoExt +type instance XDefD (GhcPass _) = NoExt +type instance XForD (GhcPass _) = NoExt +type instance XWarningD (GhcPass _) = NoExt +type instance XAnnD (GhcPass _) = NoExt +type instance XRuleD (GhcPass _) = NoExt +type instance XSpliceD (GhcPass _) = NoExt +type instance XDocD (GhcPass _) = NoExt +type instance XRoleAnnotD (GhcPass _) = NoExt +type instance XXHsDecl (GhcPass _) = NoExt + +-- NB: all top-level fixity decls are contained EITHER +-- EITHER SigDs +-- OR in the ClassDecls in TyClDs +-- +-- The former covers +-- a) data constructors +-- b) class methods (but they can be also done in the +-- signatures of class decls) +-- c) imported functions (that have an IfacSig) +-- d) top level decls +-- +-- The latter is for class methods only + +-- | Haskell Group +-- +-- A 'HsDecl' is categorised into a 'HsGroup' before being +-- fed to the renamer. +data HsGroup p + = HsGroup { + hs_ext :: XCHsGroup p, + hs_valds :: HsValBinds p, + hs_splcds :: [LSpliceDecl p], + + hs_tyclds :: [TyClGroup p], + -- A list of mutually-recursive groups; + -- This includes `InstDecl`s as well; + -- Parser generates a singleton list; + -- renamer does dependency analysis + + hs_derivds :: [LDerivDecl p], + + hs_fixds :: [LFixitySig p], + -- Snaffled out of both top-level fixity signatures, + -- and those in class declarations + + hs_defds :: [LDefaultDecl p], + hs_fords :: [LForeignDecl p], + hs_warnds :: [LWarnDecls p], + hs_annds :: [LAnnDecl p], + hs_ruleds :: [LRuleDecls p], + + hs_docs :: [LDocDecl] + } + | XHsGroup (XXHsGroup p) + +type instance XCHsGroup (GhcPass _) = NoExt +type instance XXHsGroup (GhcPass _) = NoExt + + +emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup (GhcPass p) +emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn } +emptyRnGroup = emptyGroup { hs_valds = emptyValBindsOut } + +hsGroupInstDecls :: HsGroup id -> [LInstDecl id] +hsGroupInstDecls = (=<<) group_instds . hs_tyclds + +emptyGroup = HsGroup { hs_ext = noExt, + hs_tyclds = [], + hs_derivds = [], + hs_fixds = [], hs_defds = [], hs_annds = [], + hs_fords = [], hs_warnds = [], hs_ruleds = [], + hs_valds = error "emptyGroup hs_valds: Can't happen", + hs_splcds = [], + hs_docs = [] } + +appendGroups :: HsGroup (GhcPass p) -> HsGroup (GhcPass p) + -> HsGroup (GhcPass p) +appendGroups + HsGroup { + hs_valds = val_groups1, + hs_splcds = spliceds1, + hs_tyclds = tyclds1, + hs_derivds = derivds1, + hs_fixds = fixds1, + hs_defds = defds1, + hs_annds = annds1, + hs_fords = fords1, + hs_warnds = warnds1, + hs_ruleds = rulds1, + hs_docs = docs1 } + HsGroup { + hs_valds = val_groups2, + hs_splcds = spliceds2, + hs_tyclds = tyclds2, + hs_derivds = derivds2, + hs_fixds = fixds2, + hs_defds = defds2, + hs_annds = annds2, + hs_fords = fords2, + hs_warnds = warnds2, + hs_ruleds = rulds2, + hs_docs = docs2 } + = + HsGroup { + hs_ext = noExt, + hs_valds = val_groups1 `plusHsValBinds` val_groups2, + hs_splcds = spliceds1 ++ spliceds2, + hs_tyclds = tyclds1 ++ tyclds2, + hs_derivds = derivds1 ++ derivds2, + hs_fixds = fixds1 ++ fixds2, + hs_annds = annds1 ++ annds2, + hs_defds = defds1 ++ defds2, + hs_fords = fords1 ++ fords2, + hs_warnds = warnds1 ++ warnds2, + hs_ruleds = rulds1 ++ rulds2, + hs_docs = docs1 ++ docs2 } +appendGroups _ _ = panic "appendGroups" + +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsDecl p) where + ppr (TyClD _ dcl) = ppr dcl + ppr (ValD _ binds) = ppr binds + ppr (DefD _ def) = ppr def + ppr (InstD _ inst) = ppr inst + ppr (DerivD _ deriv) = ppr deriv + ppr (ForD _ fd) = ppr fd + ppr (SigD _ sd) = ppr sd + ppr (RuleD _ rd) = ppr rd + ppr (WarningD _ wd) = ppr wd + ppr (AnnD _ ad) = ppr ad + ppr (SpliceD _ dd) = ppr dd + ppr (DocD _ doc) = ppr doc + ppr (RoleAnnotD _ ra) = ppr ra + ppr (XHsDecl x) = ppr x + +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsGroup p) where + ppr (HsGroup { hs_valds = val_decls, + hs_tyclds = tycl_decls, + hs_derivds = deriv_decls, + hs_fixds = fix_decls, + hs_warnds = deprec_decls, + hs_annds = ann_decls, + hs_fords = foreign_decls, + hs_defds = default_decls, + hs_ruleds = rule_decls }) + = vcat_mb empty + [ppr_ds fix_decls, ppr_ds default_decls, + ppr_ds deprec_decls, ppr_ds ann_decls, + ppr_ds rule_decls, + if isEmptyValBinds val_decls + then Nothing + else Just (ppr val_decls), + ppr_ds (tyClGroupTyClDecls tycl_decls), + ppr_ds (tyClGroupInstDecls tycl_decls), + ppr_ds deriv_decls, + ppr_ds foreign_decls] + where + ppr_ds :: Outputable a => [a] -> Maybe SDoc + ppr_ds [] = Nothing + ppr_ds ds = Just (vcat (map ppr ds)) + + vcat_mb :: SDoc -> [Maybe SDoc] -> SDoc + -- Concatenate vertically with white-space between non-blanks + vcat_mb _ [] = empty + vcat_mb gap (Nothing : ds) = vcat_mb gap ds + vcat_mb gap (Just d : ds) = gap $$ d $$ vcat_mb blankLine ds + ppr (XHsGroup x) = ppr x + +-- | Located Splice Declaration +type LSpliceDecl pass = Located (SpliceDecl pass) + +-- | Splice Declaration +data SpliceDecl p + = SpliceDecl -- Top level splice + (XSpliceDecl p) + (Located (HsSplice p)) + SpliceExplicitFlag + | XSpliceDecl (XXSpliceDecl p) + +type instance XSpliceDecl (GhcPass _) = NoExt +type instance XXSpliceDecl (GhcPass _) = NoExt + +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (SpliceDecl p) where + ppr (SpliceDecl _ (L _ e) f) = pprSpliceDecl e f + ppr (XSpliceDecl x) = ppr x + +{- +************************************************************************ +* * + Type and class declarations +* * +************************************************************************ + +Note [The Naming story] +~~~~~~~~~~~~~~~~~~~~~~~ +Here is the story about the implicit names that go with type, class, +and instance decls. It's a bit tricky, so pay attention! + +"Implicit" (or "system") binders +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Each data type decl defines + a worker name for each constructor + to-T and from-T convertors + Each class decl defines + a tycon for the class + a data constructor for that tycon + the worker for that constructor + a selector for each superclass + +All have occurrence names that are derived uniquely from their parent +declaration. + +None of these get separate definitions in an interface file; they are +fully defined by the data or class decl. But they may *occur* in +interface files, of course. Any such occurrence must haul in the +relevant type or class decl. + +Plan of attack: + - Ensure they "point to" the parent data/class decl + when loading that decl from an interface file + (See RnHiFiles.getSysBinders) + + - When typechecking the decl, we build the implicit TyCons and Ids. + When doing so we look them up in the name cache (RnEnv.lookupSysName), + to ensure correct module and provenance is set + +These are the two places that we have to conjure up the magic derived +names. (The actual magic is in OccName.mkWorkerOcc, etc.) + +Default methods +~~~~~~~~~~~~~~~ + - Occurrence name is derived uniquely from the method name + E.g. $dmmax + + - If there is a default method name at all, it's recorded in + the ClassOpSig (in HsBinds), in the DefMethInfo field. + (DefMethInfo is defined in Class.hs) + +Source-code class decls and interface-code class decls are treated subtly +differently, which has given me a great deal of confusion over the years. +Here's the deal. (We distinguish the two cases because source-code decls +have (Just binds) in the tcdMeths field, whereas interface decls have Nothing. + +In *source-code* class declarations: + + - When parsing, every ClassOpSig gets a DefMeth with a suitable RdrName + This is done by RdrHsSyn.mkClassOpSigDM + + - The renamer renames it to a Name + + - During typechecking, we generate a binding for each $dm for + which there's a programmer-supplied default method: + class Foo a where + op1 :: + op2 :: + op1 = ... + We generate a binding for $dmop1 but not for $dmop2. + The Class for Foo has a Nothing for op2 and + a Just ($dm_op1, VanillaDM) for op1. + The Name for $dmop2 is simply discarded. + +In *interface-file* class declarations: + - When parsing, we see if there's an explicit programmer-supplied default method + because there's an '=' sign to indicate it: + class Foo a where + op1 = :: -- NB the '=' + op2 :: + We use this info to generate a DefMeth with a suitable RdrName for op1, + and a NoDefMeth for op2 + - The interface file has a separate definition for $dmop1, with unfolding etc. + - The renamer renames it to a Name. + - The renamer treats $dmop1 as a free variable of the declaration, so that + the binding for $dmop1 will be sucked in. (See RnHsSyn.tyClDeclFVs) + This doesn't happen for source code class decls, because they *bind* the default method. + +Dictionary functions +~~~~~~~~~~~~~~~~~~~~ +Each instance declaration gives rise to one dictionary function binding. + +The type checker makes up new source-code instance declarations +(e.g. from 'deriving' or generic default methods --- see +TcInstDcls.tcInstDecls1). So we can't generate the names for +dictionary functions in advance (we don't know how many we need). + +On the other hand for interface-file instance declarations, the decl +specifies the name of the dictionary function, and it has a binding elsewhere +in the interface file: + instance {Eq Int} = dEqInt + dEqInt :: {Eq Int} + +So again we treat source code and interface file code slightly differently. + +Source code: + - Source code instance decls have a Nothing in the (Maybe name) field + (see data InstDecl below) + + - The typechecker makes up a Local name for the dict fun for any source-code + instance decl, whether it comes from a source-code instance decl, or whether + the instance decl is derived from some other construct (e.g. 'deriving'). + + - The occurrence name it chooses is derived from the instance decl (just for + documentation really) --- e.g. dNumInt. Two dict funs may share a common + occurrence name, but will have different uniques. E.g. + instance Foo [Int] where ... + instance Foo [Bool] where ... + These might both be dFooList + + - The CoreTidy phase externalises the name, and ensures the occurrence name is + unique (this isn't special to dict funs). So we'd get dFooList and dFooList1. + + - We can take this relaxed approach (changing the occurrence name later) + because dict fun Ids are not captured in a TyCon or Class (unlike default + methods, say). Instead, they are kept separately in the InstEnv. This + makes it easy to adjust them after compiling a module. (Once we've finished + compiling that module, they don't change any more.) + + +Interface file code: + - The instance decl gives the dict fun name, so the InstDecl has a (Just name) + in the (Maybe name) field. + + - RnHsSyn.instDeclFVs treats the dict fun name as free in the decl, so that we + suck in the dfun binding +-} + +-- | Located Declaration of a Type or Class +type LTyClDecl pass = Located (TyClDecl pass) + +-- | A type or class declaration. +data TyClDecl pass + = -- | @type/data family T :: *->*@ + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', + -- 'ApiAnnotation.AnnData', + -- 'ApiAnnotation.AnnFamily','ApiAnnotation.AnnDcolon', + -- 'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpenP', + -- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnCloseP', + -- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnRarrow', + -- 'ApiAnnotation.AnnVbar' + + -- For details on above see note [Api annotations] in ApiAnnotation + FamDecl { tcdFExt :: XFamDecl pass, tcdFam :: FamilyDecl pass } + + | -- | @type@ declaration + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', + -- 'ApiAnnotation.AnnEqual', + + -- For details on above see note [Api annotations] in ApiAnnotation + SynDecl { tcdSExt :: XSynDecl pass -- ^ Post renameer, FVs + , tcdLName :: Located (IdP pass) -- ^ Type constructor + , tcdTyVars :: LHsQTyVars pass -- ^ Type variables; for an + -- associated type these + -- include outer binders + , tcdFixity :: LexicalFixity -- ^ Fixity used in the declaration + , tcdRhs :: LHsType pass } -- ^ RHS of type declaration + + | -- | @data@ declaration + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnData', + -- 'ApiAnnotation.AnnFamily', + -- 'ApiAnnotation.AnnNewType', + -- 'ApiAnnotation.AnnNewType','ApiAnnotation.AnnDcolon' + -- 'ApiAnnotation.AnnWhere', + + -- For details on above see note [Api annotations] in ApiAnnotation + DataDecl { tcdDExt :: XDataDecl pass -- ^ Post renamer, CUSK flag, FVs + , tcdLName :: Located (IdP pass) -- ^ Type constructor + , tcdTyVars :: LHsQTyVars pass -- ^ Type variables + -- See Note [TyVar binders for associated declarations] + , tcdFixity :: LexicalFixity -- ^ Fixity used in the declaration + , tcdDataDefn :: HsDataDefn pass } + + | ClassDecl { tcdCExt :: XClassDecl pass, -- ^ Post renamer, FVs + tcdCtxt :: LHsContext pass, -- ^ Context... + tcdLName :: Located (IdP pass), -- ^ Name of the class + tcdTyVars :: LHsQTyVars pass, -- ^ Class type variables + tcdFixity :: LexicalFixity, -- ^ Fixity used in the declaration + tcdFDs :: [LHsFunDep pass], -- ^ Functional deps + tcdSigs :: [LSig pass], -- ^ Methods' signatures + tcdMeths :: LHsBinds pass, -- ^ Default methods + tcdATs :: [LFamilyDecl pass], -- ^ Associated types; + tcdATDefs :: [LTyFamDefltEqn pass], -- ^ Associated type defaults + tcdDocs :: [LDocDecl] -- ^ Haddock docs + } + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnClass', + -- 'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnClose' + -- - The tcdFDs will have 'ApiAnnotation.AnnVbar', + -- 'ApiAnnotation.AnnComma' + -- 'ApiAnnotation.AnnRarrow' + + -- For details on above see note [Api annotations] in ApiAnnotation + | XTyClDecl (XXTyClDecl pass) + +type LHsFunDep pass = Located (FunDep (Located (IdP pass))) + +data DataDeclRn = DataDeclRn + { tcdDataCusk :: Bool -- ^ does this have a CUSK? + , tcdFVs :: NameSet } + deriving Data + +{- Note [TyVar binders for associated decls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For an /associated/ data, newtype, or type-family decl, the LHsQTyVars +/includes/ outer binders. For example + class T a where + data D a c + type F a b :: * + type F a b = a -> a +Here the data decl for 'D', and type-family decl for 'F', both include 'a' +in their LHsQTyVars (tcdTyVars and fdTyVars resp). + +Ditto any implicit binders in the hsq_implicit field of the LHSQTyVars. + +The idea is that the associated type is really a top-level decl in its +own right. However we are careful to use the same name 'a', so that +we can match things up. + +c.f. Note [Associated type tyvar names] in Class.hs + Note [Family instance declaration binders] +-} + +type instance XFamDecl (GhcPass _) = NoExt + +type instance XSynDecl GhcPs = NoExt +type instance XSynDecl GhcRn = NameSet -- FVs +type instance XSynDecl GhcTc = NameSet -- FVs + +type instance XDataDecl GhcPs = NoExt +type instance XDataDecl GhcRn = DataDeclRn +type instance XDataDecl GhcTc = DataDeclRn + +type instance XClassDecl GhcPs = NoExt +type instance XClassDecl GhcRn = NameSet -- FVs +type instance XClassDecl GhcTc = NameSet -- FVs + +type instance XXTyClDecl (GhcPass _) = NoExt + +-- Simple classifiers for TyClDecl +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +-- | @True@ <=> argument is a @data@\/@newtype@ +-- declaration. +isDataDecl :: TyClDecl pass -> Bool +isDataDecl (DataDecl {}) = True +isDataDecl _other = False + +-- | type or type instance declaration +isSynDecl :: TyClDecl pass -> Bool +isSynDecl (SynDecl {}) = True +isSynDecl _other = False + +-- | type class +isClassDecl :: TyClDecl pass -> Bool +isClassDecl (ClassDecl {}) = True +isClassDecl _ = False + +-- | type/data family declaration +isFamilyDecl :: TyClDecl pass -> Bool +isFamilyDecl (FamDecl {}) = True +isFamilyDecl _other = False + +-- | type family declaration +isTypeFamilyDecl :: TyClDecl pass -> Bool +isTypeFamilyDecl (FamDecl _ (FamilyDecl { fdInfo = info })) = case info of + OpenTypeFamily -> True + ClosedTypeFamily {} -> True + _ -> False +isTypeFamilyDecl _ = False + +-- | open type family info +isOpenTypeFamilyInfo :: FamilyInfo pass -> Bool +isOpenTypeFamilyInfo OpenTypeFamily = True +isOpenTypeFamilyInfo _ = False + +-- | closed type family info +isClosedTypeFamilyInfo :: FamilyInfo pass -> Bool +isClosedTypeFamilyInfo (ClosedTypeFamily {}) = True +isClosedTypeFamilyInfo _ = False + +-- | data family declaration +isDataFamilyDecl :: TyClDecl pass -> Bool +isDataFamilyDecl (FamDecl _ (FamilyDecl { fdInfo = DataFamily })) = True +isDataFamilyDecl _other = False + +-- Dealing with names + +tyFamInstDeclName :: TyFamInstDecl pass -> (IdP pass) +tyFamInstDeclName = unLoc . tyFamInstDeclLName + +tyFamInstDeclLName :: TyFamInstDecl pass -> Located (IdP pass) +tyFamInstDeclLName (TyFamInstDecl { tfid_eqn = + (HsIB { hsib_body = FamEqn { feqn_tycon = ln }}) }) + = ln +tyFamInstDeclLName (TyFamInstDecl (HsIB _ (XFamEqn _))) + = panic "tyFamInstDeclLName" +tyFamInstDeclLName (TyFamInstDecl (XHsImplicitBndrs _)) + = panic "tyFamInstDeclLName" + +tyClDeclLName :: TyClDecl pass -> Located (IdP pass) +tyClDeclLName (FamDecl { tcdFam = FamilyDecl { fdLName = ln } }) = ln +tyClDeclLName decl = tcdLName decl + +tcdName :: TyClDecl pass -> (IdP pass) +tcdName = unLoc . tyClDeclLName + +tyClDeclTyVars :: TyClDecl pass -> LHsQTyVars pass +tyClDeclTyVars (FamDecl { tcdFam = FamilyDecl { fdTyVars = tvs } }) = tvs +tyClDeclTyVars d = tcdTyVars d + +countTyClDecls :: [TyClDecl pass] -> (Int, Int, Int, Int, Int) + -- class, synonym decls, data, newtype, family decls +countTyClDecls decls + = (count isClassDecl decls, + count isSynDecl decls, -- excluding... + count isDataTy decls, -- ...family... + count isNewTy decls, -- ...instances + count isFamilyDecl decls) + where + isDataTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = DataType } } = True + isDataTy _ = False + + isNewTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = NewType } } = True + isNewTy _ = False + +-- | Does this declaration have a complete, user-supplied kind signature? +-- See Note [CUSKs: complete user-supplied kind signatures] +hsDeclHasCusk :: TyClDecl GhcRn -> Bool +hsDeclHasCusk (FamDecl { tcdFam = fam_decl }) + = famDeclHasCusk False fam_decl + -- False: this is not: an associated type of a class with no cusk +hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs }) + -- NB: Keep this synchronized with 'getInitialKind' + = hsTvbAllKinded tyvars && rhs_annotated rhs + where + rhs_annotated (L _ ty) = case ty of + HsParTy _ lty -> rhs_annotated lty + HsKindSig {} -> True + _ -> False +hsDeclHasCusk (DataDecl { tcdDExt = DataDeclRn { tcdDataCusk = cusk }}) = cusk +hsDeclHasCusk (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars +hsDeclHasCusk (XTyClDecl _) = panic "hsDeclHasCusk" + +-- Pretty-printing TyClDecl +-- ~~~~~~~~~~~~~~~~~~~~~~~~ + +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (TyClDecl p) where + + ppr (FamDecl { tcdFam = decl }) = ppr decl + ppr (SynDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity + , tcdRhs = rhs }) + = hang (text "type" <+> + pp_vanilla_decl_head ltycon tyvars fixity noLHsContext <+> equals) + 4 (ppr rhs) + + ppr (DataDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity + , tcdDataDefn = defn }) + = pp_data_defn (pp_vanilla_decl_head ltycon tyvars fixity) defn + + ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars, + tcdFixity = fixity, + tcdFDs = fds, + tcdSigs = sigs, tcdMeths = methods, + tcdATs = ats, tcdATDefs = at_defs}) + | null sigs && isEmptyBag methods && null ats && null at_defs -- No "where" part + = top_matter + + | otherwise -- Laid out + = vcat [ top_matter <+> text "where" + , nest 2 $ pprDeclList (map (pprFamilyDecl NotTopLevel . unLoc) ats ++ + map ppr_fam_deflt_eqn at_defs ++ + pprLHsBindsForUser methods sigs) ] + where + top_matter = text "class" + <+> pp_vanilla_decl_head lclas tyvars fixity context + <+> pprFundeps (map unLoc fds) + + ppr (XTyClDecl x) = ppr x + +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (TyClGroup p) where + ppr (TyClGroup { group_tyclds = tyclds + , group_roles = roles + , group_instds = instds + } + ) + = ppr tyclds $$ + ppr roles $$ + ppr instds + ppr (XTyClGroup x) = ppr x + +pp_vanilla_decl_head :: (OutputableBndrId (GhcPass p)) + => Located (IdP (GhcPass p)) + -> LHsQTyVars (GhcPass p) + -> LexicalFixity + -> LHsContext (GhcPass p) + -> SDoc +pp_vanilla_decl_head thing (HsQTvs { hsq_explicit = tyvars }) fixity context + = hsep [pprLHsContext context, pp_tyvars tyvars] + where + pp_tyvars (varl:varsr) + | fixity == Infix && length varsr > 1 + = hsep [char '(',ppr (unLoc varl), pprInfixOcc (unLoc thing) + , (ppr.unLoc) (head varsr), char ')' + , hsep (map (ppr.unLoc) (tail varsr))] + | fixity == Infix + = hsep [ppr (unLoc varl), pprInfixOcc (unLoc thing) + , hsep (map (ppr.unLoc) varsr)] + | otherwise = hsep [ pprPrefixOcc (unLoc thing) + , hsep (map (ppr.unLoc) (varl:varsr))] + pp_tyvars [] = pprPrefixOcc (unLoc thing) +pp_vanilla_decl_head _ (XLHsQTyVars x) _ _ = ppr x + +pprTyClDeclFlavour :: TyClDecl (GhcPass p) -> SDoc +pprTyClDeclFlavour (ClassDecl {}) = text "class" +pprTyClDeclFlavour (SynDecl {}) = text "type" +pprTyClDeclFlavour (FamDecl { tcdFam = FamilyDecl { fdInfo = info }}) + = pprFlavour info <+> text "family" +pprTyClDeclFlavour (FamDecl { tcdFam = XFamilyDecl x}) + = ppr x +pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd } }) + = ppr nd +pprTyClDeclFlavour (DataDecl { tcdDataDefn = XHsDataDefn x }) + = ppr x +pprTyClDeclFlavour (XTyClDecl x) = ppr x + + +{- Note [CUSKs: complete user-supplied kind signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We kind-check declarations differently if they have a complete, user-supplied +kind signature (CUSK). This is because we can safely generalise a CUSKed +declaration before checking all of the others, supporting polymorphic recursion. +See https://gitlab.haskell.org/ghc/ghc/wikis/ghc-kinds/kind-inference#proposed-new-strategy +and #9200 for lots of discussion of how we got here. + +PRINCIPLE: + a type declaration has a CUSK iff we could produce a separate kind signature + for it, just like a type signature for a function, + looking only at the header of the declaration. + +Examples: + * data T1 (a :: *->*) (b :: *) = .... + -- Has CUSK; equivalant to T1 :: (*->*) -> * -> * + + * data T2 a b = ... + -- No CUSK; we do not want to guess T2 :: * -> * -> * + -- because the full decl might be data T a b = MkT (a b) + + * data T3 (a :: k -> *) (b :: *) = ... + -- CUSK; equivalent to T3 :: (k -> *) -> * -> * + -- We lexically generalise over k to get + -- T3 :: forall k. (k -> *) -> * -> * + -- The generalisation is here is purely lexical, just like + -- f3 :: a -> a + -- means + -- f3 :: forall a. a -> a + + * data T4 (a :: j k) = ... + -- CUSK; equivalent to T4 :: j k -> * + -- which we lexically generalise to T4 :: forall j k. j k -> * + -- and then, if PolyKinds is on, we further generalise to + -- T4 :: forall kk (j :: kk -> *) (k :: kk). j k -> * + -- Again this is exactly like what happens as the term level + -- when you write + -- f4 :: forall a b. a b -> Int + +NOTE THAT + * A CUSK does /not/ mean that everything about the kind signature is + fully specified by the user. Look at T4 and f4: we had do do kind + inference to figure out the kind-quantification. But in both cases + (T4 and f4) that inference is done looking /only/ at the header of T4 + (or signature for f4), not at the definition thereof. + + * The CUSK completely fixes the kind of the type constructor, forever. + + * The precise rules, for each declaration form, for whethher a declaration + has a CUSK are given in the user manual section "Complete user-supplied + kind signatures and polymorphic recursion". BUt they simply implement + PRINCIPLE above. + + * Open type families are interesting: + type family T5 a b :: * + There simply /is/ no accompanying declaration, so that info is all + we'll ever get. So we it has a CUSK by definition, and we default + any un-fixed kind variables to *. + + * Associated types are a bit tricker: + class C6 a where + type family T6 a b :: * + op :: a Int -> Int + Here C6 does not have a CUSK (in fact we ultimately discover that + a :: * -> *). And hence neither does T6, the associated family, + because we can't fix its kind until we have settled C6. Another + way to say it: unlike a top-level, we /may/ discover more about + a's kind from C6's definition. + + * A data definition with a top-level :: must explicitly bind all + kind variables to the right of the ::. See test + dependent/should_compile/KindLevels, which requires this + case. (Naturally, any kind variable mentioned before the :: should + not be bound after it.) + + This last point is much more debatable than the others; see + #15142 comment:22 +-} + + +{- ********************************************************************* +* * + TyClGroup + Strongly connected components of + type, class, instance, and role declarations +* * +********************************************************************* -} + +{- Note [TyClGroups and dependency analysis] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A TyClGroup represents a strongly connected components of type/class/instance +decls, together with the role annotations for the type/class declarations. + +The hs_tyclds :: [TyClGroup] field of a HsGroup is a dependency-order +sequence of strongly-connected components. + +Invariants + * The type and class declarations, group_tyclds, may depend on each + other, or earlier TyClGroups, but not on later ones + + * The role annotations, group_roles, are role-annotations for some or + all of the types and classes in group_tyclds (only). + + * The instance declarations, group_instds, may (and usually will) + depend on group_tyclds, or on earlier TyClGroups, but not on later + ones. + +See Note [Dependency analsis of type, class, and instance decls] +in RnSource for more info. +-} + +-- | Type or Class Group +data TyClGroup pass -- See Note [TyClGroups and dependency analysis] + = TyClGroup { group_ext :: XCTyClGroup pass + , group_tyclds :: [LTyClDecl pass] + , group_roles :: [LRoleAnnotDecl pass] + , group_instds :: [LInstDecl pass] } + | XTyClGroup (XXTyClGroup pass) + +type instance XCTyClGroup (GhcPass _) = NoExt +type instance XXTyClGroup (GhcPass _) = NoExt + + +emptyTyClGroup :: TyClGroup (GhcPass p) +emptyTyClGroup = TyClGroup noExt [] [] [] + +tyClGroupTyClDecls :: [TyClGroup pass] -> [LTyClDecl pass] +tyClGroupTyClDecls = concatMap group_tyclds + +tyClGroupInstDecls :: [TyClGroup pass] -> [LInstDecl pass] +tyClGroupInstDecls = concatMap group_instds + +tyClGroupRoleDecls :: [TyClGroup pass] -> [LRoleAnnotDecl pass] +tyClGroupRoleDecls = concatMap group_roles + +mkTyClGroup :: [LTyClDecl (GhcPass p)] -> [LInstDecl (GhcPass p)] + -> TyClGroup (GhcPass p) +mkTyClGroup decls instds = TyClGroup + { group_ext = noExt + , group_tyclds = decls + , group_roles = [] + , group_instds = instds + } + + + +{- ********************************************************************* +* * + Data and type family declarations +* * +********************************************************************* -} + +{- Note [FamilyResultSig] +~~~~~~~~~~~~~~~~~~~~~~~~~ + +This data type represents the return signature of a type family. Possible +values are: + + * NoSig - the user supplied no return signature: + type family Id a where ... + + * KindSig - the user supplied the return kind: + type family Id a :: * where ... + + * TyVarSig - user named the result with a type variable and possibly + provided a kind signature for that variable: + type family Id a = r where ... + type family Id a = (r :: *) where ... + + Naming result of a type family is required if we want to provide + injectivity annotation for a type family: + type family Id a = r | r -> a where ... + +See also: Note [Injectivity annotation] + +Note [Injectivity annotation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +A user can declare a type family to be injective: + + type family Id a = r | r -> a where ... + + * The part after the "|" is called "injectivity annotation". + * "r -> a" part is called "injectivity condition"; at the moment terms + "injectivity annotation" and "injectivity condition" are synonymous + because we only allow a single injectivity condition. + * "r" is the "LHS of injectivity condition". LHS can only contain the + variable naming the result of a type family. + + * "a" is the "RHS of injectivity condition". RHS contains space-separated + type and kind variables representing the arguments of a type + family. Variables can be omitted if a type family is not injective in + these arguments. Example: + type family Foo a b c = d | d -> a c where ... + +Note that: + (a) naming of type family result is required to provide injectivity + annotation + (b) for associated types if the result was named then injectivity annotation + is mandatory. Otherwise result type variable is indistinguishable from + associated type default. + +It is possible that in the future this syntax will be extended to support +more complicated injectivity annotations. For example we could declare that +if we know the result of Plus and one of its arguments we can determine the +other argument: + + type family Plus a b = (r :: Nat) | r a -> b, r b -> a where ... + +Here injectivity annotation would consist of two comma-separated injectivity +conditions. + +See also Note [Injective type families] in TyCon +-} + +-- | Located type Family Result Signature +type LFamilyResultSig pass = Located (FamilyResultSig pass) + +-- | type Family Result Signature +data FamilyResultSig pass = -- see Note [FamilyResultSig] + NoSig (XNoSig pass) + -- ^ - 'ApiAnnotation.AnnKeywordId' : + + -- For details on above see note [Api annotations] in ApiAnnotation + + | KindSig (XCKindSig pass) (LHsKind pass) + -- ^ - 'ApiAnnotation.AnnKeywordId' : + -- 'ApiAnnotation.AnnOpenP','ApiAnnotation.AnnDcolon', + -- 'ApiAnnotation.AnnCloseP' + + -- For details on above see note [Api annotations] in ApiAnnotation + + | TyVarSig (XTyVarSig pass) (LHsTyVarBndr pass) + -- ^ - 'ApiAnnotation.AnnKeywordId' : + -- 'ApiAnnotation.AnnOpenP','ApiAnnotation.AnnDcolon', + -- 'ApiAnnotation.AnnCloseP', 'ApiAnnotation.AnnEqual' + | XFamilyResultSig (XXFamilyResultSig pass) + + -- For details on above see note [Api annotations] in ApiAnnotation + +type instance XNoSig (GhcPass _) = NoExt +type instance XCKindSig (GhcPass _) = NoExt +type instance XTyVarSig (GhcPass _) = NoExt +type instance XXFamilyResultSig (GhcPass _) = NoExt + + +-- | Located type Family Declaration +type LFamilyDecl pass = Located (FamilyDecl pass) + +-- | type Family Declaration +data FamilyDecl pass = FamilyDecl + { fdExt :: XCFamilyDecl pass + , fdInfo :: FamilyInfo pass -- type/data, closed/open + , fdLName :: Located (IdP pass) -- type constructor + , fdTyVars :: LHsQTyVars pass -- type variables + -- See Note [TyVar binders for associated declarations] + , fdFixity :: LexicalFixity -- Fixity used in the declaration + , fdResultSig :: LFamilyResultSig pass -- result signature + , fdInjectivityAnn :: Maybe (LInjectivityAnn pass) -- optional injectivity ann + } + | XFamilyDecl (XXFamilyDecl pass) + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', + -- 'ApiAnnotation.AnnData', 'ApiAnnotation.AnnFamily', + -- 'ApiAnnotation.AnnWhere', 'ApiAnnotation.AnnOpenP', + -- 'ApiAnnotation.AnnDcolon', 'ApiAnnotation.AnnCloseP', + -- 'ApiAnnotation.AnnEqual', 'ApiAnnotation.AnnRarrow', + -- 'ApiAnnotation.AnnVbar' + + -- For details on above see note [Api annotations] in ApiAnnotation + +type instance XCFamilyDecl (GhcPass _) = NoExt +type instance XXFamilyDecl (GhcPass _) = NoExt + + +-- | Located Injectivity Annotation +type LInjectivityAnn pass = Located (InjectivityAnn pass) + +-- | If the user supplied an injectivity annotation it is represented using +-- InjectivityAnn. At the moment this is a single injectivity condition - see +-- Note [Injectivity annotation]. `Located name` stores the LHS of injectivity +-- condition. `[Located name]` stores the RHS of injectivity condition. Example: +-- +-- type family Foo a b c = r | r -> a c where ... +-- +-- This will be represented as "InjectivityAnn `r` [`a`, `c`]" +data InjectivityAnn pass + = InjectivityAnn (Located (IdP pass)) [Located (IdP pass)] + -- ^ - 'ApiAnnotation.AnnKeywordId' : + -- 'ApiAnnotation.AnnRarrow', 'ApiAnnotation.AnnVbar' + + -- For details on above see note [Api annotations] in ApiAnnotation + +data FamilyInfo pass + = DataFamily + | OpenTypeFamily + -- | 'Nothing' if we're in an hs-boot file and the user + -- said "type family Foo x where .." + | ClosedTypeFamily (Maybe [LTyFamInstEqn pass]) + +-- | Does this family declaration have a complete, user-supplied kind signature? +-- See Note [CUSKs: complete user-supplied kind signatures] +famDeclHasCusk :: Bool -- ^ True <=> this is an associated type family, + -- and the parent class has /no/ CUSK + -> FamilyDecl pass + -> Bool +famDeclHasCusk assoc_with_no_cusk + (FamilyDecl { fdInfo = fam_info + , fdTyVars = tyvars + , fdResultSig = L _ resultSig }) + = case fam_info of + ClosedTypeFamily {} -> hsTvbAllKinded tyvars + && hasReturnKindSignature resultSig + _ -> not assoc_with_no_cusk + -- Un-associated open type/data families have CUSKs + -- Associated type families have CUSKs iff the parent class does + +famDeclHasCusk _ (XFamilyDecl {}) = panic "famDeclHasCusk" + +-- | Does this family declaration have user-supplied return kind signature? +hasReturnKindSignature :: FamilyResultSig a -> Bool +hasReturnKindSignature (NoSig _) = False +hasReturnKindSignature (TyVarSig _ (L _ (UserTyVar{}))) = False +hasReturnKindSignature _ = True + +-- | Maybe return name of the result type variable +resultVariableName :: FamilyResultSig a -> Maybe (IdP a) +resultVariableName (TyVarSig _ sig) = Just $ hsLTyVarName sig +resultVariableName _ = Nothing + +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (FamilyDecl p) where + ppr = pprFamilyDecl TopLevel + +pprFamilyDecl :: (OutputableBndrId (GhcPass p)) + => TopLevelFlag -> FamilyDecl (GhcPass p) -> SDoc +pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon + , fdTyVars = tyvars + , fdFixity = fixity + , fdResultSig = L _ result + , fdInjectivityAnn = mb_inj }) + = vcat [ pprFlavour info <+> pp_top_level <+> + pp_vanilla_decl_head ltycon tyvars fixity noLHsContext <+> + pp_kind <+> pp_inj <+> pp_where + , nest 2 $ pp_eqns ] + where + pp_top_level = case top_level of + TopLevel -> text "family" + NotTopLevel -> empty + + pp_kind = case result of + NoSig _ -> empty + KindSig _ kind -> dcolon <+> ppr kind + TyVarSig _ tv_bndr -> text "=" <+> ppr tv_bndr + XFamilyResultSig x -> ppr x + pp_inj = case mb_inj of + Just (L _ (InjectivityAnn lhs rhs)) -> + hsep [ vbar, ppr lhs, text "->", hsep (map ppr rhs) ] + Nothing -> empty + (pp_where, pp_eqns) = case info of + ClosedTypeFamily mb_eqns -> + ( text "where" + , case mb_eqns of + Nothing -> text ".." + Just eqns -> vcat $ map (ppr_fam_inst_eqn . unLoc) eqns ) + _ -> (empty, empty) +pprFamilyDecl _ (XFamilyDecl x) = ppr x + +pprFlavour :: FamilyInfo pass -> SDoc +pprFlavour DataFamily = text "data" +pprFlavour OpenTypeFamily = text "type" +pprFlavour (ClosedTypeFamily {}) = text "type" + +instance Outputable (FamilyInfo pass) where + ppr info = pprFlavour info <+> text "family" + + + +{- ********************************************************************* +* * + Data types and data constructors +* * +********************************************************************* -} + +-- | Haskell Data type Definition +data HsDataDefn pass -- The payload of a data type defn + -- Used *both* for vanilla data declarations, + -- *and* for data family instances + = -- | Declares a data type or newtype, giving its constructors + -- @ + -- data/newtype T a = + -- data/newtype instance T [a] = + -- @ + HsDataDefn { dd_ext :: XCHsDataDefn pass, + dd_ND :: NewOrData, + dd_ctxt :: LHsContext pass, -- ^ Context + dd_cType :: Maybe (Located CType), + dd_kindSig:: Maybe (LHsKind pass), + -- ^ Optional kind signature. + -- + -- @(Just k)@ for a GADT-style @data@, + -- or @data instance@ decl, with explicit kind sig + -- + -- Always @Nothing@ for H98-syntax decls + + dd_cons :: [LConDecl pass], + -- ^ Data constructors + -- + -- For @data T a = T1 | T2 a@ + -- the 'LConDecl's all have 'ConDeclH98'. + -- For @data T a where { T1 :: T a }@ + -- the 'LConDecls' all have 'ConDeclGADT'. + + dd_derivs :: HsDeriving pass -- ^ Optional 'deriving' claues + + -- For details on above see note [Api annotations] in ApiAnnotation + } + | XHsDataDefn (XXHsDataDefn pass) + +type instance XCHsDataDefn (GhcPass _) = NoExt +type instance XXHsDataDefn (GhcPass _) = NoExt + +-- | Haskell Deriving clause +type HsDeriving pass = Located [LHsDerivingClause pass] + -- ^ The optional @deriving@ clauses of a data declaration. "Clauses" is + -- plural because one can specify multiple deriving clauses using the + -- @-XDerivingStrategies@ language extension. + -- + -- The list of 'LHsDerivingClause's corresponds to exactly what the user + -- requested to derive, in order. If no deriving clauses were specified, + -- the list is empty. + +type LHsDerivingClause pass = Located (HsDerivingClause pass) + +-- | A single @deriving@ clause of a data declaration. +-- +-- - 'ApiAnnotation.AnnKeywordId' : +-- 'ApiAnnotation.AnnDeriving', 'ApiAnnotation.AnnStock', +-- 'ApiAnnotation.AnnAnyClass', 'Api.AnnNewtype', +-- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose' +data HsDerivingClause pass + -- See Note [Deriving strategies] in TcDeriv + = HsDerivingClause + { deriv_clause_ext :: XCHsDerivingClause pass + , deriv_clause_strategy :: Maybe (LDerivStrategy pass) + -- ^ The user-specified strategy (if any) to use when deriving + -- 'deriv_clause_tys'. + , deriv_clause_tys :: Located [LHsSigType pass] + -- ^ The types to derive. + -- + -- It uses 'LHsSigType's because, with @-XGeneralizedNewtypeDeriving@, + -- we can mention type variables that aren't bound by the datatype, e.g. + -- + -- > data T b = ... deriving (C [a]) + -- + -- should produce a derived instance for @C [a] (T b)@. + } + | XHsDerivingClause (XXHsDerivingClause pass) + +type instance XCHsDerivingClause (GhcPass _) = NoExt +type instance XXHsDerivingClause (GhcPass _) = NoExt + +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (HsDerivingClause p) where + ppr (HsDerivingClause { deriv_clause_strategy = dcs + , deriv_clause_tys = L _ dct }) + = hsep [ text "deriving" + , pp_strat_before + , pp_dct dct + , pp_strat_after ] + where + -- This complexity is to distinguish between + -- deriving Show + -- deriving (Show) + pp_dct [HsIB { hsib_body = ty }] + = ppr (parenthesizeHsType appPrec ty) + pp_dct _ = parens (interpp'SP dct) + + -- @via@ is unique in that in comes /after/ the class being derived, + -- so we must special-case it. + (pp_strat_before, pp_strat_after) = + case dcs of + Just (L _ via@ViaStrategy{}) -> (empty, ppr via) + _ -> (ppDerivStrategy dcs, empty) + ppr (XHsDerivingClause x) = ppr x + +data NewOrData + = NewType -- ^ @newtype Blah ...@ + | DataType -- ^ @data Blah ...@ + deriving( Eq, Data ) -- Needed because Demand derives Eq + +-- | Convert a 'NewOrData' to a 'TyConFlavour' +newOrDataToFlavour :: NewOrData -> TyConFlavour +newOrDataToFlavour NewType = NewtypeFlavour +newOrDataToFlavour DataType = DataTypeFlavour + +-- | Located data Constructor Declaration +type LConDecl pass = Located (ConDecl pass) + -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when + -- in a GADT constructor list + + -- For details on above see note [Api annotations] in ApiAnnotation + +-- | +-- +-- @ +-- data T b = forall a. Eq a => MkT a b +-- MkT :: forall b a. Eq a => MkT a b +-- +-- data T b where +-- MkT1 :: Int -> T Int +-- +-- data T = Int `MkT` Int +-- | MkT2 +-- +-- data T a where +-- Int `MkT` Int :: T Int +-- @ +-- +-- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen', +-- 'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnCLose', +-- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnVbar', +-- 'ApiAnnotation.AnnDarrow','ApiAnnotation.AnnDarrow', +-- 'ApiAnnotation.AnnForall','ApiAnnotation.AnnDot' + +-- For details on above see note [Api annotations] in ApiAnnotation + +-- | data Constructor Declaration +data ConDecl pass + = ConDeclGADT + { con_g_ext :: XConDeclGADT pass + , con_names :: [Located (IdP pass)] + + -- The next four fields describe the type after the '::' + -- See Note [GADT abstract syntax] + -- The following field is Located to anchor API Annotations, + -- AnnForall and AnnDot. + , con_forall :: Located Bool -- ^ True <=> explicit forall + -- False => hsq_explicit is empty + , con_qvars :: LHsQTyVars pass + -- Whether or not there is an /explicit/ forall, we still + -- need to capture the implicitly-bound type/kind variables + + , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any) + , con_args :: HsConDeclDetails pass -- ^ Arguments; never InfixCon + , con_res_ty :: LHsType pass -- ^ Result type + + , con_doc :: Maybe LHsDocString + -- ^ A possible Haddock comment. + } + + | ConDeclH98 + { con_ext :: XConDeclH98 pass + , con_name :: Located (IdP pass) + + , con_forall :: Located Bool + -- ^ True <=> explicit user-written forall + -- e.g. data T a = forall b. MkT b (b->a) + -- con_ex_tvs = {b} + -- False => con_ex_tvs is empty + , con_ex_tvs :: [LHsTyVarBndr pass] -- ^ Existentials only + , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any) + , con_args :: HsConDeclDetails pass -- ^ Arguments; can be InfixCon + + , con_doc :: Maybe LHsDocString + -- ^ A possible Haddock comment. + } + | XConDecl (XXConDecl pass) + +type instance XConDeclGADT (GhcPass _) = NoExt +type instance XConDeclH98 (GhcPass _) = NoExt +type instance XXConDecl (GhcPass _) = NoExt + +{- Note [GADT abstract syntax] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There's a wrinkle in ConDeclGADT + +* For record syntax, it's all uniform. Given: + data T a where + K :: forall a. Ord a => { x :: [a], ... } -> T a + we make the a ConDeclGADT for K with + con_qvars = {a} + con_mb_cxt = Just [Ord a] + con_args = RecCon + con_res_ty = T a + + We need the RecCon before the reanmer, so we can find the record field + binders in HsUtils.hsConDeclsBinders. + +* However for a GADT constr declaration which is not a record, it can + be hard parse until we know operator fixities. Consider for example + C :: a :*: b -> a :*: b -> a :+: b + Initially this type will parse as + a :*: (b -> (a :*: (b -> (a :+: b)))) + so it's hard to split up the arguments until we've done the precedence + resolution (in the renamer). + + So: - In the parser (RdrHsSyn.mkGadtDecl), we put the whole constr + type into the res_ty for a ConDeclGADT for now, and use + PrefixCon [] + con_args = PrefixCon [] + con_res_ty = a :*: (b -> (a :*: (b -> (a :+: b)))) + + - In the renamer (RnSource.rnConDecl), we unravel it afer + operator fixities are sorted. So we generate. So we end + up with + con_args = PrefixCon [ a :*: b, a :*: b ] + con_res_ty = a :+: b +-} + +-- | Haskell data Constructor Declaration Details +type HsConDeclDetails pass + = HsConDetails (LBangType pass) (Located [LConDeclField pass]) + +getConNames :: ConDecl pass -> [Located (IdP pass)] +getConNames ConDeclH98 {con_name = name} = [name] +getConNames ConDeclGADT {con_names = names} = names +getConNames XConDecl {} = panic "getConNames" + +getConArgs :: ConDecl pass -> HsConDeclDetails pass +getConArgs d = con_args d + +hsConDeclArgTys :: HsConDeclDetails pass -> [LBangType pass] +hsConDeclArgTys (PrefixCon tys) = tys +hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2] +hsConDeclArgTys (RecCon flds) = map (cd_fld_type . unLoc) (unLoc flds) + +hsConDeclTheta :: Maybe (LHsContext pass) -> [LHsType pass] +hsConDeclTheta Nothing = [] +hsConDeclTheta (Just (L _ theta)) = theta + +pp_data_defn :: (OutputableBndrId (GhcPass p)) + => (LHsContext (GhcPass p) -> SDoc) -- Printing the header + -> HsDataDefn (GhcPass p) + -> SDoc +pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = context + , dd_cType = mb_ct + , dd_kindSig = mb_sig + , dd_cons = condecls, dd_derivs = derivings }) + | null condecls + = ppr new_or_data <+> pp_ct <+> pp_hdr context <+> pp_sig + <+> pp_derivings derivings + + | otherwise + = hang (ppr new_or_data <+> pp_ct <+> pp_hdr context <+> pp_sig) + 2 (pp_condecls condecls $$ pp_derivings derivings) + where + pp_ct = case mb_ct of + Nothing -> empty + Just ct -> ppr ct + pp_sig = case mb_sig of + Nothing -> empty + Just kind -> dcolon <+> ppr kind + pp_derivings (L _ ds) = vcat (map ppr ds) +pp_data_defn _ (XHsDataDefn x) = ppr x + +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (HsDataDefn p) where + ppr d = pp_data_defn (\_ -> text "Naked HsDataDefn") d + +instance Outputable NewOrData where + ppr NewType = text "newtype" + ppr DataType = text "data" + +pp_condecls :: (OutputableBndrId (GhcPass p)) => [LConDecl (GhcPass p)] -> SDoc +pp_condecls cs@(L _ ConDeclGADT{} : _) -- In GADT syntax + = hang (text "where") 2 (vcat (map ppr cs)) +pp_condecls cs -- In H98 syntax + = equals <+> sep (punctuate (text " |") (map ppr cs)) + +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (ConDecl p) where + ppr = pprConDecl + +pprConDecl :: (OutputableBndrId (GhcPass p)) => ConDecl (GhcPass p) -> SDoc +pprConDecl (ConDeclH98 { con_name = L _ con + , con_ex_tvs = ex_tvs + , con_mb_cxt = mcxt + , con_args = args + , con_doc = doc }) + = sep [ppr_mbDoc doc, pprHsForAll ForallInvis ex_tvs cxt, ppr_details args] + where + ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprInfixOcc con, ppr t2] + ppr_details (PrefixCon tys) = hsep (pprPrefixOcc con + : map (pprHsType . unLoc) tys) + ppr_details (RecCon fields) = pprPrefixOcc con + <+> pprConDeclFields (unLoc fields) + cxt = fromMaybe noLHsContext mcxt + +pprConDecl (ConDeclGADT { con_names = cons, con_qvars = qvars + , con_mb_cxt = mcxt, con_args = args + , con_res_ty = res_ty, con_doc = doc }) + = ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon + <+> (sep [pprHsForAll ForallInvis (hsq_explicit qvars) cxt, + ppr_arrow_chain (get_args args ++ [ppr res_ty]) ]) + where + get_args (PrefixCon args) = map ppr args + get_args (RecCon fields) = [pprConDeclFields (unLoc fields)] + get_args (InfixCon {}) = pprPanic "pprConDecl:GADT" (ppr cons) + + cxt = fromMaybe noLHsContext mcxt + + ppr_arrow_chain (a:as) = sep (a : map (arrow <+>) as) + ppr_arrow_chain [] = empty + +pprConDecl (XConDecl x) = ppr x + +ppr_con_names :: (OutputableBndr a) => [Located a] -> SDoc +ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc) + +{- +************************************************************************ +* * + Instance declarations +* * +************************************************************************ + +Note [Type family instance declarations in HsSyn] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The data type FamEqn represents one equation of a type family instance. +Aside from the pass, it is also parameterised over two fields: +feqn_pats and feqn_rhs. + +feqn_pats is either LHsTypes (for ordinary data/type family instances) or +LHsQTyVars (for associated type family default instances). In particular: + + * An ordinary type family instance declaration looks like this in source Haskell + type instance T [a] Int = a -> a + (or something similar for a closed family) + It is represented by a FamInstEqn, with a *type* (LHsType) in the feqn_pats + field. + + * On the other hand, the *default instance* of an associated type looks like + this in source Haskell + class C a where + type T a b + type T a b = a -> b -- The default instance + It is represented by a TyFamDefltEqn, with *type variables* (LHsQTyVars) in + the feqn_pats field. + +feqn_rhs is either an HsDataDefn (for data family instances) or an LHsType +(for type family instances). +-} + +----------------- Type synonym family instances ------------- + +-- | Located Type Family Instance Equation +type LTyFamInstEqn pass = Located (TyFamInstEqn pass) + -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' + -- when in a list + +-- For details on above see note [Api annotations] in ApiAnnotation + +-- | Located Type Family Default Equation +type LTyFamDefltEqn pass = Located (TyFamDefltEqn pass) + +-- | Haskell Type Patterns +type HsTyPats pass = [LHsTypeArg pass] + +{- Note [Family instance declaration binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For ordinary data/type family instances, the feqn_pats field of FamEqn stores +the LHS type (and kind) patterns. Any type (and kind) variables contained +in these type patterns are bound in the hsib_vars field of the HsImplicitBndrs +in FamInstEqn depending on whether or not an explicit forall is present. In +the case of an explicit forall, the hsib_vars only includes kind variables not +bound in the forall. Otherwise, all type (and kind) variables are bound in +the hsib_vars. In the latter case, note that in particular + +* The hsib_vars *includes* any anonymous wildcards. For example + type instance F a _ = a + The hsib_vars will be {a, _}. Remember that each separate wildcard + '_' gets its own unique. In this context wildcards behave just like + an ordinary type variable, only anonymous. + +* The hsib_vars *includes* type variables that are already in scope + + Eg class C s t where + type F t p :: * + instance C w (a,b) where + type F (a,b) x = x->a + The hsib_vars of the F decl are {a,b,x}, even though the F decl + is nested inside the 'instance' decl. + + However after the renamer, the uniques will match up: + instance C w7 (a8,b9) where + type F (a8,b9) x10 = x10->a8 + so that we can compare the type pattern in the 'instance' decl and + in the associated 'type' decl + +For associated type family default instances (TyFamDefltEqn), instead of using +type patterns with binders in a surrounding HsImplicitBndrs, we use raw type +variables (LHsQTyVars) in the feqn_pats field of FamEqn. + +c.f. Note [TyVar binders for associated declarations] +-} + +-- | Type Family Instance Equation +type TyFamInstEqn pass = FamInstEqn pass (LHsType pass) + +-- | Type Family Default Equation +type TyFamDefltEqn pass = FamEqn pass (LHsQTyVars pass) (LHsType pass) + -- See Note [Type family instance declarations in HsSyn] + +-- | Located Type Family Instance Declaration +type LTyFamInstDecl pass = Located (TyFamInstDecl pass) + +-- | Type Family Instance Declaration +newtype TyFamInstDecl pass = TyFamInstDecl { tfid_eqn :: TyFamInstEqn pass } + -- ^ + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', + -- 'ApiAnnotation.AnnInstance', + + -- For details on above see note [Api annotations] in ApiAnnotation + +----------------- Data family instances ------------- + +-- | Located Data Family Instance Declaration +type LDataFamInstDecl pass = Located (DataFamInstDecl pass) + +-- | Data Family Instance Declaration +newtype DataFamInstDecl pass + = DataFamInstDecl { dfid_eqn :: FamInstEqn pass (HsDataDefn pass) } + -- ^ + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnData', + -- 'ApiAnnotation.AnnNewType','ApiAnnotation.AnnInstance', + -- 'ApiAnnotation.AnnDcolon' + -- 'ApiAnnotation.AnnWhere','ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + +----------------- Family instances (common types) ------------- + +-- | Located Family Instance Equation +type LFamInstEqn pass rhs = Located (FamInstEqn pass rhs) + +-- | Family Instance Equation +type FamInstEqn pass rhs + = HsImplicitBndrs pass (FamEqn pass (HsTyPats pass) rhs) + -- ^ Here, the @pats@ are type patterns (with kind and type bndrs). + -- See Note [Family instance declaration binders] + +-- | Family Equation +-- +-- One equation in a type family instance declaration, data family instance +-- declaration, or type family default. +-- See Note [Type family instance declarations in HsSyn] +-- See Note [Family instance declaration binders] +data FamEqn pass pats rhs + = FamEqn + { feqn_ext :: XCFamEqn pass pats rhs + , feqn_tycon :: Located (IdP pass) + , feqn_bndrs :: Maybe [LHsTyVarBndr pass] -- ^ Optional quantified type vars + , feqn_pats :: pats + , feqn_fixity :: LexicalFixity -- ^ Fixity used in the declaration + , feqn_rhs :: rhs + } + -- ^ + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual' + | XFamEqn (XXFamEqn pass pats rhs) + + -- For details on above see note [Api annotations] in ApiAnnotation + +type instance XCFamEqn (GhcPass _) p r = NoExt +type instance XXFamEqn (GhcPass _) p r = NoExt + +----------------- Class instances ------------- + +-- | Located Class Instance Declaration +type LClsInstDecl pass = Located (ClsInstDecl pass) + +-- | Class Instance Declaration +data ClsInstDecl pass + = ClsInstDecl + { cid_ext :: XCClsInstDecl pass + , cid_poly_ty :: LHsSigType pass -- Context => Class Instance-type + -- Using a polytype means that the renamer conveniently + -- figures out the quantified type variables for us. + , cid_binds :: LHsBinds pass -- Class methods + , cid_sigs :: [LSig pass] -- User-supplied pragmatic info + , cid_tyfam_insts :: [LTyFamInstDecl pass] -- Type family instances + , cid_datafam_insts :: [LDataFamInstDecl pass] -- Data family instances + , cid_overlap_mode :: Maybe (Located OverlapMode) + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnClose', + + -- For details on above see note [Api annotations] in ApiAnnotation + } + -- ^ + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnInstance', + -- 'ApiAnnotation.AnnWhere', + -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose', + + -- For details on above see note [Api annotations] in ApiAnnotation + | XClsInstDecl (XXClsInstDecl pass) + +type instance XCClsInstDecl (GhcPass _) = NoExt +type instance XXClsInstDecl (GhcPass _) = NoExt + +----------------- Instances of all kinds ------------- + +-- | Located Instance Declaration +type LInstDecl pass = Located (InstDecl pass) + +-- | Instance Declaration +data InstDecl pass -- Both class and family instances + = ClsInstD + { cid_d_ext :: XClsInstD pass + , cid_inst :: ClsInstDecl pass } + | DataFamInstD -- data family instance + { dfid_ext :: XDataFamInstD pass + , dfid_inst :: DataFamInstDecl pass } + | TyFamInstD -- type family instance + { tfid_ext :: XTyFamInstD pass + , tfid_inst :: TyFamInstDecl pass } + | XInstDecl (XXInstDecl pass) + +type instance XClsInstD (GhcPass _) = NoExt +type instance XDataFamInstD (GhcPass _) = NoExt +type instance XTyFamInstD (GhcPass _) = NoExt +type instance XXInstDecl (GhcPass _) = NoExt + +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (TyFamInstDecl p) where + ppr = pprTyFamInstDecl TopLevel + +pprTyFamInstDecl :: (OutputableBndrId (GhcPass p)) + => TopLevelFlag -> TyFamInstDecl (GhcPass p) -> SDoc +pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_eqn = eqn }) + = text "type" <+> ppr_instance_keyword top_lvl <+> ppr_fam_inst_eqn eqn + +ppr_instance_keyword :: TopLevelFlag -> SDoc +ppr_instance_keyword TopLevel = text "instance" +ppr_instance_keyword NotTopLevel = empty + +ppr_fam_inst_eqn :: (OutputableBndrId (GhcPass p)) + => TyFamInstEqn (GhcPass p) -> SDoc +ppr_fam_inst_eqn (HsIB { hsib_body = FamEqn { feqn_tycon = L _ tycon + , feqn_bndrs = bndrs + , feqn_pats = pats + , feqn_fixity = fixity + , feqn_rhs = rhs }}) + = pprHsFamInstLHS tycon bndrs pats fixity noLHsContext <+> equals <+> ppr rhs +ppr_fam_inst_eqn (HsIB { hsib_body = XFamEqn x }) = ppr x +ppr_fam_inst_eqn (XHsImplicitBndrs x) = ppr x + +ppr_fam_deflt_eqn :: (OutputableBndrId (GhcPass p)) + => LTyFamDefltEqn (GhcPass p) -> SDoc +ppr_fam_deflt_eqn (L _ (FamEqn { feqn_tycon = tycon + , feqn_pats = tvs + , feqn_fixity = fixity + , feqn_rhs = rhs })) + = text "type" <+> pp_vanilla_decl_head tycon tvs fixity noLHsContext + <+> equals <+> ppr rhs +ppr_fam_deflt_eqn (L _ (XFamEqn x)) = ppr x + +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (DataFamInstDecl p) where + ppr = pprDataFamInstDecl TopLevel + +pprDataFamInstDecl :: (OutputableBndrId (GhcPass p)) + => TopLevelFlag -> DataFamInstDecl (GhcPass p) -> SDoc +pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = + FamEqn { feqn_tycon = L _ tycon + , feqn_bndrs = bndrs + , feqn_pats = pats + , feqn_fixity = fixity + , feqn_rhs = defn }}}) + = pp_data_defn pp_hdr defn + where + pp_hdr ctxt = ppr_instance_keyword top_lvl + <+> pprHsFamInstLHS tycon bndrs pats fixity ctxt + -- pp_data_defn pretty-prints the kind sig. See #14817. + +pprDataFamInstDecl _ (DataFamInstDecl (HsIB _ (XFamEqn x))) + = ppr x +pprDataFamInstDecl _ (DataFamInstDecl (XHsImplicitBndrs x)) + = ppr x + +pprDataFamInstFlavour :: DataFamInstDecl (GhcPass p) -> SDoc +pprDataFamInstFlavour (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = + FamEqn { feqn_rhs = HsDataDefn { dd_ND = nd }}}}) + = ppr nd +pprDataFamInstFlavour (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = + FamEqn { feqn_rhs = XHsDataDefn x}}}) + = ppr x +pprDataFamInstFlavour (DataFamInstDecl (HsIB _ (XFamEqn x))) + = ppr x +pprDataFamInstFlavour (DataFamInstDecl (XHsImplicitBndrs x)) + = ppr x + +pprHsFamInstLHS :: (OutputableBndrId (GhcPass p)) + => IdP (GhcPass p) + -> Maybe [LHsTyVarBndr (GhcPass p)] + -> HsTyPats (GhcPass p) + -> LexicalFixity + -> LHsContext (GhcPass p) + -> SDoc +pprHsFamInstLHS thing bndrs typats fixity mb_ctxt + = hsep [ pprHsExplicitForAll ForallInvis bndrs + , pprLHsContext mb_ctxt + , pp_pats typats ] + where + pp_pats (patl:patr:pats) + | Infix <- fixity + = let pp_op_app = hsep [ ppr patl, pprInfixOcc thing, ppr patr ] in + case pats of + [] -> pp_op_app + _ -> hsep (parens pp_op_app : map ppr pats) + + pp_pats pats = hsep [ pprPrefixOcc thing + , hsep (map ppr pats)] + +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (ClsInstDecl p) where + ppr (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds + , cid_sigs = sigs, cid_tyfam_insts = ats + , cid_overlap_mode = mbOverlap + , cid_datafam_insts = adts }) + | null sigs, null ats, null adts, isEmptyBag binds -- No "where" part + = top_matter + + | otherwise -- Laid out + = vcat [ top_matter <+> text "where" + , nest 2 $ pprDeclList $ + map (pprTyFamInstDecl NotTopLevel . unLoc) ats ++ + map (pprDataFamInstDecl NotTopLevel . unLoc) adts ++ + pprLHsBindsForUser binds sigs ] + where + top_matter = text "instance" <+> ppOverlapPragma mbOverlap + <+> ppr inst_ty + ppr (XClsInstDecl x) = ppr x + +ppDerivStrategy :: (p ~ GhcPass pass, OutputableBndrId p) + => Maybe (LDerivStrategy p) -> SDoc +ppDerivStrategy mb = + case mb of + Nothing -> empty + Just (L _ ds) -> ppr ds + +ppOverlapPragma :: Maybe (Located OverlapMode) -> SDoc +ppOverlapPragma mb = + case mb of + Nothing -> empty + Just (L _ (NoOverlap s)) -> maybe_stext s "{-# NO_OVERLAP #-}" + Just (L _ (Overlappable s)) -> maybe_stext s "{-# OVERLAPPABLE #-}" + Just (L _ (Overlapping s)) -> maybe_stext s "{-# OVERLAPPING #-}" + Just (L _ (Overlaps s)) -> maybe_stext s "{-# OVERLAPS #-}" + Just (L _ (Incoherent s)) -> maybe_stext s "{-# INCOHERENT #-}" + where + maybe_stext NoSourceText alt = text alt + maybe_stext (SourceText src) _ = text src <+> text "#-}" + + +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (InstDecl p) where + ppr (ClsInstD { cid_inst = decl }) = ppr decl + ppr (TyFamInstD { tfid_inst = decl }) = ppr decl + ppr (DataFamInstD { dfid_inst = decl }) = ppr decl + ppr (XInstDecl x) = ppr x + +-- Extract the declarations of associated data types from an instance + +instDeclDataFamInsts :: [LInstDecl pass] -> [DataFamInstDecl pass] +instDeclDataFamInsts inst_decls + = concatMap do_one inst_decls + where + do_one (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fam_insts } })) + = map unLoc fam_insts + do_one (L _ (DataFamInstD { dfid_inst = fam_inst })) = [fam_inst] + do_one (L _ (TyFamInstD {})) = [] + do_one (L _ (ClsInstD _ (XClsInstDecl _))) = panic "instDeclDataFamInsts" + do_one (L _ (XInstDecl _)) = panic "instDeclDataFamInsts" + +{- +************************************************************************ +* * +\subsection[DerivDecl]{A stand-alone instance deriving declaration} +* * +************************************************************************ +-} + +-- | Located stand-alone 'deriving instance' declaration +type LDerivDecl pass = Located (DerivDecl pass) + +-- | Stand-alone 'deriving instance' declaration +data DerivDecl pass = DerivDecl + { deriv_ext :: XCDerivDecl pass + , deriv_type :: LHsSigWcType pass + -- ^ The instance type to derive. + -- + -- It uses an 'LHsSigWcType' because the context is allowed to be a + -- single wildcard: + -- + -- > deriving instance _ => Eq (Foo a) + -- + -- Which signifies that the context should be inferred. + + -- See Note [Inferring the instance context] in TcDerivInfer. + + , deriv_strategy :: Maybe (LDerivStrategy pass) + , deriv_overlap_mode :: Maybe (Located OverlapMode) + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDeriving', + -- 'ApiAnnotation.AnnInstance', 'ApiAnnotation.AnnStock', + -- 'ApiAnnotation.AnnAnyClass', 'Api.AnnNewtype', + -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + } + | XDerivDecl (XXDerivDecl pass) + +type instance XCDerivDecl (GhcPass _) = NoExt +type instance XXDerivDecl (GhcPass _) = NoExt + +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (DerivDecl p) where + ppr (DerivDecl { deriv_type = ty + , deriv_strategy = ds + , deriv_overlap_mode = o }) + = hsep [ text "deriving" + , ppDerivStrategy ds + , text "instance" + , ppOverlapPragma o + , ppr ty ] + ppr (XDerivDecl x) = ppr x + +{- +************************************************************************ +* * + Deriving strategies +* * +************************************************************************ +-} + +-- | A 'Located' 'DerivStrategy'. +type LDerivStrategy pass = Located (DerivStrategy pass) + +-- | Which technique the user explicitly requested when deriving an instance. +data DerivStrategy pass + -- See Note [Deriving strategies] in TcDeriv + = StockStrategy -- ^ GHC's \"standard\" strategy, which is to implement a + -- custom instance for the data type. This only works + -- for certain types that GHC knows about (e.g., 'Eq', + -- 'Show', 'Functor' when @-XDeriveFunctor@ is enabled, + -- etc.) + | AnyclassStrategy -- ^ @-XDeriveAnyClass@ + | NewtypeStrategy -- ^ @-XGeneralizedNewtypeDeriving@ + | ViaStrategy (XViaStrategy pass) + -- ^ @-XDerivingVia@ + +type instance XViaStrategy GhcPs = LHsSigType GhcPs +type instance XViaStrategy GhcRn = LHsSigType GhcRn +type instance XViaStrategy GhcTc = Type + +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (DerivStrategy p) where + ppr StockStrategy = text "stock" + ppr AnyclassStrategy = text "anyclass" + ppr NewtypeStrategy = text "newtype" + ppr (ViaStrategy ty) = text "via" <+> ppr ty + +-- | A short description of a @DerivStrategy'@. +derivStrategyName :: DerivStrategy a -> SDoc +derivStrategyName = text . go + where + go StockStrategy = "stock" + go AnyclassStrategy = "anyclass" + go NewtypeStrategy = "newtype" + go (ViaStrategy {}) = "via" + +{- +************************************************************************ +* * +\subsection[DefaultDecl]{A @default@ declaration} +* * +************************************************************************ + +There can only be one default declaration per module, but it is hard +for the parser to check that; we pass them all through in the abstract +syntax, and that restriction must be checked in the front end. +-} + +-- | Located Default Declaration +type LDefaultDecl pass = Located (DefaultDecl pass) + +-- | Default Declaration +data DefaultDecl pass + = DefaultDecl (XCDefaultDecl pass) [LHsType pass] + -- ^ - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnDefault', + -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + | XDefaultDecl (XXDefaultDecl pass) + +type instance XCDefaultDecl (GhcPass _) = NoExt +type instance XXDefaultDecl (GhcPass _) = NoExt + +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (DefaultDecl p) where + ppr (DefaultDecl _ tys) + = text "default" <+> parens (interpp'SP tys) + ppr (XDefaultDecl x) = ppr x + +{- +************************************************************************ +* * +\subsection{Foreign function interface declaration} +* * +************************************************************************ +-} + +-- foreign declarations are distinguished as to whether they define or use a +-- Haskell name +-- +-- * the Boolean value indicates whether the pre-standard deprecated syntax +-- has been used + +-- | Located Foreign Declaration +type LForeignDecl pass = Located (ForeignDecl pass) + +-- | Foreign Declaration +data ForeignDecl pass + = ForeignImport + { fd_i_ext :: XForeignImport pass -- Post typechecker, rep_ty ~ sig_ty + , fd_name :: Located (IdP pass) -- defines this name + , fd_sig_ty :: LHsSigType pass -- sig_ty + , fd_fi :: ForeignImport } + + | ForeignExport + { fd_e_ext :: XForeignExport pass -- Post typechecker, rep_ty ~ sig_ty + , fd_name :: Located (IdP pass) -- uses this name + , fd_sig_ty :: LHsSigType pass -- sig_ty + , fd_fe :: ForeignExport } + -- ^ + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnForeign', + -- 'ApiAnnotation.AnnImport','ApiAnnotation.AnnExport', + -- 'ApiAnnotation.AnnDcolon' + + -- For details on above see note [Api annotations] in ApiAnnotation + | XForeignDecl (XXForeignDecl pass) + +{- + In both ForeignImport and ForeignExport: + sig_ty is the type given in the Haskell code + rep_ty is the representation for this type, i.e. with newtypes + coerced away and type functions evaluated. + Thus if the declaration is valid, then rep_ty will only use types + such as Int and IO that we know how to make foreign calls with. +-} + +type instance XForeignImport GhcPs = NoExt +type instance XForeignImport GhcRn = NoExt +type instance XForeignImport GhcTc = Coercion + +type instance XForeignExport GhcPs = NoExt +type instance XForeignExport GhcRn = NoExt +type instance XForeignExport GhcTc = Coercion + +type instance XXForeignDecl (GhcPass _) = NoExt + +-- Specification Of an imported external entity in dependence on the calling +-- convention +-- +data ForeignImport = -- import of a C entity + -- + -- * the two strings specifying a header file or library + -- may be empty, which indicates the absence of a + -- header or object specification (both are not used + -- in the case of `CWrapper' and when `CFunction' + -- has a dynamic target) + -- + -- * the calling convention is irrelevant for code + -- generation in the case of `CLabel', but is needed + -- for pretty printing + -- + -- * `Safety' is irrelevant for `CLabel' and `CWrapper' + -- + CImport (Located CCallConv) -- ccall or stdcall + (Located Safety) -- interruptible, safe or unsafe + (Maybe Header) -- name of C header + CImportSpec -- details of the C entity + (Located SourceText) -- original source text for + -- the C entity + deriving Data + +-- details of an external C entity +-- +data CImportSpec = CLabel CLabelString -- import address of a C label + | CFunction CCallTarget -- static or dynamic function + | CWrapper -- wrapper to expose closures + -- (former f.e.d.) + deriving Data + +-- specification of an externally exported entity in dependence on the calling +-- convention +-- +data ForeignExport = CExport (Located CExportSpec) -- contains the calling + -- convention + (Located SourceText) -- original source text for + -- the C entity + deriving Data + +-- pretty printing of foreign declarations +-- + +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (ForeignDecl p) where + ppr (ForeignImport { fd_name = n, fd_sig_ty = ty, fd_fi = fimport }) + = hang (text "foreign import" <+> ppr fimport <+> ppr n) + 2 (dcolon <+> ppr ty) + ppr (ForeignExport { fd_name = n, fd_sig_ty = ty, fd_fe = fexport }) = + hang (text "foreign export" <+> ppr fexport <+> ppr n) + 2 (dcolon <+> ppr ty) + ppr (XForeignDecl x) = ppr x + +instance Outputable ForeignImport where + ppr (CImport cconv safety mHeader spec (L _ srcText)) = + ppr cconv <+> ppr safety + <+> pprWithSourceText srcText (pprCEntity spec "") + where + pp_hdr = case mHeader of + Nothing -> empty + Just (Header _ header) -> ftext header + + pprCEntity (CLabel lbl) _ = + doubleQuotes $ text "static" <+> pp_hdr <+> char '&' <> ppr lbl + pprCEntity (CFunction (StaticTarget st _lbl _ isFun)) src = + if dqNeeded then doubleQuotes ce else empty + where + dqNeeded = (take 6 src == "static") + || isJust mHeader + || not isFun + || st /= NoSourceText + ce = + -- We may need to drop leading spaces first + (if take 6 src == "static" then text "static" else empty) + <+> pp_hdr + <+> (if isFun then empty else text "value") + <+> (pprWithSourceText st empty) + pprCEntity (CFunction DynamicTarget) _ = + doubleQuotes $ text "dynamic" + pprCEntity CWrapper _ = doubleQuotes $ text "wrapper" + +instance Outputable ForeignExport where + ppr (CExport (L _ (CExportStatic _ lbl cconv)) _) = + ppr cconv <+> char '"' <> ppr lbl <> char '"' + +{- +************************************************************************ +* * +\subsection{Transformation rules} +* * +************************************************************************ +-} + +-- | Located Rule Declarations +type LRuleDecls pass = Located (RuleDecls pass) + + -- Note [Pragma source text] in BasicTypes +-- | Rule Declarations +data RuleDecls pass = HsRules { rds_ext :: XCRuleDecls pass + , rds_src :: SourceText + , rds_rules :: [LRuleDecl pass] } + | XRuleDecls (XXRuleDecls pass) + +type instance XCRuleDecls (GhcPass _) = NoExt +type instance XXRuleDecls (GhcPass _) = NoExt + +-- | Located Rule Declaration +type LRuleDecl pass = Located (RuleDecl pass) + +-- | Rule Declaration +data RuleDecl pass + = HsRule -- Source rule + { rd_ext :: XHsRule pass + -- ^ After renamer, free-vars from the LHS and RHS + , rd_name :: Located (SourceText,RuleName) + -- ^ Note [Pragma source text] in BasicTypes + , rd_act :: Activation + , rd_tyvs :: Maybe [LHsTyVarBndr (NoGhcTc pass)] + -- ^ Forall'd type vars + , rd_tmvs :: [LRuleBndr pass] + -- ^ Forall'd term vars, before typechecking; after typechecking + -- this includes all forall'd vars + , rd_lhs :: Located (HsExpr pass) + , rd_rhs :: Located (HsExpr pass) + } + -- ^ + -- - 'ApiAnnotation.AnnKeywordId' : + -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnTilde', + -- 'ApiAnnotation.AnnVal', + -- 'ApiAnnotation.AnnClose', + -- 'ApiAnnotation.AnnForall','ApiAnnotation.AnnDot', + -- 'ApiAnnotation.AnnEqual', + | XRuleDecl (XXRuleDecl pass) + +data HsRuleRn = HsRuleRn NameSet NameSet -- Free-vars from the LHS and RHS + deriving Data + +type instance XHsRule GhcPs = NoExt +type instance XHsRule GhcRn = HsRuleRn +type instance XHsRule GhcTc = HsRuleRn + +type instance XXRuleDecl (GhcPass _) = NoExt + +flattenRuleDecls :: [LRuleDecls pass] -> [LRuleDecl pass] +flattenRuleDecls decls = concatMap (rds_rules . unLoc) decls + +-- | Located Rule Binder +type LRuleBndr pass = Located (RuleBndr pass) + +-- | Rule Binder +data RuleBndr pass + = RuleBndr (XCRuleBndr pass) (Located (IdP pass)) + | RuleBndrSig (XRuleBndrSig pass) (Located (IdP pass)) (LHsSigWcType pass) + | XRuleBndr (XXRuleBndr pass) + -- ^ + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + +type instance XCRuleBndr (GhcPass _) = NoExt +type instance XRuleBndrSig (GhcPass _) = NoExt +type instance XXRuleBndr (GhcPass _) = NoExt + +collectRuleBndrSigTys :: [RuleBndr pass] -> [LHsSigWcType pass] +collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ _ ty <- bndrs] + +pprFullRuleName :: Located (SourceText, RuleName) -> SDoc +pprFullRuleName (L _ (st, n)) = pprWithSourceText st (doubleQuotes $ ftext n) + +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (RuleDecls p) where + ppr (HsRules { rds_src = st + , rds_rules = rules }) + = pprWithSourceText st (text "{-# RULES") + <+> vcat (punctuate semi (map ppr rules)) <+> text "#-}" + ppr (XRuleDecls x) = ppr x + +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (RuleDecl p) where + ppr (HsRule { rd_name = name + , rd_act = act + , rd_tyvs = tys + , rd_tmvs = tms + , rd_lhs = lhs + , rd_rhs = rhs }) + = sep [pprFullRuleName name <+> ppr act, + nest 4 (pp_forall_ty tys <+> pp_forall_tm tys + <+> pprExpr (unLoc lhs)), + nest 6 (equals <+> pprExpr (unLoc rhs)) ] + where + pp_forall_ty Nothing = empty + pp_forall_ty (Just qtvs) = forAllLit <+> fsep (map ppr qtvs) <> dot + pp_forall_tm Nothing | null tms = empty + pp_forall_tm _ = forAllLit <+> fsep (map ppr tms) <> dot + ppr (XRuleDecl x) = ppr x + +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (RuleBndr p) where + ppr (RuleBndr _ name) = ppr name + ppr (RuleBndrSig _ name ty) = parens (ppr name <> dcolon <> ppr ty) + ppr (XRuleBndr x) = ppr x + +{- +************************************************************************ +* * +\subsection[DocDecl]{Document comments} +* * +************************************************************************ +-} + +-- | Located Documentation comment Declaration +type LDocDecl = Located (DocDecl) + +-- | Documentation comment Declaration +data DocDecl + = DocCommentNext HsDocString + | DocCommentPrev HsDocString + | DocCommentNamed String HsDocString + | DocGroup Int HsDocString + deriving Data + +-- Okay, I need to reconstruct the document comments, but for now: +instance Outputable DocDecl where + ppr _ = text "" + +docDeclDoc :: DocDecl -> HsDocString +docDeclDoc (DocCommentNext d) = d +docDeclDoc (DocCommentPrev d) = d +docDeclDoc (DocCommentNamed _ d) = d +docDeclDoc (DocGroup _ d) = d + +{- +************************************************************************ +* * +\subsection[DeprecDecl]{Deprecations} +* * +************************************************************************ + +We use exported entities for things to deprecate. +-} + +-- | Located Warning Declarations +type LWarnDecls pass = Located (WarnDecls pass) + + -- Note [Pragma source text] in BasicTypes +-- | Warning pragma Declarations +data WarnDecls pass = Warnings { wd_ext :: XWarnings pass + , wd_src :: SourceText + , wd_warnings :: [LWarnDecl pass] + } + | XWarnDecls (XXWarnDecls pass) + +type instance XWarnings (GhcPass _) = NoExt +type instance XXWarnDecls (GhcPass _) = NoExt + +-- | Located Warning pragma Declaration +type LWarnDecl pass = Located (WarnDecl pass) + +-- | Warning pragma Declaration +data WarnDecl pass = Warning (XWarning pass) [Located (IdP pass)] WarningTxt + | XWarnDecl (XXWarnDecl pass) + +type instance XWarning (GhcPass _) = NoExt +type instance XXWarnDecl (GhcPass _) = NoExt + + +instance (p ~ GhcPass pass,OutputableBndr (IdP p)) + => Outputable (WarnDecls p) where + ppr (Warnings _ (SourceText src) decls) + = text src <+> vcat (punctuate comma (map ppr decls)) <+> text "#-}" + ppr (Warnings _ NoSourceText _decls) = panic "WarnDecls" + ppr (XWarnDecls x) = ppr x + +instance (p ~ GhcPass pass, OutputableBndr (IdP p)) + => Outputable (WarnDecl p) where + ppr (Warning _ thing txt) + = hsep ( punctuate comma (map ppr thing)) + <+> ppr txt + ppr (XWarnDecl x) = ppr x + +{- +************************************************************************ +* * +\subsection[AnnDecl]{Annotations} +* * +************************************************************************ +-} + +-- | Located Annotation Declaration +type LAnnDecl pass = Located (AnnDecl pass) + +-- | Annotation Declaration +data AnnDecl pass = HsAnnotation + (XHsAnnotation pass) + SourceText -- Note [Pragma source text] in BasicTypes + (AnnProvenance (IdP pass)) (Located (HsExpr pass)) + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnType' + -- 'ApiAnnotation.AnnModule' + -- 'ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + | XAnnDecl (XXAnnDecl pass) + +type instance XHsAnnotation (GhcPass _) = NoExt +type instance XXAnnDecl (GhcPass _) = NoExt + +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (AnnDecl p) where + ppr (HsAnnotation _ _ provenance expr) + = hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"] + ppr (XAnnDecl x) = ppr x + +-- | Annotation Provenance +data AnnProvenance name = ValueAnnProvenance (Located name) + | TypeAnnProvenance (Located name) + | ModuleAnnProvenance +deriving instance Functor AnnProvenance +deriving instance Foldable AnnProvenance +deriving instance Traversable AnnProvenance +deriving instance (Data pass) => Data (AnnProvenance pass) + +annProvenanceName_maybe :: AnnProvenance name -> Maybe name +annProvenanceName_maybe (ValueAnnProvenance (L _ name)) = Just name +annProvenanceName_maybe (TypeAnnProvenance (L _ name)) = Just name +annProvenanceName_maybe ModuleAnnProvenance = Nothing + +pprAnnProvenance :: OutputableBndr name => AnnProvenance name -> SDoc +pprAnnProvenance ModuleAnnProvenance = text "ANN module" +pprAnnProvenance (ValueAnnProvenance (L _ name)) + = text "ANN" <+> ppr name +pprAnnProvenance (TypeAnnProvenance (L _ name)) + = text "ANN type" <+> ppr name + +{- +************************************************************************ +* * +\subsection[RoleAnnot]{Role annotations} +* * +************************************************************************ +-} + +-- | Located Role Annotation Declaration +type LRoleAnnotDecl pass = Located (RoleAnnotDecl pass) + +-- See #8185 for more info about why role annotations are +-- top-level declarations +-- | Role Annotation Declaration +data RoleAnnotDecl pass + = RoleAnnotDecl (XCRoleAnnotDecl pass) + (Located (IdP pass)) -- type constructor + [Located (Maybe Role)] -- optional annotations + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', + -- 'ApiAnnotation.AnnRole' + + -- For details on above see note [Api annotations] in ApiAnnotation + | XRoleAnnotDecl (XXRoleAnnotDecl pass) + +type instance XCRoleAnnotDecl (GhcPass _) = NoExt +type instance XXRoleAnnotDecl (GhcPass _) = NoExt + +instance (p ~ GhcPass pass, OutputableBndr (IdP p)) + => Outputable (RoleAnnotDecl p) where + ppr (RoleAnnotDecl _ ltycon roles) + = text "type role" <+> pprPrefixOcc (unLoc ltycon) <+> + hsep (map (pp_role . unLoc) roles) + where + pp_role Nothing = underscore + pp_role (Just r) = ppr r + ppr (XRoleAnnotDecl x) = ppr x + +roleAnnotDeclName :: RoleAnnotDecl pass -> (IdP pass) +roleAnnotDeclName (RoleAnnotDecl _ (L _ name) _) = name +roleAnnotDeclName (XRoleAnnotDecl _) = panic "roleAnnotDeclName" diff --git a/compiler/hsSyn/HsDoc.hs b/compiler/hsSyn/HsDoc.hs new file mode 100644 --- /dev/null +++ b/compiler/hsSyn/HsDoc.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module HsDoc + ( HsDocString + , LHsDocString + , mkHsDocString + , mkHsDocStringUtf8ByteString + , unpackHDS + , hsDocStringToByteString + , ppr_mbDoc + + , appendDocs + , concatDocs + + , DeclDocMap(..) + , emptyDeclDocMap + + , ArgDocMap(..) + , emptyArgDocMap + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import Binary +import Encoding +import FastFunctions +import Name +import Outputable +import SrcLoc + +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as C8 +import qualified Data.ByteString.Internal as BS +import Data.Data +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe +import Foreign + +-- | Haskell Documentation String +-- +-- Internally this is a UTF8-Encoded 'ByteString'. +newtype HsDocString = HsDocString ByteString + -- There are at least two plausible Semigroup instances for this type: + -- + -- 1. Simple string concatenation. + -- 2. Concatenation as documentation paragraphs with newlines in between. + -- + -- To avoid confusion, we pass on defining an instance at all. + deriving (Eq, Show, Data) + +-- | Located Haskell Documentation String +type LHsDocString = Located HsDocString + +instance Binary HsDocString where + put_ bh (HsDocString bs) = put_ bh bs + get bh = HsDocString <$> get bh + +instance Outputable HsDocString where + ppr = doubleQuotes . text . unpackHDS + +mkHsDocString :: String -> HsDocString +mkHsDocString s = + inlinePerformIO $ do + let len = utf8EncodedLength s + buf <- mallocForeignPtrBytes len + withForeignPtr buf $ \ptr -> do + utf8EncodeString ptr s + pure (HsDocString (BS.fromForeignPtr buf 0 len)) + +-- | Create a 'HsDocString' from a UTF8-encoded 'ByteString'. +mkHsDocStringUtf8ByteString :: ByteString -> HsDocString +mkHsDocStringUtf8ByteString = HsDocString + +unpackHDS :: HsDocString -> String +unpackHDS = utf8DecodeByteString . hsDocStringToByteString + +-- | Return the contents of a 'HsDocString' as a UTF8-encoded 'ByteString'. +hsDocStringToByteString :: HsDocString -> ByteString +hsDocStringToByteString (HsDocString bs) = bs + +ppr_mbDoc :: Maybe LHsDocString -> SDoc +ppr_mbDoc (Just doc) = ppr doc +ppr_mbDoc Nothing = empty + +-- | Join two docstrings. +-- +-- Non-empty docstrings are joined with two newlines in between, +-- resulting in separate paragraphs. +appendDocs :: HsDocString -> HsDocString -> HsDocString +appendDocs x y = + fromMaybe + (HsDocString BS.empty) + (concatDocs [x, y]) + +-- | Concat docstrings with two newlines in between. +-- +-- Empty docstrings are skipped. +-- +-- If all inputs are empty, 'Nothing' is returned. +concatDocs :: [HsDocString] -> Maybe HsDocString +concatDocs xs = + if BS.null b + then Nothing + else Just (HsDocString b) + where + b = BS.intercalate (C8.pack "\n\n") + . filter (not . BS.null) + . map hsDocStringToByteString + $ xs + +-- | Docs for declarations: functions, data types, instances, methods etc. +newtype DeclDocMap = DeclDocMap (Map Name HsDocString) + +instance Binary DeclDocMap where + put_ bh (DeclDocMap m) = put_ bh (Map.toList m) + -- We can't rely on a deterministic ordering of the `Name`s here. + -- See the comments on `Name`'s `Ord` instance for context. + get bh = DeclDocMap . Map.fromList <$> get bh + +instance Outputable DeclDocMap where + ppr (DeclDocMap m) = vcat (map pprPair (Map.toAscList m)) + where + pprPair (name, doc) = ppr name Outputable.<> colon $$ nest 2 (ppr doc) + +emptyDeclDocMap :: DeclDocMap +emptyDeclDocMap = DeclDocMap Map.empty + +-- | Docs for arguments. E.g. function arguments, method arguments. +newtype ArgDocMap = ArgDocMap (Map Name (Map Int HsDocString)) + +instance Binary ArgDocMap where + put_ bh (ArgDocMap m) = put_ bh (Map.toList (Map.toAscList <$> m)) + -- We can't rely on a deterministic ordering of the `Name`s here. + -- See the comments on `Name`'s `Ord` instance for context. + get bh = ArgDocMap . fmap Map.fromDistinctAscList . Map.fromList <$> get bh + +instance Outputable ArgDocMap where + ppr (ArgDocMap m) = vcat (map pprPair (Map.toAscList m)) + where + pprPair (name, int_map) = + ppr name Outputable.<> colon $$ nest 2 (pprIntMap int_map) + pprIntMap im = vcat (map pprIPair (Map.toAscList im)) + pprIPair (i, doc) = ppr i Outputable.<> colon $$ nest 2 (ppr doc) + +emptyArgDocMap :: ArgDocMap +emptyArgDocMap = ArgDocMap Map.empty diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs new file mode 100644 --- /dev/null +++ b/compiler/hsSyn/HsExpr.hs @@ -0,0 +1,2873 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] + -- in module PlaceHolder +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Abstract Haskell syntax for expressions. +module HsExpr where + +#include "HsVersions.h" + +-- friends: +import GhcPrelude + +import HsDecls +import HsPat +import HsLit +import PlaceHolder ( NameOrRdrName ) +import HsExtension +import HsTypes +import HsBinds + +-- others: +import TcEvidence +import CoreSyn +import DynFlags ( gopt, GeneralFlag(Opt_PrintExplicitCoercions) ) +import Name +import NameSet +import RdrName ( GlobalRdrEnv ) +import BasicTypes +import ConLike +import SrcLoc +import Util +import Outputable +import FastString +import Type +import TcType (TcType) +import {-# SOURCE #-} TcRnTypes (TcLclEnv) + +-- libraries: +import Data.Data hiding (Fixity(..)) +import qualified Data.Data as Data (Fixity(..)) +import Data.Maybe (isNothing) + +import GHCi.RemoteTypes ( ForeignRef ) +import qualified Language.Haskell.TH as TH (Q) + +{- +************************************************************************ +* * +\subsection{Expressions proper} +* * +************************************************************************ +-} + +-- * Expressions proper + +-- | Located Haskell Expression +type LHsExpr p = Located (HsExpr p) + -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' when + -- in a list + + -- For details on above see note [Api annotations] in ApiAnnotation + +------------------------- +-- | Post-Type checking Expression +-- +-- PostTcExpr is an evidence expression attached to the syntax tree by the +-- type checker (c.f. postTcType). +type PostTcExpr = HsExpr GhcTc + +-- | Post-Type checking Table +-- +-- We use a PostTcTable where there are a bunch of pieces of evidence, more +-- than is convenient to keep individually. +type PostTcTable = [(Name, PostTcExpr)] + +------------------------- +-- | Syntax Expression +-- +-- SyntaxExpr is like 'PostTcExpr', but it's filled in a little earlier, +-- by the renamer. It's used for rebindable syntax. +-- +-- E.g. @(>>=)@ is filled in before the renamer by the appropriate 'Name' for +-- @(>>=)@, and then instantiated by the type checker with its type args +-- etc +-- +-- This should desugar to +-- +-- > syn_res_wrap $ syn_expr (syn_arg_wraps[0] arg0) +-- > (syn_arg_wraps[1] arg1) ... +-- +-- where the actual arguments come from elsewhere in the AST. +-- This could be defined using @GhcPass p@ and such, but it's +-- harder to get it all to work out that way. ('noSyntaxExpr' is hard to +-- write, for example.) +data SyntaxExpr p = SyntaxExpr { syn_expr :: HsExpr p + , syn_arg_wraps :: [HsWrapper] + , syn_res_wrap :: HsWrapper } + +-- | This is used for rebindable-syntax pieces that are too polymorphic +-- for tcSyntaxOp (trS_fmap and the mzip in ParStmt) +noExpr :: HsExpr (GhcPass p) +noExpr = HsLit noExt (HsString (SourceText "noExpr") (fsLit "noExpr")) + +noSyntaxExpr :: SyntaxExpr (GhcPass p) + -- Before renaming, and sometimes after, + -- (if the syntax slot makes no sense) +noSyntaxExpr = SyntaxExpr { syn_expr = HsLit noExt (HsString NoSourceText + (fsLit "noSyntaxExpr")) + , syn_arg_wraps = [] + , syn_res_wrap = WpHole } + +-- | Make a 'SyntaxExpr (HsExpr _)', missing its HsWrappers. +mkSyntaxExpr :: HsExpr (GhcPass p) -> SyntaxExpr (GhcPass p) +mkSyntaxExpr expr = SyntaxExpr { syn_expr = expr + , syn_arg_wraps = [] + , syn_res_wrap = WpHole } + +-- | Make a 'SyntaxExpr Name' (the "rn" is because this is used in the +-- renamer), missing its HsWrappers. +mkRnSyntaxExpr :: Name -> SyntaxExpr GhcRn +mkRnSyntaxExpr name = mkSyntaxExpr $ HsVar noExt $ noLoc name + -- don't care about filling in syn_arg_wraps because we're clearly + -- not past the typechecker + +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (SyntaxExpr p) where + ppr (SyntaxExpr { syn_expr = expr + , syn_arg_wraps = arg_wraps + , syn_res_wrap = res_wrap }) + = sdocWithDynFlags $ \ dflags -> + getPprStyle $ \s -> + if debugStyle s || gopt Opt_PrintExplicitCoercions dflags + then ppr expr <> braces (pprWithCommas ppr arg_wraps) + <> braces (ppr res_wrap) + else ppr expr + +-- | Command Syntax Table (for Arrow syntax) +type CmdSyntaxTable p = [(Name, HsExpr p)] +-- See Note [CmdSyntaxTable] + +{- +Note [CmdSyntaxtable] +~~~~~~~~~~~~~~~~~~~~~ +Used only for arrow-syntax stuff (HsCmdTop), the CmdSyntaxTable keeps +track of the methods needed for a Cmd. + +* Before the renamer, this list is an empty list + +* After the renamer, it takes the form @[(std_name, HsVar actual_name)]@ + For example, for the 'arr' method + * normal case: (GHC.Control.Arrow.arr, HsVar GHC.Control.Arrow.arr) + * with rebindable syntax: (GHC.Control.Arrow.arr, arr_22) + where @arr_22@ is whatever 'arr' is in scope + +* After the type checker, it takes the form [(std_name, )] + where is the evidence for the method. This evidence is + instantiated with the class, but is still polymorphic in everything + else. For example, in the case of 'arr', the evidence has type + forall b c. (b->c) -> a b c + where 'a' is the ambient type of the arrow. This polymorphism is + important because the desugarer uses the same evidence at multiple + different types. + +This is Less Cool than what we normally do for rebindable syntax, which is to +make fully-instantiated piece of evidence at every use site. The Cmd way +is Less Cool because + * The renamer has to predict which methods are needed. + See the tedious RnExpr.methodNamesCmd. + + * The desugarer has to know the polymorphic type of the instantiated + method. This is checked by Inst.tcSyntaxName, but is less flexible + than the rest of rebindable syntax, where the type is less + pre-ordained. (And this flexibility is useful; for example we can + typecheck do-notation with (>>=) :: m1 a -> (a -> m2 b) -> m2 b.) +-} + +-- | An unbound variable; used for treating +-- out-of-scope variables as expression holes +-- +-- Either "x", "y" Plain OutOfScope +-- or "_", "_x" A TrueExprHole +-- +-- Both forms indicate an out-of-scope variable, but the latter +-- indicates that the user /expects/ it to be out of scope, and +-- just wants GHC to report its type +data UnboundVar + = OutOfScope OccName GlobalRdrEnv -- ^ An (unqualified) out-of-scope + -- variable, together with the GlobalRdrEnv + -- with respect to which it is unbound + + -- See Note [OutOfScope and GlobalRdrEnv] + + | TrueExprHole OccName -- ^ A "true" expression hole (_ or _x) + + deriving Data + +instance Outputable UnboundVar where + ppr (OutOfScope occ _) = text "OutOfScope" <> parens (ppr occ) + ppr (TrueExprHole occ) = text "ExprHole" <> parens (ppr occ) + +unboundVarOcc :: UnboundVar -> OccName +unboundVarOcc (OutOfScope occ _) = occ +unboundVarOcc (TrueExprHole occ) = occ + +{- +Note [OutOfScope and GlobalRdrEnv] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To understand why we bundle a GlobalRdrEnv with an out-of-scope variable, +consider the following module: + + module A where + + foo :: () + foo = bar + + bat :: [Double] + bat = [1.2, 3.4] + + $(return []) + + bar = () + bad = False + +When A is compiled, the renamer determines that `bar` is not in scope in the +declaration of `foo` (since `bar` is declared in the following inter-splice +group). Once it has finished typechecking the entire module, the typechecker +then generates the associated error message, which specifies both the type of +`bar` and a list of possible in-scope alternatives: + + A.hs:6:7: error: + • Variable not in scope: bar :: () + • ‘bar’ (line 13) is not in scope before the splice on line 11 + Perhaps you meant ‘bat’ (line 9) + +When it calls RnEnv.unknownNameSuggestions to identify these alternatives, the +typechecker must provide a GlobalRdrEnv. If it provided the current one, which +contains top-level declarations for the entire module, the error message would +incorrectly suggest the out-of-scope `bar` and `bad` as possible alternatives +for `bar` (see #11680). Instead, the typechecker must use the same +GlobalRdrEnv the renamer used when it determined that `bar` is out-of-scope. + +To obtain this GlobalRdrEnv, can the typechecker simply use the out-of-scope +`bar`'s location to either reconstruct it (from the current GlobalRdrEnv) or to +look it up in some global store? Unfortunately, no. The problem is that +location information is not always sufficient for this task. This is most +apparent when dealing with the TH function addTopDecls, which adds its +declarations to the FOLLOWING inter-splice group. Consider these declarations: + + ex9 = cat -- cat is NOT in scope here + + $(do ------------------------------------------------------------- + ds <- [d| f = cab -- cat and cap are both in scope here + cat = () + |] + addTopDecls ds + [d| g = cab -- only cap is in scope here + cap = True + |]) + + ex10 = cat -- cat is NOT in scope here + + $(return []) ----------------------------------------------------- + + ex11 = cat -- cat is in scope + +Here, both occurrences of `cab` are out-of-scope, and so the typechecker needs +the GlobalRdrEnvs which were used when they were renamed. These GlobalRdrEnvs +are different (`cat` is present only in the GlobalRdrEnv for f's `cab'), but the +locations of the two `cab`s are the same (they are both created in the same +splice). Thus, we must include some additional information with each `cab` to +allow the typechecker to obtain the correct GlobalRdrEnv. Clearly, the simplest +information to use is the GlobalRdrEnv itself. +-} + +-- | A Haskell expression. +data HsExpr p + = HsVar (XVar p) + (Located (IdP p)) -- ^ Variable + + -- See Note [Located RdrNames] + + | HsUnboundVar (XUnboundVar p) + UnboundVar -- ^ Unbound variable; also used for "holes" + -- (_ or _x). + -- Turned from HsVar to HsUnboundVar by the + -- renamer, when it finds an out-of-scope + -- variable or hole. + -- Turned into HsVar by type checker, to support + -- deferred type errors. + + | HsConLikeOut (XConLikeOut p) + ConLike -- ^ After typechecker only; must be different + -- HsVar for pretty printing + + | HsRecFld (XRecFld p) + (AmbiguousFieldOcc p) -- ^ Variable pointing to record selector + -- Not in use after typechecking + + | HsOverLabel (XOverLabel p) + (Maybe (IdP p)) FastString + -- ^ Overloaded label (Note [Overloaded labels] in GHC.OverloadedLabels) + -- @Just id@ means @RebindableSyntax@ is in use, and gives the id of the + -- in-scope 'fromLabel'. + -- NB: Not in use after typechecking + + | HsIPVar (XIPVar p) + HsIPName -- ^ Implicit parameter (not in use after typechecking) + | HsOverLit (XOverLitE p) + (HsOverLit p) -- ^ Overloaded literals + + | HsLit (XLitE p) + (HsLit p) -- ^ Simple (non-overloaded) literals + + | HsLam (XLam p) + (MatchGroup p (LHsExpr p)) + -- ^ Lambda abstraction. Currently always a single match + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam', + -- 'ApiAnnotation.AnnRarrow', + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsLamCase (XLamCase p) (MatchGroup p (LHsExpr p)) -- ^ Lambda-case + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam', + -- 'ApiAnnotation.AnnCase','ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsApp (XApp p) (LHsExpr p) (LHsExpr p) -- ^ Application + + | HsAppType (XAppTypeE p) (LHsExpr p) (LHsWcType (NoGhcTc p)) -- ^ Visible type application + -- + -- Explicit type argument; e.g f @Int x y + -- NB: Has wildcards, but no implicit quantification + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt', + + -- | Operator applications: + -- NB Bracketed ops such as (+) come out as Vars. + + -- NB We need an expr for the operator in an OpApp/Section since + -- the typechecker may need to apply the operator to a few types. + + | OpApp (XOpApp p) + (LHsExpr p) -- left operand + (LHsExpr p) -- operator + (LHsExpr p) -- right operand + + -- | Negation operator. Contains the negated expression and the name + -- of 'negate' + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnMinus' + + -- For details on above see note [Api annotations] in ApiAnnotation + | NegApp (XNegApp p) + (LHsExpr p) + (SyntaxExpr p) + + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, + -- 'ApiAnnotation.AnnClose' @')'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + | HsPar (XPar p) + (LHsExpr p) -- ^ Parenthesised expr; see Note [Parens in HsSyn] + + | SectionL (XSectionL p) + (LHsExpr p) -- operand; see Note [Sections in HsSyn] + (LHsExpr p) -- operator + | SectionR (XSectionR p) + (LHsExpr p) -- operator; see Note [Sections in HsSyn] + (LHsExpr p) -- operand + + -- | Used for explicit tuples and sections thereof + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + | ExplicitTuple + (XExplicitTuple p) + [LHsTupArg p] + Boxity + + -- | Used for unboxed sum types + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(#'@, + -- 'ApiAnnotation.AnnVbar', 'ApiAnnotation.AnnClose' @'#)'@, + -- + -- There will be multiple 'ApiAnnotation.AnnVbar', (1 - alternative) before + -- the expression, (arity - alternative) after it + | ExplicitSum + (XExplicitSum p) + ConTag -- Alternative (one-based) + Arity -- Sum arity + (LHsExpr p) + + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnCase', + -- 'ApiAnnotation.AnnOf','ApiAnnotation.AnnOpen' @'{'@, + -- 'ApiAnnotation.AnnClose' @'}'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + | HsCase (XCase p) + (LHsExpr p) + (MatchGroup p (LHsExpr p)) + + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnIf', + -- 'ApiAnnotation.AnnSemi', + -- 'ApiAnnotation.AnnThen','ApiAnnotation.AnnSemi', + -- 'ApiAnnotation.AnnElse', + + -- For details on above see note [Api annotations] in ApiAnnotation + | HsIf (XIf p) + (Maybe (SyntaxExpr p)) -- cond function + -- Nothing => use the built-in 'if' + -- See Note [Rebindable if] + (LHsExpr p) -- predicate + (LHsExpr p) -- then part + (LHsExpr p) -- else part + + -- | Multi-way if + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnIf' + -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose', + + -- For details on above see note [Api annotations] in ApiAnnotation + | HsMultiIf (XMultiIf p) [LGRHS p (LHsExpr p)] + + -- | let(rec) + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet', + -- 'ApiAnnotation.AnnOpen' @'{'@, + -- 'ApiAnnotation.AnnClose' @'}'@,'ApiAnnotation.AnnIn' + + -- For details on above see note [Api annotations] in ApiAnnotation + | HsLet (XLet p) + (LHsLocalBinds p) + (LHsExpr p) + + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDo', + -- 'ApiAnnotation.AnnOpen', 'ApiAnnotation.AnnSemi', + -- 'ApiAnnotation.AnnVbar', + -- 'ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + | HsDo (XDo p) -- Type of the whole expression + (HsStmtContext Name) -- The parameterisation is unimportant + -- because in this context we never use + -- the PatGuard or ParStmt variant + (Located [ExprLStmt p]) -- "do":one or more stmts + + -- | Syntactic list: [a,b,c,...] + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@, + -- 'ApiAnnotation.AnnClose' @']'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + | ExplicitList + (XExplicitList p) -- Gives type of components of list + (Maybe (SyntaxExpr p)) + -- For OverloadedLists, the fromListN witness + [LHsExpr p] + + -- | Record construction + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{'@, + -- 'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnClose' @'}'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + | RecordCon + { rcon_ext :: XRecordCon p + , rcon_con_name :: Located (IdP p) -- The constructor name; + -- not used after type checking + , rcon_flds :: HsRecordBinds p } -- The fields + + -- | Record update + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{'@, + -- 'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnClose' @'}'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + | RecordUpd + { rupd_ext :: XRecordUpd p + , rupd_expr :: LHsExpr p + , rupd_flds :: [LHsRecUpdField p] + } + -- For a type family, the arg types are of the *instance* tycon, + -- not the family tycon + + -- | Expression with an explicit type signature. @e :: type@ + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon' + + -- For details on above see note [Api annotations] in ApiAnnotation + | ExprWithTySig + (XExprWithTySig p) + + (LHsExpr p) + (LHsSigWcType (NoGhcTc p)) + + -- | Arithmetic sequence + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@, + -- 'ApiAnnotation.AnnComma','ApiAnnotation.AnnDotdot', + -- 'ApiAnnotation.AnnClose' @']'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + | ArithSeq + (XArithSeq p) + (Maybe (SyntaxExpr p)) + -- For OverloadedLists, the fromList witness + (ArithSeqInfo p) + + -- For details on above see note [Api annotations] in ApiAnnotation + | HsSCC (XSCC p) + SourceText -- Note [Pragma source text] in BasicTypes + StringLiteral -- "set cost centre" SCC pragma + (LHsExpr p) -- expr whose cost is to be measured + + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# CORE'@, + -- 'ApiAnnotation.AnnVal', 'ApiAnnotation.AnnClose' @'\#-}'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + | HsCoreAnn (XCoreAnn p) + SourceText -- Note [Pragma source text] in BasicTypes + StringLiteral -- hdaume: core annotation + (LHsExpr p) + + ----------------------------------------------------------- + -- MetaHaskell Extensions + + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnOpenE','ApiAnnotation.AnnOpenEQ', + -- 'ApiAnnotation.AnnClose','ApiAnnotation.AnnCloseQ' + + -- For details on above see note [Api annotations] in ApiAnnotation + | HsBracket (XBracket p) (HsBracket p) + + -- See Note [Pending Splices] + | HsRnBracketOut + (XRnBracketOut p) + (HsBracket GhcRn) -- Output of the renamer is the *original* renamed + -- expression, plus + [PendingRnSplice] -- _renamed_ splices to be type checked + + | HsTcBracketOut + (XTcBracketOut p) + (HsBracket GhcRn) -- Output of the type checker is the *original* + -- renamed expression, plus + [PendingTcSplice] -- _typechecked_ splices to be + -- pasted back in by the desugarer + + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + | HsSpliceE (XSpliceE p) (HsSplice p) + + ----------------------------------------------------------- + -- Arrow notation extension + + -- | @proc@ notation for Arrows + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnProc', + -- 'ApiAnnotation.AnnRarrow' + + -- For details on above see note [Api annotations] in ApiAnnotation + | HsProc (XProc p) + (LPat p) -- arrow abstraction, proc + (LHsCmdTop p) -- body of the abstraction + -- always has an empty stack + + --------------------------------------- + -- static pointers extension + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnStatic', + + -- For details on above see note [Api annotations] in ApiAnnotation + | HsStatic (XStatic p) -- Free variables of the body + (LHsExpr p) -- Body + + --------------------------------------- + -- Haskell program coverage (Hpc) Support + + | HsTick + (XTick p) + (Tickish (IdP p)) + (LHsExpr p) -- sub-expression + + | HsBinTick + (XBinTick p) + Int -- module-local tick number for True + Int -- module-local tick number for False + (LHsExpr p) -- sub-expression + + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnOpen' @'{-\# GENERATED'@, + -- 'ApiAnnotation.AnnVal','ApiAnnotation.AnnVal', + -- 'ApiAnnotation.AnnColon','ApiAnnotation.AnnVal', + -- 'ApiAnnotation.AnnMinus', + -- 'ApiAnnotation.AnnVal','ApiAnnotation.AnnColon', + -- 'ApiAnnotation.AnnVal', + -- 'ApiAnnotation.AnnClose' @'\#-}'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + | HsTickPragma -- A pragma introduced tick + (XTickPragma p) + SourceText -- Note [Pragma source text] in BasicTypes + (StringLiteral,(Int,Int),(Int,Int)) + -- external span for this tick + ((SourceText,SourceText),(SourceText,SourceText)) + -- Source text for the four integers used in the span. + -- See note [Pragma source text] in BasicTypes + (LHsExpr p) + + --------------------------------------- + -- These constructors only appear temporarily in the parser. + -- The renamer translates them into the Right Thing. + + | EWildPat (XEWildPat p) -- wildcard + + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt' + + -- For details on above see note [Api annotations] in ApiAnnotation + | EAsPat (XEAsPat p) + (Located (IdP p)) -- as pattern + (LHsExpr p) + + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow' + + -- For details on above see note [Api annotations] in ApiAnnotation + | EViewPat (XEViewPat p) + (LHsExpr p) -- view pattern + (LHsExpr p) + + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde' + + -- For details on above see note [Api annotations] in ApiAnnotation + | ELazyPat (XELazyPat p) (LHsExpr p) -- ~ pattern + + + --------------------------------------- + -- Finally, HsWrap appears only in typechecker output + -- The contained Expr is *NOT* itself an HsWrap. + -- See Note [Detecting forced eta expansion] in DsExpr. This invariant + -- is maintained by HsUtils.mkHsWrap. + + | HsWrap (XWrap p) + HsWrapper -- TRANSLATION + (HsExpr p) + + | XExpr (XXExpr p) -- Note [Trees that Grow] extension constructor + + +-- | Extra data fields for a 'RecordCon', added by the type checker +data RecordConTc = RecordConTc + { rcon_con_like :: ConLike -- The data constructor or pattern synonym + , rcon_con_expr :: PostTcExpr -- Instantiated constructor function + } + +-- | Extra data fields for a 'RecordUpd', added by the type checker +data RecordUpdTc = RecordUpdTc + { rupd_cons :: [ConLike] + -- Filled in by the type checker to the + -- _non-empty_ list of DataCons that have + -- all the upd'd fields + + , rupd_in_tys :: [Type] -- Argument types of *input* record type + , rupd_out_tys :: [Type] -- and *output* record type + -- The original type can be reconstructed + -- with conLikeResTy + , rupd_wrap :: HsWrapper -- See note [Record Update HsWrapper] + } deriving Data + +-- --------------------------------------------------------------------- + +type instance XVar (GhcPass _) = NoExt +type instance XUnboundVar (GhcPass _) = NoExt +type instance XConLikeOut (GhcPass _) = NoExt +type instance XRecFld (GhcPass _) = NoExt +type instance XOverLabel (GhcPass _) = NoExt +type instance XIPVar (GhcPass _) = NoExt +type instance XOverLitE (GhcPass _) = NoExt +type instance XLitE (GhcPass _) = NoExt +type instance XLam (GhcPass _) = NoExt +type instance XLamCase (GhcPass _) = NoExt +type instance XApp (GhcPass _) = NoExt + +type instance XAppTypeE (GhcPass _) = NoExt + +type instance XOpApp GhcPs = NoExt +type instance XOpApp GhcRn = Fixity +type instance XOpApp GhcTc = Fixity + +type instance XNegApp (GhcPass _) = NoExt +type instance XPar (GhcPass _) = NoExt +type instance XSectionL (GhcPass _) = NoExt +type instance XSectionR (GhcPass _) = NoExt +type instance XExplicitTuple (GhcPass _) = NoExt + +type instance XExplicitSum GhcPs = NoExt +type instance XExplicitSum GhcRn = NoExt +type instance XExplicitSum GhcTc = [Type] + +type instance XCase (GhcPass _) = NoExt +type instance XIf (GhcPass _) = NoExt + +type instance XMultiIf GhcPs = NoExt +type instance XMultiIf GhcRn = NoExt +type instance XMultiIf GhcTc = Type + +type instance XLet (GhcPass _) = NoExt + +type instance XDo GhcPs = NoExt +type instance XDo GhcRn = NoExt +type instance XDo GhcTc = Type + +type instance XExplicitList GhcPs = NoExt +type instance XExplicitList GhcRn = NoExt +type instance XExplicitList GhcTc = Type + +type instance XRecordCon GhcPs = NoExt +type instance XRecordCon GhcRn = NoExt +type instance XRecordCon GhcTc = RecordConTc + +type instance XRecordUpd GhcPs = NoExt +type instance XRecordUpd GhcRn = NoExt +type instance XRecordUpd GhcTc = RecordUpdTc + +type instance XExprWithTySig (GhcPass _) = NoExt + +type instance XArithSeq GhcPs = NoExt +type instance XArithSeq GhcRn = NoExt +type instance XArithSeq GhcTc = PostTcExpr + +type instance XSCC (GhcPass _) = NoExt +type instance XCoreAnn (GhcPass _) = NoExt +type instance XBracket (GhcPass _) = NoExt + +type instance XRnBracketOut (GhcPass _) = NoExt +type instance XTcBracketOut (GhcPass _) = NoExt + +type instance XSpliceE (GhcPass _) = NoExt +type instance XProc (GhcPass _) = NoExt + +type instance XStatic GhcPs = NoExt +type instance XStatic GhcRn = NameSet +type instance XStatic GhcTc = NameSet + +type instance XTick (GhcPass _) = NoExt +type instance XBinTick (GhcPass _) = NoExt +type instance XTickPragma (GhcPass _) = NoExt +type instance XEWildPat (GhcPass _) = NoExt +type instance XEAsPat (GhcPass _) = NoExt +type instance XEViewPat (GhcPass _) = NoExt +type instance XELazyPat (GhcPass _) = NoExt +type instance XWrap (GhcPass _) = NoExt +type instance XXExpr (GhcPass _) = NoExt + +-- --------------------------------------------------------------------- + +-- | Located Haskell Tuple Argument +-- +-- 'HsTupArg' is used for tuple sections +-- @(,a,)@ is represented by +-- @ExplicitTuple [Missing ty1, Present a, Missing ty3]@ +-- Which in turn stands for @(\x:ty1 \y:ty2. (x,a,y))@ +type LHsTupArg id = Located (HsTupArg id) +-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' + +-- For details on above see note [Api annotations] in ApiAnnotation + +-- | Haskell Tuple Argument +data HsTupArg id + = Present (XPresent id) (LHsExpr id) -- ^ The argument + | Missing (XMissing id) -- ^ The argument is missing, but this is its type + | XTupArg (XXTupArg id) -- ^ Note [Trees that Grow] extension point + +type instance XPresent (GhcPass _) = NoExt + +type instance XMissing GhcPs = NoExt +type instance XMissing GhcRn = NoExt +type instance XMissing GhcTc = Type + +type instance XXTupArg (GhcPass _) = NoExt + +tupArgPresent :: LHsTupArg id -> Bool +tupArgPresent (L _ (Present {})) = True +tupArgPresent (L _ (Missing {})) = False +tupArgPresent (L _ (XTupArg {})) = False + +{- +Note [Parens in HsSyn] +~~~~~~~~~~~~~~~~~~~~~~ +HsPar (and ParPat in patterns, HsParTy in types) is used as follows + + * HsPar is required; the pretty printer does not add parens. + + * HsPars are respected when rearranging operator fixities. + So a * (b + c) means what it says (where the parens are an HsPar) + + * For ParPat and HsParTy the pretty printer does add parens but this should be + a no-op for ParsedSource, based on the pretty printer round trip feature + introduced in + https://phabricator.haskell.org/rGHC499e43824bda967546ebf95ee33ec1f84a114a7c + + * ParPat and HsParTy are pretty printed as '( .. )' regardless of whether or + not they are strictly necessary. This should be addressed when #13238 is + completed, to be treated the same as HsPar. + + +Note [Sections in HsSyn] +~~~~~~~~~~~~~~~~~~~~~~~~ +Sections should always appear wrapped in an HsPar, thus + HsPar (SectionR ...) +The parser parses sections in a wider variety of situations +(See Note [Parsing sections]), but the renamer checks for those +parens. This invariant makes pretty-printing easier; we don't need +a special case for adding the parens round sections. + +Note [Rebindable if] +~~~~~~~~~~~~~~~~~~~~ +The rebindable syntax for 'if' is a bit special, because when +rebindable syntax is *off* we do not want to treat + (if c then t else e) +as if it was an application (ifThenElse c t e). Why not? +Because we allow an 'if' to return *unboxed* results, thus + if blah then 3# else 4# +whereas that would not be possible using a all to a polymorphic function +(because you can't call a polymorphic function at an unboxed type). + +So we use Nothing to mean "use the old built-in typing rule". + +Note [Record Update HsWrapper] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There is a wrapper in RecordUpd which is used for the *required* +constraints for pattern synonyms. This wrapper is created in the +typechecking and is then directly used in the desugaring without +modification. + +For example, if we have the record pattern synonym P, + pattern P :: (Show a) => a -> Maybe a + pattern P{x} = Just x + + foo = (Just True) { x = False } +then `foo` desugars to something like + foo = case Just True of + P x -> P False +hence we need to provide the correct dictionaries to P's matcher on +the RHS so that we can build the expression. + +Note [Located RdrNames] +~~~~~~~~~~~~~~~~~~~~~~~ +A number of syntax elements have seemingly redundant locations attached to them. +This is deliberate, to allow transformations making use of the API Annotations +to easily correlate a Located Name in the RenamedSource with a Located RdrName +in the ParsedSource. + +There are unfortunately enough differences between the ParsedSource and the +RenamedSource that the API Annotations cannot be used directly with +RenamedSource, so this allows a simple mapping to be used based on the location. +-} + +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsExpr p) where + ppr expr = pprExpr expr + +----------------------- +-- pprExpr, pprLExpr, pprBinds call pprDeeper; +-- the underscore versions do not +pprLExpr :: (OutputableBndrId (GhcPass p)) => LHsExpr (GhcPass p) -> SDoc +pprLExpr (L _ e) = pprExpr e + +pprExpr :: (OutputableBndrId (GhcPass p)) => HsExpr (GhcPass p) -> SDoc +pprExpr e | isAtomicHsExpr e || isQuietHsExpr e = ppr_expr e + | otherwise = pprDeeper (ppr_expr e) + +isQuietHsExpr :: HsExpr id -> Bool +-- Parentheses do display something, but it gives little info and +-- if we go deeper when we go inside them then we get ugly things +-- like (...) +isQuietHsExpr (HsPar {}) = True +-- applications don't display anything themselves +isQuietHsExpr (HsApp {}) = True +isQuietHsExpr (HsAppType {}) = True +isQuietHsExpr (OpApp {}) = True +isQuietHsExpr _ = False + +pprBinds :: (OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR)) + => HsLocalBindsLR (GhcPass idL) (GhcPass idR) -> SDoc +pprBinds b = pprDeeper (ppr b) + +----------------------- +ppr_lexpr :: (OutputableBndrId (GhcPass p)) => LHsExpr (GhcPass p) -> SDoc +ppr_lexpr e = ppr_expr (unLoc e) + +ppr_expr :: forall p. (OutputableBndrId (GhcPass p)) + => HsExpr (GhcPass p) -> SDoc +ppr_expr (HsVar _ (L _ v)) = pprPrefixOcc v +ppr_expr (HsUnboundVar _ uv)= pprPrefixOcc (unboundVarOcc uv) +ppr_expr (HsConLikeOut _ c) = pprPrefixOcc c +ppr_expr (HsIPVar _ v) = ppr v +ppr_expr (HsOverLabel _ _ l)= char '#' <> ppr l +ppr_expr (HsLit _ lit) = ppr lit +ppr_expr (HsOverLit _ lit) = ppr lit +ppr_expr (HsPar _ e) = parens (ppr_lexpr e) + +ppr_expr (HsCoreAnn _ stc (StringLiteral sta s) e) + = vcat [pprWithSourceText stc (text "{-# CORE") + <+> pprWithSourceText sta (doubleQuotes $ ftext s) <+> text "#-}" + , ppr_lexpr e] + +ppr_expr e@(HsApp {}) = ppr_apps e [] +ppr_expr e@(HsAppType {}) = ppr_apps e [] + +ppr_expr (OpApp _ e1 op e2) + | Just pp_op <- should_print_infix (unLoc op) + = pp_infixly pp_op + | otherwise + = pp_prefixly + + where + should_print_infix (HsVar _ (L _ v)) = Just (pprInfixOcc v) + should_print_infix (HsConLikeOut _ c)= Just (pprInfixOcc (conLikeName c)) + should_print_infix (HsRecFld _ f) = Just (pprInfixOcc f) + should_print_infix (HsUnboundVar _ h@TrueExprHole{}) + = Just (pprInfixOcc (unboundVarOcc h)) + should_print_infix (EWildPat _) = Just (text "`_`") + should_print_infix (HsWrap _ _ e) = should_print_infix e + should_print_infix _ = Nothing + + pp_e1 = pprDebugParendExpr opPrec e1 -- In debug mode, add parens + pp_e2 = pprDebugParendExpr opPrec e2 -- to make precedence clear + + pp_prefixly + = hang (ppr op) 2 (sep [pp_e1, pp_e2]) + + pp_infixly pp_op + = hang pp_e1 2 (sep [pp_op, nest 2 pp_e2]) + +ppr_expr (NegApp _ e _) = char '-' <+> pprDebugParendExpr appPrec e + +ppr_expr (SectionL _ expr op) + = case unLoc op of + HsVar _ (L _ v) -> pp_infixly v + HsConLikeOut _ c -> pp_infixly (conLikeName c) + HsUnboundVar _ h@TrueExprHole{} + -> pp_infixly (unboundVarOcc h) + _ -> pp_prefixly + where + pp_expr = pprDebugParendExpr opPrec expr + + pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op]) + 4 (hsep [pp_expr, text "x_ )"]) + + pp_infixly :: forall a. (OutputableBndr a) => a -> SDoc + pp_infixly v = (sep [pp_expr, pprInfixOcc v]) + +ppr_expr (SectionR _ op expr) + = case unLoc op of + HsVar _ (L _ v) -> pp_infixly v + HsConLikeOut _ c -> pp_infixly (conLikeName c) + HsUnboundVar _ h@TrueExprHole{} + -> pp_infixly (unboundVarOcc h) + _ -> pp_prefixly + where + pp_expr = pprDebugParendExpr opPrec expr + + pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, text "x_"]) + 4 (pp_expr <> rparen) + + pp_infixly :: forall a. (OutputableBndr a) => a -> SDoc + pp_infixly v = sep [pprInfixOcc v, pp_expr] + +ppr_expr (ExplicitTuple _ exprs boxity) + = tupleParens (boxityTupleSort boxity) (fcat (ppr_tup_args $ map unLoc exprs)) + where + ppr_tup_args [] = [] + ppr_tup_args (Present _ e : es) = (ppr_lexpr e <> punc es) : ppr_tup_args es + ppr_tup_args (Missing _ : es) = punc es : ppr_tup_args es + ppr_tup_args (XTupArg x : es) = (ppr x <> punc es) : ppr_tup_args es + + punc (Present {} : _) = comma <> space + punc (Missing {} : _) = comma + punc (XTupArg {} : _) = comma <> space + punc [] = empty + +ppr_expr (ExplicitSum _ alt arity expr) + = text "(#" <+> ppr_bars (alt - 1) <+> ppr expr <+> ppr_bars (arity - alt) <+> text "#)" + where + ppr_bars n = hsep (replicate n (char '|')) + +ppr_expr (HsLam _ matches) + = pprMatches matches + +ppr_expr (HsLamCase _ matches) + = sep [ sep [text "\\case"], + nest 2 (pprMatches matches) ] + +ppr_expr (HsCase _ expr matches@(MG { mg_alts = L _ [_] })) + = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of {")], + nest 2 (pprMatches matches) <+> char '}'] +ppr_expr (HsCase _ expr matches) + = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of")], + nest 2 (pprMatches matches) ] + +ppr_expr (HsIf _ _ e1 e2 e3) + = sep [hsep [text "if", nest 2 (ppr e1), ptext (sLit "then")], + nest 4 (ppr e2), + text "else", + nest 4 (ppr e3)] + +ppr_expr (HsMultiIf _ alts) + = hang (text "if") 3 (vcat (map ppr_alt alts)) + where ppr_alt (L _ (GRHS _ guards expr)) = + hang vbar 2 (ppr_one one_alt) + where + ppr_one [] = panic "ppr_exp HsMultiIf" + ppr_one (h:t) = hang h 2 (sep t) + one_alt = [ interpp'SP guards + , text "->" <+> pprDeeper (ppr expr) ] + ppr_alt (L _ (XGRHS x)) = ppr x + +-- special case: let ... in let ... +ppr_expr (HsLet _ (L _ binds) expr@(L _ (HsLet _ _ _))) + = sep [hang (text "let") 2 (hsep [pprBinds binds, ptext (sLit "in")]), + ppr_lexpr expr] + +ppr_expr (HsLet _ (L _ binds) expr) + = sep [hang (text "let") 2 (pprBinds binds), + hang (text "in") 2 (ppr expr)] + +ppr_expr (HsDo _ do_or_list_comp (L _ stmts)) = pprDo do_or_list_comp stmts + +ppr_expr (ExplicitList _ _ exprs) + = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs))) + +ppr_expr (RecordCon { rcon_con_name = con_id, rcon_flds = rbinds }) + = hang (ppr con_id) 2 (ppr rbinds) + +ppr_expr (RecordUpd { rupd_expr = L _ aexp, rupd_flds = rbinds }) + = hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds)))) + +ppr_expr (ExprWithTySig _ expr sig) + = hang (nest 2 (ppr_lexpr expr) <+> dcolon) + 4 (ppr sig) + +ppr_expr (ArithSeq _ _ info) = brackets (ppr info) + +ppr_expr (EWildPat _) = char '_' +ppr_expr (ELazyPat _ e) = char '~' <> ppr e +ppr_expr (EAsPat _ (L _ v) e) = pprPrefixOcc v <> char '@' <> ppr e +ppr_expr (EViewPat _ p e) = ppr p <+> text "->" <+> ppr e + +ppr_expr (HsSCC _ st (StringLiteral stl lbl) expr) + = sep [ pprWithSourceText st (text "{-# SCC") + -- no doublequotes if stl empty, for the case where the SCC was written + -- without quotes. + <+> pprWithSourceText stl (ftext lbl) <+> text "#-}", + ppr expr ] + +ppr_expr (HsWrap _ co_fn e) + = pprHsWrapper co_fn (\parens -> if parens then pprExpr e + else pprExpr e) + +ppr_expr (HsSpliceE _ s) = pprSplice s +ppr_expr (HsBracket _ b) = pprHsBracket b +ppr_expr (HsRnBracketOut _ e []) = ppr e +ppr_expr (HsRnBracketOut _ e ps) = ppr e $$ text "pending(rn)" <+> ppr ps +ppr_expr (HsTcBracketOut _ e []) = ppr e +ppr_expr (HsTcBracketOut _ e ps) = ppr e $$ text "pending(tc)" <+> ppr ps + +ppr_expr (HsProc _ pat (L _ (HsCmdTop _ cmd))) + = hsep [text "proc", ppr pat, ptext (sLit "->"), ppr cmd] +ppr_expr (HsProc _ pat (L _ (XCmdTop x))) + = hsep [text "proc", ppr pat, ptext (sLit "->"), ppr x] + +ppr_expr (HsStatic _ e) + = hsep [text "static", ppr e] + +ppr_expr (HsTick _ tickish exp) + = pprTicks (ppr exp) $ + ppr tickish <+> ppr_lexpr exp +ppr_expr (HsBinTick _ tickIdTrue tickIdFalse exp) + = pprTicks (ppr exp) $ + hcat [text "bintick<", + ppr tickIdTrue, + text ",", + ppr tickIdFalse, + text ">(", + ppr exp, text ")"] +ppr_expr (HsTickPragma _ _ externalSrcLoc _ exp) + = pprTicks (ppr exp) $ + hcat [text "tickpragma<", + pprExternalSrcLoc externalSrcLoc, + text ">(", + ppr exp, + text ")"] + +ppr_expr (HsRecFld _ f) = ppr f +ppr_expr (XExpr x) = ppr x + +ppr_apps :: (OutputableBndrId (GhcPass p)) + => HsExpr (GhcPass p) + -> [Either (LHsExpr (GhcPass p)) (LHsWcType (NoGhcTc (GhcPass p)))] + -> SDoc +ppr_apps (HsApp _ (L _ fun) arg) args + = ppr_apps fun (Left arg : args) +ppr_apps (HsAppType _ (L _ fun) arg) args + = ppr_apps fun (Right arg : args) +ppr_apps fun args = hang (ppr_expr fun) 2 (sep (map pp args)) + where + pp (Left arg) = ppr arg + -- pp (Right (LHsWcTypeX (HsWC { hswc_body = L _ arg }))) + -- = char '@' <> pprHsType arg + pp (Right arg) + = char '@' <> ppr arg + +pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc +pprExternalSrcLoc (StringLiteral _ src,(n1,n2),(n3,n4)) + = ppr (src,(n1,n2),(n3,n4)) + +{- +HsSyn records exactly where the user put parens, with HsPar. +So generally speaking we print without adding any parens. +However, some code is internally generated, and in some places +parens are absolutely required; so for these places we use +pprParendLExpr (but don't print double parens of course). + +For operator applications we don't add parens, because the operator +fixities should do the job, except in debug mode (-dppr-debug) so we +can see the structure of the parse tree. +-} + +pprDebugParendExpr :: (OutputableBndrId (GhcPass p)) + => PprPrec -> LHsExpr (GhcPass p) -> SDoc +pprDebugParendExpr p expr + = getPprStyle (\sty -> + if debugStyle sty then pprParendLExpr p expr + else pprLExpr expr) + +pprParendLExpr :: (OutputableBndrId (GhcPass p)) + => PprPrec -> LHsExpr (GhcPass p) -> SDoc +pprParendLExpr p (L _ e) = pprParendExpr p e + +pprParendExpr :: (OutputableBndrId (GhcPass p)) + => PprPrec -> HsExpr (GhcPass p) -> SDoc +pprParendExpr p expr + | hsExprNeedsParens p expr = parens (pprExpr expr) + | otherwise = pprExpr expr + -- Using pprLExpr makes sure that we go 'deeper' + -- I think that is usually (always?) right + +-- | @'hsExprNeedsParens' p e@ returns 'True' if the expression @e@ needs +-- parentheses under precedence @p@. +hsExprNeedsParens :: PprPrec -> HsExpr p -> Bool +hsExprNeedsParens p = go + where + go (HsVar{}) = False + go (HsUnboundVar{}) = False + go (HsConLikeOut{}) = False + go (HsIPVar{}) = False + go (HsOverLabel{}) = False + go (HsLit _ l) = hsLitNeedsParens p l + go (HsOverLit _ ol) = hsOverLitNeedsParens p ol + go (HsPar{}) = False + go (HsCoreAnn _ _ _ (L _ e)) = go e + go (HsApp{}) = p >= appPrec + go (HsAppType {}) = p >= appPrec + go (OpApp{}) = p >= opPrec + go (NegApp{}) = p > topPrec + go (SectionL{}) = True + go (SectionR{}) = True + go (ExplicitTuple{}) = False + go (ExplicitSum{}) = False + go (HsLam{}) = p > topPrec + go (HsLamCase{}) = p > topPrec + go (HsCase{}) = p > topPrec + go (HsIf{}) = p > topPrec + go (HsMultiIf{}) = p > topPrec + go (HsLet{}) = p > topPrec + go (HsDo _ sc _) + | isComprehensionContext sc = False + | otherwise = p > topPrec + go (ExplicitList{}) = False + go (RecordUpd{}) = False + go (ExprWithTySig{}) = p >= sigPrec + go (ArithSeq{}) = False + go (EWildPat{}) = False + go (ELazyPat{}) = False + go (EAsPat{}) = False + go (EViewPat{}) = True + go (HsSCC{}) = p >= appPrec + go (HsWrap _ _ e) = go e + go (HsSpliceE{}) = False + go (HsBracket{}) = False + go (HsRnBracketOut{}) = False + go (HsTcBracketOut{}) = False + go (HsProc{}) = p > topPrec + go (HsStatic{}) = p >= appPrec + go (HsTick _ _ (L _ e)) = go e + go (HsBinTick _ _ _ (L _ e)) = go e + go (HsTickPragma _ _ _ _ (L _ e)) = go e + go (RecordCon{}) = False + go (HsRecFld{}) = False + go (XExpr{}) = True + +-- | @'parenthesizeHsExpr' p e@ checks if @'hsExprNeedsParens' p e@ is true, +-- and if so, surrounds @e@ with an 'HsPar'. Otherwise, it simply returns @e@. +parenthesizeHsExpr :: PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) +parenthesizeHsExpr p le@(L loc e) + | hsExprNeedsParens p e = L loc (HsPar NoExt le) + | otherwise = le + +isAtomicHsExpr :: HsExpr id -> Bool +-- True of a single token +isAtomicHsExpr (HsVar {}) = True +isAtomicHsExpr (HsConLikeOut {}) = True +isAtomicHsExpr (HsLit {}) = True +isAtomicHsExpr (HsOverLit {}) = True +isAtomicHsExpr (HsIPVar {}) = True +isAtomicHsExpr (HsOverLabel {}) = True +isAtomicHsExpr (HsUnboundVar {}) = True +isAtomicHsExpr (HsWrap _ _ e) = isAtomicHsExpr e +isAtomicHsExpr (HsPar _ e) = isAtomicHsExpr (unLoc e) +isAtomicHsExpr (HsRecFld{}) = True +isAtomicHsExpr _ = False + +{- +************************************************************************ +* * +\subsection{Commands (in arrow abstractions)} +* * +************************************************************************ + +We re-use HsExpr to represent these. +-} + +-- | Located Haskell Command (for arrow syntax) +type LHsCmd id = Located (HsCmd id) + +-- | Haskell Command (e.g. a "statement" in an Arrow proc block) +data HsCmd id + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.Annlarrowtail', + -- 'ApiAnnotation.Annrarrowtail','ApiAnnotation.AnnLarrowtail', + -- 'ApiAnnotation.AnnRarrowtail' + + -- For details on above see note [Api annotations] in ApiAnnotation + = HsCmdArrApp -- Arrow tail, or arrow application (f -< arg) + (XCmdArrApp id) -- type of the arrow expressions f, + -- of the form a t t', where arg :: t + (LHsExpr id) -- arrow expression, f + (LHsExpr id) -- input expression, arg + HsArrAppType -- higher-order (-<<) or first-order (-<) + Bool -- True => right-to-left (f -< arg) + -- False => left-to-right (arg >- f) + + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpenB' @'(|'@, + -- 'ApiAnnotation.AnnCloseB' @'|)'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + | HsCmdArrForm -- Command formation, (| e cmd1 .. cmdn |) + (XCmdArrForm id) + (LHsExpr id) -- The operator. + -- After type-checking, a type abstraction to be + -- applied to the type of the local environment tuple + LexicalFixity -- Whether the operator appeared prefix or infix when + -- parsed. + (Maybe Fixity) -- fixity (filled in by the renamer), for forms that + -- were converted from OpApp's by the renamer + [LHsCmdTop id] -- argument commands + + | HsCmdApp (XCmdApp id) + (LHsCmd id) + (LHsExpr id) + + | HsCmdLam (XCmdLam id) + (MatchGroup id (LHsCmd id)) -- kappa + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam', + -- 'ApiAnnotation.AnnRarrow', + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsCmdPar (XCmdPar id) + (LHsCmd id) -- parenthesised command + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, + -- 'ApiAnnotation.AnnClose' @')'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsCmdCase (XCmdCase id) + (LHsExpr id) + (MatchGroup id (LHsCmd id)) -- bodies are HsCmd's + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnCase', + -- 'ApiAnnotation.AnnOf','ApiAnnotation.AnnOpen' @'{'@, + -- 'ApiAnnotation.AnnClose' @'}'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsCmdIf (XCmdIf id) + (Maybe (SyntaxExpr id)) -- cond function + (LHsExpr id) -- predicate + (LHsCmd id) -- then part + (LHsCmd id) -- else part + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnIf', + -- 'ApiAnnotation.AnnSemi', + -- 'ApiAnnotation.AnnThen','ApiAnnotation.AnnSemi', + -- 'ApiAnnotation.AnnElse', + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsCmdLet (XCmdLet id) + (LHsLocalBinds id) -- let(rec) + (LHsCmd id) + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet', + -- 'ApiAnnotation.AnnOpen' @'{'@, + -- 'ApiAnnotation.AnnClose' @'}'@,'ApiAnnotation.AnnIn' + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsCmdDo (XCmdDo id) -- Type of the whole expression + (Located [CmdLStmt id]) + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDo', + -- 'ApiAnnotation.AnnOpen', 'ApiAnnotation.AnnSemi', + -- 'ApiAnnotation.AnnVbar', + -- 'ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsCmdWrap (XCmdWrap id) + HsWrapper + (HsCmd id) -- If cmd :: arg1 --> res + -- wrap :: arg1 "->" arg2 + -- Then (HsCmdWrap wrap cmd) :: arg2 --> res + | XCmd (XXCmd id) -- Note [Trees that Grow] extension point + +type instance XCmdArrApp GhcPs = NoExt +type instance XCmdArrApp GhcRn = NoExt +type instance XCmdArrApp GhcTc = Type + +type instance XCmdArrForm (GhcPass _) = NoExt +type instance XCmdApp (GhcPass _) = NoExt +type instance XCmdLam (GhcPass _) = NoExt +type instance XCmdPar (GhcPass _) = NoExt +type instance XCmdCase (GhcPass _) = NoExt +type instance XCmdIf (GhcPass _) = NoExt +type instance XCmdLet (GhcPass _) = NoExt + +type instance XCmdDo GhcPs = NoExt +type instance XCmdDo GhcRn = NoExt +type instance XCmdDo GhcTc = Type + +type instance XCmdWrap (GhcPass _) = NoExt +type instance XXCmd (GhcPass _) = NoExt + +-- | Haskell Array Application Type +data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp + deriving Data + + +{- | Top-level command, introducing a new arrow. +This may occur inside a proc (where the stack is empty) or as an +argument of a command-forming operator. +-} + +-- | Located Haskell Top-level Command +type LHsCmdTop p = Located (HsCmdTop p) + +-- | Haskell Top-level Command +data HsCmdTop p + = HsCmdTop (XCmdTop p) + (LHsCmd p) + | XCmdTop (XXCmdTop p) -- Note [Trees that Grow] extension point + +data CmdTopTc + = CmdTopTc Type -- Nested tuple of inputs on the command's stack + Type -- return type of the command + (CmdSyntaxTable GhcTc) -- See Note [CmdSyntaxTable] + +type instance XCmdTop GhcPs = NoExt +type instance XCmdTop GhcRn = CmdSyntaxTable GhcRn -- See Note [CmdSyntaxTable] +type instance XCmdTop GhcTc = CmdTopTc + +type instance XXCmdTop (GhcPass _) = NoExt + +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsCmd p) where + ppr cmd = pprCmd cmd + +----------------------- +-- pprCmd and pprLCmd call pprDeeper; +-- the underscore versions do not +pprLCmd :: (OutputableBndrId (GhcPass p)) => LHsCmd (GhcPass p) -> SDoc +pprLCmd (L _ c) = pprCmd c + +pprCmd :: (OutputableBndrId (GhcPass p)) => HsCmd (GhcPass p) -> SDoc +pprCmd c | isQuietHsCmd c = ppr_cmd c + | otherwise = pprDeeper (ppr_cmd c) + +isQuietHsCmd :: HsCmd id -> Bool +-- Parentheses do display something, but it gives little info and +-- if we go deeper when we go inside them then we get ugly things +-- like (...) +isQuietHsCmd (HsCmdPar {}) = True +-- applications don't display anything themselves +isQuietHsCmd (HsCmdApp {}) = True +isQuietHsCmd _ = False + +----------------------- +ppr_lcmd :: (OutputableBndrId (GhcPass p)) => LHsCmd (GhcPass p) -> SDoc +ppr_lcmd c = ppr_cmd (unLoc c) + +ppr_cmd :: forall p. (OutputableBndrId (GhcPass p)) => HsCmd (GhcPass p) -> SDoc +ppr_cmd (HsCmdPar _ c) = parens (ppr_lcmd c) + +ppr_cmd (HsCmdApp _ c e) + = let (fun, args) = collect_args c [e] in + hang (ppr_lcmd fun) 2 (sep (map ppr args)) + where + collect_args (L _ (HsCmdApp _ fun arg)) args = collect_args fun (arg:args) + collect_args fun args = (fun, args) + +ppr_cmd (HsCmdLam _ matches) + = pprMatches matches + +ppr_cmd (HsCmdCase _ expr matches) + = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of")], + nest 2 (pprMatches matches) ] + +ppr_cmd (HsCmdIf _ _ e ct ce) + = sep [hsep [text "if", nest 2 (ppr e), ptext (sLit "then")], + nest 4 (ppr ct), + text "else", + nest 4 (ppr ce)] + +-- special case: let ... in let ... +ppr_cmd (HsCmdLet _ (L _ binds) cmd@(L _ (HsCmdLet {}))) + = sep [hang (text "let") 2 (hsep [pprBinds binds, ptext (sLit "in")]), + ppr_lcmd cmd] + +ppr_cmd (HsCmdLet _ (L _ binds) cmd) + = sep [hang (text "let") 2 (pprBinds binds), + hang (text "in") 2 (ppr cmd)] + +ppr_cmd (HsCmdDo _ (L _ stmts)) = pprDo ArrowExpr stmts + +ppr_cmd (HsCmdWrap _ w cmd) + = pprHsWrapper w (\_ -> parens (ppr_cmd cmd)) +ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp True) + = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg] +ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp False) + = hsep [ppr_lexpr arg, arrowt, ppr_lexpr arrow] +ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp True) + = hsep [ppr_lexpr arrow, larrowtt, ppr_lexpr arg] +ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp False) + = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow] + +ppr_cmd (HsCmdArrForm _ (L _ (HsVar _ (L _ v))) _ (Just _) [arg1, arg2]) + = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v + , pprCmdArg (unLoc arg2)]) +ppr_cmd (HsCmdArrForm _ (L _ (HsVar _ (L _ v))) Infix _ [arg1, arg2]) + = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v + , pprCmdArg (unLoc arg2)]) +ppr_cmd (HsCmdArrForm _ (L _ (HsConLikeOut _ c)) _ (Just _) [arg1, arg2]) + = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c) + , pprCmdArg (unLoc arg2)]) +ppr_cmd (HsCmdArrForm _ (L _ (HsConLikeOut _ c)) Infix _ [arg1, arg2]) + = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c) + , pprCmdArg (unLoc arg2)]) +ppr_cmd (HsCmdArrForm _ op _ _ args) + = hang (text "(|" <+> ppr_lexpr op) + 4 (sep (map (pprCmdArg.unLoc) args) <+> text "|)") +ppr_cmd (XCmd x) = ppr x + +pprCmdArg :: (OutputableBndrId (GhcPass p)) => HsCmdTop (GhcPass p) -> SDoc +pprCmdArg (HsCmdTop _ cmd) + = ppr_lcmd cmd +pprCmdArg (XCmdTop x) = ppr x + +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsCmdTop p) where + ppr = pprCmdArg + +{- +************************************************************************ +* * +\subsection{Record binds} +* * +************************************************************************ +-} + +-- | Haskell Record Bindings +type HsRecordBinds p = HsRecFields p (LHsExpr p) + +{- +************************************************************************ +* * +\subsection{@Match@, @GRHSs@, and @GRHS@ datatypes} +* * +************************************************************************ + +@Match@es are sets of pattern bindings and right hand sides for +functions, patterns or case branches. For example, if a function @g@ +is defined as: +\begin{verbatim} +g (x,y) = y +g ((x:ys),y) = y+1, +\end{verbatim} +then \tr{g} has two @Match@es: @(x,y) = y@ and @((x:ys),y) = y+1@. + +It is always the case that each element of an @[Match]@ list has the +same number of @pats@s inside it. This corresponds to saying that +a function defined by pattern matching must have the same number of +patterns in each equation. +-} + +data MatchGroup p body + = MG { mg_ext :: XMG p body -- Posr typechecker, types of args and result + , mg_alts :: Located [LMatch p body] -- The alternatives + , mg_origin :: Origin } + -- The type is the type of the entire group + -- t1 -> ... -> tn -> tr + -- where there are n patterns + | XMatchGroup (XXMatchGroup p body) + +data MatchGroupTc + = MatchGroupTc + { mg_arg_tys :: [Type] -- Types of the arguments, t1..tn + , mg_res_ty :: Type -- Type of the result, tr + } deriving Data + +type instance XMG GhcPs b = NoExt +type instance XMG GhcRn b = NoExt +type instance XMG GhcTc b = MatchGroupTc + +type instance XXMatchGroup (GhcPass _) b = NoExt + +-- | Located Match +type LMatch id body = Located (Match id body) +-- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' when in a +-- list + +-- For details on above see note [Api annotations] in ApiAnnotation +data Match p body + = Match { + m_ext :: XCMatch p body, + m_ctxt :: HsMatchContext (NameOrRdrName (IdP p)), + -- See note [m_ctxt in Match] + m_pats :: [LPat p], -- The patterns + m_grhss :: (GRHSs p body) + } + | XMatch (XXMatch p body) + +type instance XCMatch (GhcPass _) b = NoExt +type instance XXMatch (GhcPass _) b = NoExt + +instance (idR ~ GhcPass pr, OutputableBndrId idR, Outputable body) + => Outputable (Match idR body) where + ppr = pprMatch + +{- +Note [m_ctxt in Match] +~~~~~~~~~~~~~~~~~~~~~~ + +A Match can occur in a number of contexts, such as a FunBind, HsCase, HsLam and +so on. + +In order to simplify tooling processing and pretty print output, the provenance +is captured in an HsMatchContext. + +This is particularly important for the API Annotations for a multi-equation +FunBind. + +The parser initially creates a FunBind with a single Match in it for +every function definition it sees. + +These are then grouped together by getMonoBind into a single FunBind, +where all the Matches are combined. + +In the process, all the original FunBind fun_id's bar one are +discarded, including the locations. + +This causes a problem for source to source conversions via API +Annotations, so the original fun_ids and infix flags are preserved in +the Match, when it originates from a FunBind. + +Example infix function definition requiring individual API Annotations + + (&&& ) [] [] = [] + xs &&& [] = xs + ( &&& ) [] ys = ys + + + +-} + + +isInfixMatch :: Match id body -> Bool +isInfixMatch match = case m_ctxt match of + FunRhs {mc_fixity = Infix} -> True + _ -> False + +isEmptyMatchGroup :: MatchGroup id body -> Bool +isEmptyMatchGroup (MG { mg_alts = ms }) = null $ unLoc ms +isEmptyMatchGroup (XMatchGroup{}) = panic "isEmptyMatchGroup" + +-- | Is there only one RHS in this list of matches? +isSingletonMatchGroup :: [LMatch id body] -> Bool +isSingletonMatchGroup matches + | [L _ match] <- matches + , Match { m_grhss = GRHSs { grhssGRHSs = [_] } } <- match + = True + | otherwise + = False + +matchGroupArity :: MatchGroup id body -> Arity +-- Precondition: MatchGroup is non-empty +-- This is called before type checking, when mg_arg_tys is not set +matchGroupArity (MG { mg_alts = alts }) + | L _ (alt1:_) <- alts = length (hsLMatchPats alt1) + | otherwise = panic "matchGroupArity" +matchGroupArity (XMatchGroup{}) = panic "matchGroupArity" + +hsLMatchPats :: LMatch id body -> [LPat id] +hsLMatchPats (L _ (Match { m_pats = pats })) = pats +hsLMatchPats (L _ (XMatch _)) = panic "hsLMatchPats" + +-- | Guarded Right-Hand Sides +-- +-- GRHSs are used both for pattern bindings and for Matches +-- +-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVbar', +-- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnWhere', +-- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose' +-- 'ApiAnnotation.AnnRarrow','ApiAnnotation.AnnSemi' + +-- For details on above see note [Api annotations] in ApiAnnotation +data GRHSs p body + = GRHSs { + grhssExt :: XCGRHSs p body, + grhssGRHSs :: [LGRHS p body], -- ^ Guarded RHSs + grhssLocalBinds :: LHsLocalBinds p -- ^ The where clause + } + | XGRHSs (XXGRHSs p body) + +type instance XCGRHSs (GhcPass _) b = NoExt +type instance XXGRHSs (GhcPass _) b = NoExt + +-- | Located Guarded Right-Hand Side +type LGRHS id body = Located (GRHS id body) + +-- | Guarded Right Hand Side. +data GRHS p body = GRHS (XCGRHS p body) + [GuardLStmt p] -- Guards + body -- Right hand side + | XGRHS (XXGRHS p body) + +type instance XCGRHS (GhcPass _) b = NoExt +type instance XXGRHS (GhcPass _) b = NoExt + +-- We know the list must have at least one @Match@ in it. + +pprMatches :: (OutputableBndrId (GhcPass idR), Outputable body) + => MatchGroup (GhcPass idR) body -> SDoc +pprMatches MG { mg_alts = matches } + = vcat (map pprMatch (map unLoc (unLoc matches))) + -- Don't print the type; it's only a place-holder before typechecking +pprMatches (XMatchGroup x) = ppr x + +-- Exported to HsBinds, which can't see the defn of HsMatchContext +pprFunBind :: (OutputableBndrId (GhcPass idR), Outputable body) + => MatchGroup (GhcPass idR) body -> SDoc +pprFunBind matches = pprMatches matches + +-- Exported to HsBinds, which can't see the defn of HsMatchContext +pprPatBind :: forall bndr p body. (OutputableBndrId (GhcPass bndr), + OutputableBndrId (GhcPass p), + Outputable body) + => LPat (GhcPass bndr) -> GRHSs (GhcPass p) body -> SDoc +pprPatBind pat (grhss) + = sep [ppr pat, + nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext (IdP (GhcPass p))) grhss)] + +pprMatch :: (OutputableBndrId (GhcPass idR), Outputable body) + => Match (GhcPass idR) body -> SDoc +pprMatch match + = sep [ sep (herald : map (nest 2 . pprParendLPat appPrec) other_pats) + , nest 2 (pprGRHSs ctxt (m_grhss match)) ] + where + ctxt = m_ctxt match + (herald, other_pats) + = case ctxt of + FunRhs {mc_fun=L _ fun, mc_fixity=fixity, mc_strictness=strictness} + | strictness == SrcStrict -> ASSERT(null $ m_pats match) + (char '!'<>pprPrefixOcc fun, m_pats match) + -- a strict variable binding + | fixity == Prefix -> (pprPrefixOcc fun, m_pats match) + -- f x y z = e + -- Not pprBndr; the AbsBinds will + -- have printed the signature + + | null pats2 -> (pp_infix, []) + -- x &&& y = e + + | otherwise -> (parens pp_infix, pats2) + -- (x &&& y) z = e + where + pp_infix = pprParendLPat opPrec pat1 + <+> pprInfixOcc fun + <+> pprParendLPat opPrec pat2 + + LambdaExpr -> (char '\\', m_pats match) + + _ -> if null (m_pats match) + then (empty, []) + else ASSERT2( null pats1, ppr ctxt $$ ppr pat1 $$ ppr pats1 ) + (ppr pat1, []) -- No parens around the single pat + + (pat1:pats1) = m_pats match + (pat2:pats2) = pats1 + +pprGRHSs :: (OutputableBndrId (GhcPass idR), Outputable body) + => HsMatchContext idL -> GRHSs (GhcPass idR) body -> SDoc +pprGRHSs ctxt (GRHSs _ grhss (L _ binds)) + = vcat (map (pprGRHS ctxt . unLoc) grhss) + -- Print the "where" even if the contents of the binds is empty. Only + -- EmptyLocalBinds means no "where" keyword + $$ ppUnless (eqEmptyLocalBinds binds) + (text "where" $$ nest 4 (pprBinds binds)) +pprGRHSs _ (XGRHSs x) = ppr x + +pprGRHS :: (OutputableBndrId (GhcPass idR), Outputable body) + => HsMatchContext idL -> GRHS (GhcPass idR) body -> SDoc +pprGRHS ctxt (GRHS _ [] body) + = pp_rhs ctxt body + +pprGRHS ctxt (GRHS _ guards body) + = sep [vbar <+> interpp'SP guards, pp_rhs ctxt body] + +pprGRHS _ (XGRHS x) = ppr x + +pp_rhs :: Outputable body => HsMatchContext idL -> body -> SDoc +pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs) + +{- +************************************************************************ +* * +\subsection{Do stmts and list comprehensions} +* * +************************************************************************ +-} + +-- | Located @do@ block Statement +type LStmt id body = Located (StmtLR id id body) + +-- | Located Statement with separate Left and Right id's +type LStmtLR idL idR body = Located (StmtLR idL idR body) + +-- | @do@ block Statement +type Stmt id body = StmtLR id id body + +-- | Command Located Statement +type CmdLStmt id = LStmt id (LHsCmd id) + +-- | Command Statement +type CmdStmt id = Stmt id (LHsCmd id) + +-- | Expression Located Statement +type ExprLStmt id = LStmt id (LHsExpr id) + +-- | Expression Statement +type ExprStmt id = Stmt id (LHsExpr id) + +-- | Guard Located Statement +type GuardLStmt id = LStmt id (LHsExpr id) + +-- | Guard Statement +type GuardStmt id = Stmt id (LHsExpr id) + +-- | Ghci Located Statement +type GhciLStmt id = LStmt id (LHsExpr id) + +-- | Ghci Statement +type GhciStmt id = Stmt id (LHsExpr id) + +-- The SyntaxExprs in here are used *only* for do-notation and monad +-- comprehensions, which have rebindable syntax. Otherwise they are unused. +-- | API Annotations when in qualifier lists or guards +-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVbar', +-- 'ApiAnnotation.AnnComma','ApiAnnotation.AnnThen', +-- 'ApiAnnotation.AnnBy','ApiAnnotation.AnnBy', +-- 'ApiAnnotation.AnnGroup','ApiAnnotation.AnnUsing' + +-- For details on above see note [Api annotations] in ApiAnnotation +data StmtLR idL idR body -- body should always be (LHs**** idR) + = LastStmt -- Always the last Stmt in ListComp, MonadComp, + -- and (after the renamer, see RnExpr.checkLastStmt) DoExpr, MDoExpr + -- Not used for GhciStmtCtxt, PatGuard, which scope over other stuff + (XLastStmt idL idR body) + body + Bool -- True <=> return was stripped by ApplicativeDo + (SyntaxExpr idR) -- The return operator + -- The return operator is used only for MonadComp + -- For ListComp we use the baked-in 'return' + -- For DoExpr, MDoExpr, we don't apply a 'return' at all + -- See Note [Monad Comprehensions] + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLarrow' + + -- For details on above see note [Api annotations] in ApiAnnotation + | BindStmt (XBindStmt idL idR body) -- Post typechecking, + -- result type of the function passed to bind; + -- that is, S in (>>=) :: Q -> (R -> S) -> T + (LPat idL) + body + (SyntaxExpr idR) -- The (>>=) operator; see Note [The type of bind in Stmts] + (SyntaxExpr idR) -- The fail operator + -- The fail operator is noSyntaxExpr + -- if the pattern match can't fail + + -- | 'ApplicativeStmt' represents an applicative expression built with + -- '<$>' and '<*>'. It is generated by the renamer, and is desugared into the + -- appropriate applicative expression by the desugarer, but it is intended + -- to be invisible in error messages. + -- + -- For full details, see Note [ApplicativeDo] in RnExpr + -- + | ApplicativeStmt + (XApplicativeStmt idL idR body) -- Post typecheck, Type of the body + [ ( SyntaxExpr idR + , ApplicativeArg idL) ] + -- [(<$>, e1), (<*>, e2), ..., (<*>, en)] + (Maybe (SyntaxExpr idR)) -- 'join', if necessary + + | BodyStmt (XBodyStmt idL idR body) -- Post typecheck, element type + -- of the RHS (used for arrows) + body -- See Note [BodyStmt] + (SyntaxExpr idR) -- The (>>) operator + (SyntaxExpr idR) -- The `guard` operator; used only in MonadComp + -- See notes [Monad Comprehensions] + + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet' + -- 'ApiAnnotation.AnnOpen' @'{'@,'ApiAnnotation.AnnClose' @'}'@, + + -- For details on above see note [Api annotations] in ApiAnnotation + | LetStmt (XLetStmt idL idR body) (LHsLocalBindsLR idL idR) + + -- ParStmts only occur in a list/monad comprehension + | ParStmt (XParStmt idL idR body) -- Post typecheck, + -- S in (>>=) :: Q -> (R -> S) -> T + [ParStmtBlock idL idR] + (HsExpr idR) -- Polymorphic `mzip` for monad comprehensions + (SyntaxExpr idR) -- The `>>=` operator + -- See notes [Monad Comprehensions] + -- After renaming, the ids are the binders + -- bound by the stmts and used after themp + + | TransStmt { + trS_ext :: XTransStmt idL idR body, -- Post typecheck, + -- R in (>>=) :: Q -> (R -> S) -> T + trS_form :: TransForm, + trS_stmts :: [ExprLStmt idL], -- Stmts to the *left* of the 'group' + -- which generates the tuples to be grouped + + trS_bndrs :: [(IdP idR, IdP idR)], -- See Note [TransStmt binder map] + + trS_using :: LHsExpr idR, + trS_by :: Maybe (LHsExpr idR), -- "by e" (optional) + -- Invariant: if trS_form = GroupBy, then grp_by = Just e + + trS_ret :: SyntaxExpr idR, -- The monomorphic 'return' function for + -- the inner monad comprehensions + trS_bind :: SyntaxExpr idR, -- The '(>>=)' operator + trS_fmap :: HsExpr idR -- The polymorphic 'fmap' function for desugaring + -- Only for 'group' forms + -- Just a simple HsExpr, because it's + -- too polymorphic for tcSyntaxOp + } -- See Note [Monad Comprehensions] + + -- Recursive statement (see Note [How RecStmt works] below) + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRec' + + -- For details on above see note [Api annotations] in ApiAnnotation + | RecStmt + { recS_ext :: XRecStmt idL idR body + , recS_stmts :: [LStmtLR idL idR body] + + -- The next two fields are only valid after renaming + , recS_later_ids :: [IdP idR] + -- The ids are a subset of the variables bound by the + -- stmts that are used in stmts that follow the RecStmt + + , recS_rec_ids :: [IdP idR] + -- Ditto, but these variables are the "recursive" ones, + -- that are used before they are bound in the stmts of + -- the RecStmt. + -- An Id can be in both groups + -- Both sets of Ids are (now) treated monomorphically + -- See Note [How RecStmt works] for why they are separate + + -- Rebindable syntax + , recS_bind_fn :: SyntaxExpr idR -- The bind function + , recS_ret_fn :: SyntaxExpr idR -- The return function + , recS_mfix_fn :: SyntaxExpr idR -- The mfix function + } + | XStmtLR (XXStmtLR idL idR body) + +-- Extra fields available post typechecking for RecStmt. +data RecStmtTc = + RecStmtTc + { recS_bind_ty :: Type -- S in (>>=) :: Q -> (R -> S) -> T + , recS_later_rets :: [PostTcExpr] -- (only used in the arrow version) + , recS_rec_rets :: [PostTcExpr] -- These expressions correspond 1-to-1 + -- with recS_later_ids and recS_rec_ids, + -- and are the expressions that should be + -- returned by the recursion. + -- They may not quite be the Ids themselves, + -- because the Id may be *polymorphic*, but + -- the returned thing has to be *monomorphic*, + -- so they may be type applications + + , recS_ret_ty :: Type -- The type of + -- do { stmts; return (a,b,c) } + -- With rebindable syntax the type might not + -- be quite as simple as (m (tya, tyb, tyc)). + } + + +type instance XLastStmt (GhcPass _) (GhcPass _) b = NoExt + +type instance XBindStmt (GhcPass _) GhcPs b = NoExt +type instance XBindStmt (GhcPass _) GhcRn b = NoExt +type instance XBindStmt (GhcPass _) GhcTc b = Type + +type instance XApplicativeStmt (GhcPass _) GhcPs b = NoExt +type instance XApplicativeStmt (GhcPass _) GhcRn b = NoExt +type instance XApplicativeStmt (GhcPass _) GhcTc b = Type + +type instance XBodyStmt (GhcPass _) GhcPs b = NoExt +type instance XBodyStmt (GhcPass _) GhcRn b = NoExt +type instance XBodyStmt (GhcPass _) GhcTc b = Type + +type instance XLetStmt (GhcPass _) (GhcPass _) b = NoExt + +type instance XParStmt (GhcPass _) GhcPs b = NoExt +type instance XParStmt (GhcPass _) GhcRn b = NoExt +type instance XParStmt (GhcPass _) GhcTc b = Type + +type instance XTransStmt (GhcPass _) GhcPs b = NoExt +type instance XTransStmt (GhcPass _) GhcRn b = NoExt +type instance XTransStmt (GhcPass _) GhcTc b = Type + +type instance XRecStmt (GhcPass _) GhcPs b = NoExt +type instance XRecStmt (GhcPass _) GhcRn b = NoExt +type instance XRecStmt (GhcPass _) GhcTc b = RecStmtTc + +type instance XXStmtLR (GhcPass _) (GhcPass _) b = NoExt + +data TransForm -- The 'f' below is the 'using' function, 'e' is the by function + = ThenForm -- then f or then f by e (depending on trS_by) + | GroupForm -- then group using f or then group by e using f (depending on trS_by) + deriving Data + +-- | Parenthesised Statement Block +data ParStmtBlock idL idR + = ParStmtBlock + (XParStmtBlock idL idR) + [ExprLStmt idL] + [IdP idR] -- The variables to be returned + (SyntaxExpr idR) -- The return operator + | XParStmtBlock (XXParStmtBlock idL idR) + +type instance XParStmtBlock (GhcPass pL) (GhcPass pR) = NoExt +type instance XXParStmtBlock (GhcPass pL) (GhcPass pR) = NoExt + +-- | Applicative Argument +data ApplicativeArg idL + = ApplicativeArgOne -- A single statement (BindStmt or BodyStmt) + (XApplicativeArgOne idL) + (LPat idL) -- WildPat if it was a BodyStmt (see below) + (LHsExpr idL) + Bool -- True <=> was a BodyStmt + -- False <=> was a BindStmt + -- See Note [Applicative BodyStmt] + + | ApplicativeArgMany -- do { stmts; return vars } + (XApplicativeArgMany idL) + [ExprLStmt idL] -- stmts + (HsExpr idL) -- return (v1,..,vn), or just (v1,..,vn) + (LPat idL) -- (v1,...,vn) + | XApplicativeArg (XXApplicativeArg idL) + +type instance XApplicativeArgOne (GhcPass _) = NoExt +type instance XApplicativeArgMany (GhcPass _) = NoExt +type instance XXApplicativeArg (GhcPass _) = NoExt + +{- +Note [The type of bind in Stmts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Some Stmts, notably BindStmt, keep the (>>=) bind operator. +We do NOT assume that it has type + (>>=) :: m a -> (a -> m b) -> m b +In some cases (see #303, #1537) it might have a more +exotic type, such as + (>>=) :: m i j a -> (a -> m j k b) -> m i k b +So we must be careful not to make assumptions about the type. +In particular, the monad may not be uniform throughout. + +Note [TransStmt binder map] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The [(idR,idR)] in a TransStmt behaves as follows: + + * Before renaming: [] + + * After renaming: + [ (x27,x27), ..., (z35,z35) ] + These are the variables + bound by the stmts to the left of the 'group' + and used either in the 'by' clause, + or in the stmts following the 'group' + Each item is a pair of identical variables. + + * After typechecking: + [ (x27:Int, x27:[Int]), ..., (z35:Bool, z35:[Bool]) ] + Each pair has the same unique, but different *types*. + +Note [BodyStmt] +~~~~~~~~~~~~~~~ +BodyStmts are a bit tricky, because what they mean +depends on the context. Consider the following contexts: + + A do expression of type (m res_ty) + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * BodyStmt E any_ty: do { ....; E; ... } + E :: m any_ty + Translation: E >> ... + + A list comprehensions of type [elt_ty] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * BodyStmt E Bool: [ .. | .... E ] + [ .. | ..., E, ... ] + [ .. | .... | ..., E | ... ] + E :: Bool + Translation: if E then fail else ... + + A guard list, guarding a RHS of type rhs_ty + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * BodyStmt E BooParStmtBlockl: f x | ..., E, ... = ...rhs... + E :: Bool + Translation: if E then fail else ... + + A monad comprehension of type (m res_ty) + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * BodyStmt E Bool: [ .. | .... E ] + E :: Bool + Translation: guard E >> ... + +Array comprehensions are handled like list comprehensions. + +Note [How RecStmt works] +~~~~~~~~~~~~~~~~~~~~~~~~ +Example: + HsDo [ BindStmt x ex + + , RecStmt { recS_rec_ids = [a, c] + , recS_stmts = [ BindStmt b (return (a,c)) + , LetStmt a = ...b... + , BindStmt c ec ] + , recS_later_ids = [a, b] + + , return (a b) ] + +Here, the RecStmt binds a,b,c; but + - Only a,b are used in the stmts *following* the RecStmt, + - Only a,c are used in the stmts *inside* the RecStmt + *before* their bindings + +Why do we need *both* rec_ids and later_ids? For monads they could be +combined into a single set of variables, but not for arrows. That +follows from the types of the respective feedback operators: + + mfix :: MonadFix m => (a -> m a) -> m a + loop :: ArrowLoop a => a (b,d) (c,d) -> a b c + +* For mfix, the 'a' covers the union of the later_ids and the rec_ids +* For 'loop', 'c' is the later_ids and 'd' is the rec_ids + +Note [Typing a RecStmt] +~~~~~~~~~~~~~~~~~~~~~~~ +A (RecStmt stmts) types as if you had written + + (v1,..,vn, _, ..., _) <- mfix (\~(_, ..., _, r1, ..., rm) -> + do { stmts + ; return (v1,..vn, r1, ..., rm) }) + +where v1..vn are the later_ids + r1..rm are the rec_ids + +Note [Monad Comprehensions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Monad comprehensions require separate functions like 'return' and +'>>=' for desugaring. These functions are stored in the statements +used in monad comprehensions. For example, the 'return' of the 'LastStmt' +expression is used to lift the body of the monad comprehension: + + [ body | stmts ] + => + stmts >>= \bndrs -> return body + +In transform and grouping statements ('then ..' and 'then group ..') the +'return' function is required for nested monad comprehensions, for example: + + [ body | stmts, then f, rest ] + => + f [ env | stmts ] >>= \bndrs -> [ body | rest ] + +BodyStmts require the 'Control.Monad.guard' function for boolean +expressions: + + [ body | exp, stmts ] + => + guard exp >> [ body | stmts ] + +Parallel statements require the 'Control.Monad.Zip.mzip' function: + + [ body | stmts1 | stmts2 | .. ] + => + mzip stmts1 (mzip stmts2 (..)) >>= \(bndrs1, (bndrs2, ..)) -> return body + +In any other context than 'MonadComp', the fields for most of these +'SyntaxExpr's stay bottom. + + +Note [Applicative BodyStmt] + +(#12143) For the purposes of ApplicativeDo, we treat any BodyStmt +as if it was a BindStmt with a wildcard pattern. For example, + + do + x <- A + B + return x + +is transformed as if it were + + do + x <- A + _ <- B + return x + +so it transforms to + + (\(x,_) -> x) <$> A <*> B + +But we have to remember when we treat a BodyStmt like a BindStmt, +because in error messages we want to emit the original syntax the user +wrote, not our internal representation. So ApplicativeArgOne has a +Bool flag that is True when the original statement was a BodyStmt, so +that we can pretty-print it correctly. +-} + +instance (Outputable (StmtLR idL idL (LHsExpr idL)), + Outputable (XXParStmtBlock idL idR)) + => Outputable (ParStmtBlock idL idR) where + ppr (ParStmtBlock _ stmts _ _) = interpp'SP stmts + ppr (XParStmtBlock x) = ppr x + +instance (idL ~ GhcPass pl,idR ~ GhcPass pr, + OutputableBndrId idL, OutputableBndrId idR, + Outputable body) + => Outputable (StmtLR idL idR body) where + ppr stmt = pprStmt stmt + +pprStmt :: forall idL idR body . (OutputableBndrId (GhcPass idL), + OutputableBndrId (GhcPass idR), + Outputable body) + => (StmtLR (GhcPass idL) (GhcPass idR) body) -> SDoc +pprStmt (LastStmt _ expr ret_stripped _) + = whenPprDebug (text "[last]") <+> + (if ret_stripped then text "return" else empty) <+> + ppr expr +pprStmt (BindStmt _ pat expr _ _) = hsep [ppr pat, larrow, ppr expr] +pprStmt (LetStmt _ (L _ binds)) = hsep [text "let", pprBinds binds] +pprStmt (BodyStmt _ expr _ _) = ppr expr +pprStmt (ParStmt _ stmtss _ _) = sep (punctuate (text " | ") (map ppr stmtss)) + +pprStmt (TransStmt { trS_stmts = stmts, trS_by = by + , trS_using = using, trS_form = form }) + = sep $ punctuate comma (map ppr stmts ++ [pprTransStmt by using form]) + +pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids + , recS_later_ids = later_ids }) + = text "rec" <+> + vcat [ ppr_do_stmts segment + , whenPprDebug (vcat [ text "rec_ids=" <> ppr rec_ids + , text "later_ids=" <> ppr later_ids])] + +pprStmt (ApplicativeStmt _ args mb_join) + = getPprStyle $ \style -> + if userStyle style + then pp_for_user + else pp_debug + where + -- make all the Applicative stuff invisible in error messages by + -- flattening the whole ApplicativeStmt nest back to a sequence + -- of statements. + pp_for_user = vcat $ concatMap flattenArg args + + -- ppr directly rather than transforming here, because we need to + -- inject a "return" which is hard when we're polymorphic in the id + -- type. + flattenStmt :: ExprLStmt (GhcPass idL) -> [SDoc] + flattenStmt (L _ (ApplicativeStmt _ args _)) = concatMap flattenArg args + flattenStmt stmt = [ppr stmt] + + flattenArg :: forall a . (a, ApplicativeArg (GhcPass idL)) -> [SDoc] + flattenArg (_, ApplicativeArgOne _ pat expr isBody) + | isBody = -- See Note [Applicative BodyStmt] + [ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr + :: ExprStmt (GhcPass idL))] + | otherwise = + [ppr (BindStmt (panic "pprStmt") pat expr noSyntaxExpr noSyntaxExpr + :: ExprStmt (GhcPass idL))] + flattenArg (_, ApplicativeArgMany _ stmts _ _) = + concatMap flattenStmt stmts + flattenArg (_, XApplicativeArg _) = panic "flattenArg" + + pp_debug = + let + ap_expr = sep (punctuate (text " |") (map pp_arg args)) + in + if isNothing mb_join + then ap_expr + else text "join" <+> parens ap_expr + + pp_arg :: (a, ApplicativeArg (GhcPass idL)) -> SDoc + pp_arg (_, ApplicativeArgOne _ pat expr isBody) + | isBody = -- See Note [Applicative BodyStmt] + ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr + :: ExprStmt (GhcPass idL)) + | otherwise = + ppr (BindStmt (panic "pprStmt") pat expr noSyntaxExpr noSyntaxExpr + :: ExprStmt (GhcPass idL)) + pp_arg (_, ApplicativeArgMany _ stmts return pat) = + ppr pat <+> + text "<-" <+> + ppr (HsDo (panic "pprStmt") DoExpr (noLoc + (stmts ++ + [noLoc (LastStmt noExt (noLoc return) False noSyntaxExpr)]))) + pp_arg (_, XApplicativeArg x) = ppr x + +pprStmt (XStmtLR x) = ppr x + +pprTransformStmt :: (OutputableBndrId (GhcPass p)) + => [IdP (GhcPass p)] -> LHsExpr (GhcPass p) + -> Maybe (LHsExpr (GhcPass p)) -> SDoc +pprTransformStmt bndrs using by + = sep [ text "then" <+> whenPprDebug (braces (ppr bndrs)) + , nest 2 (ppr using) + , nest 2 (pprBy by)] + +pprTransStmt :: Outputable body => Maybe body -> body -> TransForm -> SDoc +pprTransStmt by using ThenForm + = sep [ text "then", nest 2 (ppr using), nest 2 (pprBy by)] +pprTransStmt by using GroupForm + = sep [ text "then group", nest 2 (pprBy by), nest 2 (ptext (sLit "using") <+> ppr using)] + +pprBy :: Outputable body => Maybe body -> SDoc +pprBy Nothing = empty +pprBy (Just e) = text "by" <+> ppr e + +pprDo :: (OutputableBndrId (GhcPass p), Outputable body) + => HsStmtContext any -> [LStmt (GhcPass p) body] -> SDoc +pprDo DoExpr stmts = text "do" <+> ppr_do_stmts stmts +pprDo GhciStmtCtxt stmts = text "do" <+> ppr_do_stmts stmts +pprDo ArrowExpr stmts = text "do" <+> ppr_do_stmts stmts +pprDo MDoExpr stmts = text "mdo" <+> ppr_do_stmts stmts +pprDo ListComp stmts = brackets $ pprComp stmts +pprDo MonadComp stmts = brackets $ pprComp stmts +pprDo _ _ = panic "pprDo" -- PatGuard, ParStmtCxt + +ppr_do_stmts :: (OutputableBndrId (GhcPass idL), OutputableBndrId (GhcPass idR), + Outputable body) + => [LStmtLR (GhcPass idL) (GhcPass idR) body] -> SDoc +-- Print a bunch of do stmts +ppr_do_stmts stmts = pprDeeperList vcat (map ppr stmts) + +pprComp :: (OutputableBndrId (GhcPass p), Outputable body) + => [LStmt (GhcPass p) body] -> SDoc +pprComp quals -- Prints: body | qual1, ..., qualn + | Just (initStmts, L _ (LastStmt _ body _ _)) <- snocView quals + = if null initStmts + -- If there are no statements in a list comprehension besides the last + -- one, we simply treat it like a normal list. This does arise + -- occasionally in code that GHC generates, e.g., in implementations of + -- 'range' for derived 'Ix' instances for product datatypes with exactly + -- one constructor (e.g., see #12583). + then ppr body + else hang (ppr body <+> vbar) 2 (pprQuals initStmts) + | otherwise + = pprPanic "pprComp" (pprQuals quals) + +pprQuals :: (OutputableBndrId (GhcPass p), Outputable body) + => [LStmt (GhcPass p) body] -> SDoc +-- Show list comprehension qualifiers separated by commas +pprQuals quals = interpp'SP quals + +{- +************************************************************************ +* * + Template Haskell quotation brackets +* * +************************************************************************ +-} + +-- | Haskell Splice +data HsSplice id + = HsTypedSplice -- $$z or $$(f 4) + (XTypedSplice id) + SpliceDecoration -- Whether $$( ) variant found, for pretty printing + (IdP id) -- A unique name to identify this splice point + (LHsExpr id) -- See Note [Pending Splices] + + | HsUntypedSplice -- $z or $(f 4) + (XUntypedSplice id) + SpliceDecoration -- Whether $( ) variant found, for pretty printing + (IdP id) -- A unique name to identify this splice point + (LHsExpr id) -- See Note [Pending Splices] + + | HsQuasiQuote -- See Note [Quasi-quote overview] in TcSplice + (XQuasiQuote id) + (IdP id) -- Splice point + (IdP id) -- Quoter + SrcSpan -- The span of the enclosed string + FastString -- The enclosed string + + -- AZ:TODO: use XSplice instead of HsSpliced + | HsSpliced -- See Note [Delaying modFinalizers in untyped splices] in + -- RnSplice. + -- This is the result of splicing a splice. It is produced by + -- the renamer and consumed by the typechecker. It lives only + -- between the two. + (XSpliced id) + ThModFinalizers -- TH finalizers produced by the splice. + (HsSplicedThing id) -- The result of splicing + | HsSplicedT + DelayedSplice + | XSplice (XXSplice id) -- Note [Trees that Grow] extension point + +type instance XTypedSplice (GhcPass _) = NoExt +type instance XUntypedSplice (GhcPass _) = NoExt +type instance XQuasiQuote (GhcPass _) = NoExt +type instance XSpliced (GhcPass _) = NoExt +type instance XXSplice (GhcPass _) = NoExt + +-- | A splice can appear with various decorations wrapped around it. This data +-- type captures explicitly how it was originally written, for use in the pretty +-- printer. +data SpliceDecoration + = HasParens -- ^ $( splice ) or $$( splice ) + | HasDollar -- ^ $splice or $$splice + | NoParens -- ^ bare splice + deriving (Data, Eq, Show) + +instance Outputable SpliceDecoration where + ppr x = text $ show x + + +isTypedSplice :: HsSplice id -> Bool +isTypedSplice (HsTypedSplice {}) = True +isTypedSplice _ = False -- Quasi-quotes are untyped splices + +-- | Finalizers produced by a splice with +-- 'Language.Haskell.TH.Syntax.addModFinalizer' +-- +-- See Note [Delaying modFinalizers in untyped splices] in RnSplice. For how +-- this is used. +-- +newtype ThModFinalizers = ThModFinalizers [ForeignRef (TH.Q ())] + +-- A Data instance which ignores the argument of 'ThModFinalizers'. +instance Data ThModFinalizers where + gunfold _ z _ = z $ ThModFinalizers [] + toConstr a = mkConstr (dataTypeOf a) "ThModFinalizers" [] Data.Prefix + dataTypeOf a = mkDataType "HsExpr.ThModFinalizers" [toConstr a] + +-- See Note [Running typed splices in the zonker] +-- These are the arguments that are passed to `TcSplice.runTopSplice` +data DelayedSplice = + DelayedSplice + TcLclEnv -- The local environment to run the splice in + (LHsExpr GhcRn) -- The original renamed expression + TcType -- The result type of running the splice, unzonked + (LHsExpr GhcTcId) -- The typechecked expression to run and splice in the result + +-- A Data instance which ignores the argument of 'DelayedSplice'. +instance Data DelayedSplice where + gunfold _ _ _ = panic "DelayedSplice" + toConstr a = mkConstr (dataTypeOf a) "DelayedSplice" [] Data.Prefix + dataTypeOf a = mkDataType "HsExpr.DelayedSplice" [toConstr a] + +-- | Haskell Spliced Thing +-- +-- Values that can result from running a splice. +data HsSplicedThing id + = HsSplicedExpr (HsExpr id) -- ^ Haskell Spliced Expression + | HsSplicedTy (HsType id) -- ^ Haskell Spliced Type + | HsSplicedPat (Pat id) -- ^ Haskell Spliced Pattern + + +-- See Note [Pending Splices] +type SplicePointName = Name + +-- | Pending Renamer Splice +data PendingRnSplice + = PendingRnSplice UntypedSpliceFlavour SplicePointName (LHsExpr GhcRn) + +data UntypedSpliceFlavour + = UntypedExpSplice + | UntypedPatSplice + | UntypedTypeSplice + | UntypedDeclSplice + deriving Data + +-- | Pending Type-checker Splice +data PendingTcSplice + = PendingTcSplice SplicePointName (LHsExpr GhcTc) + +{- +Note [Pending Splices] +~~~~~~~~~~~~~~~~~~~~~~ +When we rename an untyped bracket, we name and lift out all the nested +splices, so that when the typechecker hits the bracket, it can +typecheck those nested splices without having to walk over the untyped +bracket code. So for example + [| f $(g x) |] +looks like + + HsBracket (HsApp (HsVar "f") (HsSpliceE _ (g x))) + +which the renamer rewrites to + + HsRnBracketOut (HsApp (HsVar f) (HsSpliceE sn (g x))) + [PendingRnSplice UntypedExpSplice sn (g x)] + +* The 'sn' is the Name of the splice point, the SplicePointName + +* The PendingRnExpSplice gives the splice that splice-point name maps to; + and the typechecker can now conveniently find these sub-expressions + +* The other copy of the splice, in the second argument of HsSpliceE + in the renamed first arg of HsRnBracketOut + is used only for pretty printing + +There are four varieties of pending splices generated by the renamer, +distinguished by their UntypedSpliceFlavour + + * Pending expression splices (UntypedExpSplice), e.g., + [|$(f x) + 2|] + + UntypedExpSplice is also used for + * quasi-quotes, where the pending expression expands to + $(quoter "...blah...") + (see RnSplice.makePending, HsQuasiQuote case) + + * cross-stage lifting, where the pending expression expands to + $(lift x) + (see RnSplice.checkCrossStageLifting) + + * Pending pattern splices (UntypedPatSplice), e.g., + [| \$(f x) -> x |] + + * Pending type splices (UntypedTypeSplice), e.g., + [| f :: $(g x) |] + + * Pending declaration (UntypedDeclSplice), e.g., + [| let $(f x) in ... |] + +There is a fifth variety of pending splice, which is generated by the type +checker: + + * Pending *typed* expression splices, (PendingTcSplice), e.g., + [||1 + $$(f 2)||] + +It would be possible to eliminate HsRnBracketOut and use HsBracketOut for the +output of the renamer. However, when pretty printing the output of the renamer, +e.g., in a type error message, we *do not* want to print out the pending +splices. In contrast, when pretty printing the output of the type checker, we +*do* want to print the pending splices. So splitting them up seems to make +sense, although I hate to add another constructor to HsExpr. +-} + +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (HsSplicedThing p) where + ppr (HsSplicedExpr e) = ppr_expr e + ppr (HsSplicedTy t) = ppr t + ppr (HsSplicedPat p) = ppr p + +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsSplice p) where + ppr s = pprSplice s + +pprPendingSplice :: (OutputableBndrId (GhcPass p)) + => SplicePointName -> LHsExpr (GhcPass p) -> SDoc +pprPendingSplice n e = angleBrackets (ppr n <> comma <+> ppr e) + +pprSpliceDecl :: (OutputableBndrId (GhcPass p)) + => HsSplice (GhcPass p) -> SpliceExplicitFlag -> SDoc +pprSpliceDecl e@HsQuasiQuote{} _ = pprSplice e +pprSpliceDecl e ExplicitSplice = text "$(" <> ppr_splice_decl e <> text ")" +pprSpliceDecl e ImplicitSplice = ppr_splice_decl e + +ppr_splice_decl :: (OutputableBndrId (GhcPass p)) + => HsSplice (GhcPass p) -> SDoc +ppr_splice_decl (HsUntypedSplice _ _ n e) = ppr_splice empty n e empty +ppr_splice_decl e = pprSplice e + +pprSplice :: (OutputableBndrId (GhcPass p)) => HsSplice (GhcPass p) -> SDoc +pprSplice (HsTypedSplice _ HasParens n e) + = ppr_splice (text "$$(") n e (text ")") +pprSplice (HsTypedSplice _ HasDollar n e) + = ppr_splice (text "$$") n e empty +pprSplice (HsTypedSplice _ NoParens n e) + = ppr_splice empty n e empty +pprSplice (HsUntypedSplice _ HasParens n e) + = ppr_splice (text "$(") n e (text ")") +pprSplice (HsUntypedSplice _ HasDollar n e) + = ppr_splice (text "$") n e empty +pprSplice (HsUntypedSplice _ NoParens n e) + = ppr_splice empty n e empty +pprSplice (HsQuasiQuote _ n q _ s) = ppr_quasi n q s +pprSplice (HsSpliced _ _ thing) = ppr thing +pprSplice (HsSplicedT {}) = text "Unevaluated typed splice" +pprSplice (XSplice x) = ppr x + +ppr_quasi :: OutputableBndr p => p -> p -> FastString -> SDoc +ppr_quasi n quoter quote = whenPprDebug (brackets (ppr n)) <> + char '[' <> ppr quoter <> vbar <> + ppr quote <> text "|]" + +ppr_splice :: (OutputableBndrId (GhcPass p)) + => SDoc -> (IdP (GhcPass p)) -> LHsExpr (GhcPass p) -> SDoc -> SDoc +ppr_splice herald n e trail + = herald <> whenPprDebug (brackets (ppr n)) <> ppr e <> trail + +-- | Haskell Bracket +data HsBracket p + = ExpBr (XExpBr p) (LHsExpr p) -- [| expr |] + | PatBr (XPatBr p) (LPat p) -- [p| pat |] + | DecBrL (XDecBrL p) [LHsDecl p] -- [d| decls |]; result of parser + | DecBrG (XDecBrG p) (HsGroup p) -- [d| decls |]; result of renamer + | TypBr (XTypBr p) (LHsType p) -- [t| type |] + | VarBr (XVarBr p) Bool (IdP p) -- True: 'x, False: ''T + -- (The Bool flag is used only in pprHsBracket) + | TExpBr (XTExpBr p) (LHsExpr p) -- [|| expr ||] + | XBracket (XXBracket p) -- Note [Trees that Grow] extension point + +type instance XExpBr (GhcPass _) = NoExt +type instance XPatBr (GhcPass _) = NoExt +type instance XDecBrL (GhcPass _) = NoExt +type instance XDecBrG (GhcPass _) = NoExt +type instance XTypBr (GhcPass _) = NoExt +type instance XVarBr (GhcPass _) = NoExt +type instance XTExpBr (GhcPass _) = NoExt +type instance XXBracket (GhcPass _) = NoExt + +isTypedBracket :: HsBracket id -> Bool +isTypedBracket (TExpBr {}) = True +isTypedBracket _ = False + +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (HsBracket p) where + ppr = pprHsBracket + + +pprHsBracket :: (OutputableBndrId (GhcPass p)) => HsBracket (GhcPass p) -> SDoc +pprHsBracket (ExpBr _ e) = thBrackets empty (ppr e) +pprHsBracket (PatBr _ p) = thBrackets (char 'p') (ppr p) +pprHsBracket (DecBrG _ gp) = thBrackets (char 'd') (ppr gp) +pprHsBracket (DecBrL _ ds) = thBrackets (char 'd') (vcat (map ppr ds)) +pprHsBracket (TypBr _ t) = thBrackets (char 't') (ppr t) +pprHsBracket (VarBr _ True n) + = char '\'' <> pprPrefixOcc n +pprHsBracket (VarBr _ False n) + = text "''" <> pprPrefixOcc n +pprHsBracket (TExpBr _ e) = thTyBrackets (ppr e) +pprHsBracket (XBracket e) = ppr e + +thBrackets :: SDoc -> SDoc -> SDoc +thBrackets pp_kind pp_body = char '[' <> pp_kind <> vbar <+> + pp_body <+> text "|]" + +thTyBrackets :: SDoc -> SDoc +thTyBrackets pp_body = text "[||" <+> pp_body <+> ptext (sLit "||]") + +instance Outputable PendingRnSplice where + ppr (PendingRnSplice _ n e) = pprPendingSplice n e + +instance Outputable PendingTcSplice where + ppr (PendingTcSplice n e) = pprPendingSplice n e + +{- +************************************************************************ +* * +\subsection{Enumerations and list comprehensions} +* * +************************************************************************ +-} + +-- | Arithmetic Sequence Information +data ArithSeqInfo id + = From (LHsExpr id) + | FromThen (LHsExpr id) + (LHsExpr id) + | FromTo (LHsExpr id) + (LHsExpr id) + | FromThenTo (LHsExpr id) + (LHsExpr id) + (LHsExpr id) +-- AZ: Sould ArithSeqInfo have a TTG extension? + +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (ArithSeqInfo p) where + ppr (From e1) = hcat [ppr e1, pp_dotdot] + ppr (FromThen e1 e2) = hcat [ppr e1, comma, space, ppr e2, pp_dotdot] + ppr (FromTo e1 e3) = hcat [ppr e1, pp_dotdot, ppr e3] + ppr (FromThenTo e1 e2 e3) + = hcat [ppr e1, comma, space, ppr e2, pp_dotdot, ppr e3] + +pp_dotdot :: SDoc +pp_dotdot = text " .. " + +{- +************************************************************************ +* * +\subsection{HsMatchCtxt} +* * +************************************************************************ +-} + +-- | Haskell Match Context +-- +-- Context of a pattern match. This is more subtle than it would seem. See Note +-- [Varieties of pattern matches]. +data HsMatchContext id -- Not an extensible tag + = FunRhs { mc_fun :: Located id -- ^ function binder of @f@ + , mc_fixity :: LexicalFixity -- ^ fixing of @f@ + , mc_strictness :: SrcStrictness -- ^ was @f@ banged? + -- See Note [FunBind vs PatBind] + } + -- ^A pattern matching on an argument of a + -- function binding + | LambdaExpr -- ^Patterns of a lambda + | CaseAlt -- ^Patterns and guards on a case alternative + | IfAlt -- ^Guards of a multi-way if alternative + | ProcExpr -- ^Patterns of a proc + | PatBindRhs -- ^A pattern binding eg [y] <- e = e + | PatBindGuards -- ^Guards of pattern bindings, e.g., + -- (Just b) | Just _ <- x = e + -- | otherwise = e' + + | RecUpd -- ^Record update [used only in DsExpr to + -- tell matchWrapper what sort of + -- runtime error message to generate] + + | StmtCtxt (HsStmtContext id) -- ^Pattern of a do-stmt, list comprehension, + -- pattern guard, etc + + | ThPatSplice -- ^A Template Haskell pattern splice + | ThPatQuote -- ^A Template Haskell pattern quotation [p| (a,b) |] + | PatSyn -- ^A pattern synonym declaration + deriving Functor +deriving instance (Data id) => Data (HsMatchContext id) + +instance OutputableBndr id => Outputable (HsMatchContext id) where + ppr m@(FunRhs{}) = text "FunRhs" <+> ppr (mc_fun m) <+> ppr (mc_fixity m) + ppr LambdaExpr = text "LambdaExpr" + ppr CaseAlt = text "CaseAlt" + ppr IfAlt = text "IfAlt" + ppr ProcExpr = text "ProcExpr" + ppr PatBindRhs = text "PatBindRhs" + ppr PatBindGuards = text "PatBindGuards" + ppr RecUpd = text "RecUpd" + ppr (StmtCtxt _) = text "StmtCtxt _" + ppr ThPatSplice = text "ThPatSplice" + ppr ThPatQuote = text "ThPatQuote" + ppr PatSyn = text "PatSyn" + +isPatSynCtxt :: HsMatchContext id -> Bool +isPatSynCtxt ctxt = + case ctxt of + PatSyn -> True + _ -> False + +-- | Haskell Statement Context. It expects to be parameterised with one of +-- 'RdrName', 'Name' or 'Id' +data HsStmtContext id + = ListComp + | MonadComp + + | DoExpr -- ^do { ... } + | MDoExpr -- ^mdo { ... } ie recursive do-expression + | ArrowExpr -- ^do-notation in an arrow-command context + + | GhciStmtCtxt -- ^A command-line Stmt in GHCi pat <- rhs + | PatGuard (HsMatchContext id) -- ^Pattern guard for specified thing + | ParStmtCtxt (HsStmtContext id) -- ^A branch of a parallel stmt + | TransStmtCtxt (HsStmtContext id) -- ^A branch of a transform stmt + deriving Functor +deriving instance (Data id) => Data (HsStmtContext id) + +isComprehensionContext :: HsStmtContext id -> Bool +-- Uses comprehension syntax [ e | quals ] +isComprehensionContext ListComp = True +isComprehensionContext MonadComp = True +isComprehensionContext (ParStmtCtxt c) = isComprehensionContext c +isComprehensionContext (TransStmtCtxt c) = isComprehensionContext c +isComprehensionContext _ = False + +-- | Should pattern match failure in a 'HsStmtContext' be desugared using +-- 'MonadFail'? +isMonadFailStmtContext :: HsStmtContext id -> Bool +isMonadFailStmtContext MonadComp = True +isMonadFailStmtContext DoExpr = True +isMonadFailStmtContext MDoExpr = True +isMonadFailStmtContext GhciStmtCtxt = True +isMonadFailStmtContext (ParStmtCtxt ctxt) = isMonadFailStmtContext ctxt +isMonadFailStmtContext (TransStmtCtxt ctxt) = isMonadFailStmtContext ctxt +isMonadFailStmtContext _ = False -- ListComp, PatGuard, ArrowExpr + +isMonadCompContext :: HsStmtContext id -> Bool +isMonadCompContext MonadComp = True +isMonadCompContext _ = False + +matchSeparator :: HsMatchContext id -> SDoc +matchSeparator (FunRhs {}) = text "=" +matchSeparator CaseAlt = text "->" +matchSeparator IfAlt = text "->" +matchSeparator LambdaExpr = text "->" +matchSeparator ProcExpr = text "->" +matchSeparator PatBindRhs = text "=" +matchSeparator PatBindGuards = text "=" +matchSeparator (StmtCtxt _) = text "<-" +matchSeparator RecUpd = text "=" -- This can be printed by the pattern + -- match checker trace +matchSeparator ThPatSplice = panic "unused" +matchSeparator ThPatQuote = panic "unused" +matchSeparator PatSyn = panic "unused" + +pprMatchContext :: (Outputable (NameOrRdrName id),Outputable id) + => HsMatchContext id -> SDoc +pprMatchContext ctxt + | want_an ctxt = text "an" <+> pprMatchContextNoun ctxt + | otherwise = text "a" <+> pprMatchContextNoun ctxt + where + want_an (FunRhs {}) = True -- Use "an" in front + want_an ProcExpr = True + want_an _ = False + +pprMatchContextNoun :: (Outputable (NameOrRdrName id),Outputable id) + => HsMatchContext id -> SDoc +pprMatchContextNoun (FunRhs {mc_fun=L _ fun}) + = text "equation for" + <+> quotes (ppr fun) +pprMatchContextNoun CaseAlt = text "case alternative" +pprMatchContextNoun IfAlt = text "multi-way if alternative" +pprMatchContextNoun RecUpd = text "record-update construct" +pprMatchContextNoun ThPatSplice = text "Template Haskell pattern splice" +pprMatchContextNoun ThPatQuote = text "Template Haskell pattern quotation" +pprMatchContextNoun PatBindRhs = text "pattern binding" +pprMatchContextNoun PatBindGuards = text "pattern binding guards" +pprMatchContextNoun LambdaExpr = text "lambda abstraction" +pprMatchContextNoun ProcExpr = text "arrow abstraction" +pprMatchContextNoun (StmtCtxt ctxt) = text "pattern binding in" + $$ pprAStmtContext ctxt +pprMatchContextNoun PatSyn = text "pattern synonym declaration" + +----------------- +pprAStmtContext, pprStmtContext :: (Outputable id, + Outputable (NameOrRdrName id)) + => HsStmtContext id -> SDoc +pprAStmtContext ctxt = article <+> pprStmtContext ctxt + where + pp_an = text "an" + pp_a = text "a" + article = case ctxt of + MDoExpr -> pp_an + GhciStmtCtxt -> pp_an + _ -> pp_a + + +----------------- +pprStmtContext GhciStmtCtxt = text "interactive GHCi command" +pprStmtContext DoExpr = text "'do' block" +pprStmtContext MDoExpr = text "'mdo' block" +pprStmtContext ArrowExpr = text "'do' block in an arrow command" +pprStmtContext ListComp = text "list comprehension" +pprStmtContext MonadComp = text "monad comprehension" +pprStmtContext (PatGuard ctxt) = text "pattern guard for" $$ pprMatchContext ctxt + +-- Drop the inner contexts when reporting errors, else we get +-- Unexpected transform statement +-- in a transformed branch of +-- transformed branch of +-- transformed branch of monad comprehension +pprStmtContext (ParStmtCtxt c) = + ifPprDebug (sep [text "parallel branch of", pprAStmtContext c]) + (pprStmtContext c) +pprStmtContext (TransStmtCtxt c) = + ifPprDebug (sep [text "transformed branch of", pprAStmtContext c]) + (pprStmtContext c) + +instance (Outputable p, Outputable (NameOrRdrName p)) + => Outputable (HsStmtContext p) where + ppr = pprStmtContext + +-- Used to generate the string for a *runtime* error message +matchContextErrString :: Outputable id + => HsMatchContext id -> SDoc +matchContextErrString (FunRhs{mc_fun=L _ fun}) = text "function" <+> ppr fun +matchContextErrString CaseAlt = text "case" +matchContextErrString IfAlt = text "multi-way if" +matchContextErrString PatBindRhs = text "pattern binding" +matchContextErrString PatBindGuards = text "pattern binding guards" +matchContextErrString RecUpd = text "record update" +matchContextErrString LambdaExpr = text "lambda" +matchContextErrString ProcExpr = text "proc" +matchContextErrString ThPatSplice = panic "matchContextErrString" -- Not used at runtime +matchContextErrString ThPatQuote = panic "matchContextErrString" -- Not used at runtime +matchContextErrString PatSyn = panic "matchContextErrString" -- Not used at runtime +matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c) +matchContextErrString (StmtCtxt (TransStmtCtxt c)) = matchContextErrString (StmtCtxt c) +matchContextErrString (StmtCtxt (PatGuard _)) = text "pattern guard" +matchContextErrString (StmtCtxt GhciStmtCtxt) = text "interactive GHCi command" +matchContextErrString (StmtCtxt DoExpr) = text "'do' block" +matchContextErrString (StmtCtxt ArrowExpr) = text "'do' block" +matchContextErrString (StmtCtxt MDoExpr) = text "'mdo' block" +matchContextErrString (StmtCtxt ListComp) = text "list comprehension" +matchContextErrString (StmtCtxt MonadComp) = text "monad comprehension" + +pprMatchInCtxt :: (OutputableBndrId (GhcPass idR), + -- TODO:AZ these constraints do not make sense + Outputable (NameOrRdrName (NameOrRdrName (IdP (GhcPass idR)))), + Outputable body) + => Match (GhcPass idR) body -> SDoc +pprMatchInCtxt match = hang (text "In" <+> pprMatchContext (m_ctxt match) + <> colon) + 4 (pprMatch match) + +pprStmtInCtxt :: (OutputableBndrId (GhcPass idL), + OutputableBndrId (GhcPass idR), + Outputable body) + => HsStmtContext (IdP (GhcPass idL)) + -> StmtLR (GhcPass idL) (GhcPass idR) body + -> SDoc +pprStmtInCtxt ctxt (LastStmt _ e _ _) + | isComprehensionContext ctxt -- For [ e | .. ], do not mutter about "stmts" + = hang (text "In the expression:") 2 (ppr e) + +pprStmtInCtxt ctxt stmt + = hang (text "In a stmt of" <+> pprAStmtContext ctxt <> colon) + 2 (ppr_stmt stmt) + where + -- For Group and Transform Stmts, don't print the nested stmts! + ppr_stmt (TransStmt { trS_by = by, trS_using = using + , trS_form = form }) = pprTransStmt by using form + ppr_stmt stmt = pprStmt stmt diff --git a/compiler/hsSyn/HsExpr.hs-boot b/compiler/hsSyn/HsExpr.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/hsSyn/HsExpr.hs-boot @@ -0,0 +1,51 @@ +{-# LANGUAGE CPP, KindSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] + -- in module PlaceHolder +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE TypeFamilies #-} + +module HsExpr where + +import SrcLoc ( Located ) +import Outputable ( SDoc, Outputable ) +import {-# SOURCE #-} HsPat ( LPat ) +import BasicTypes ( SpliceExplicitFlag(..)) +import HsExtension ( OutputableBndrId, GhcPass ) + +type role HsExpr nominal +type role HsCmd nominal +type role MatchGroup nominal nominal +type role GRHSs nominal nominal +type role HsSplice nominal +type role SyntaxExpr nominal +data HsExpr (i :: *) +data HsCmd (i :: *) +data HsSplice (i :: *) +data MatchGroup (a :: *) (body :: *) +data GRHSs (a :: *) (body :: *) +data SyntaxExpr (i :: *) + +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsExpr p) +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsCmd p) + +type LHsExpr a = Located (HsExpr a) + +pprLExpr :: (OutputableBndrId (GhcPass p)) => LHsExpr (GhcPass p) -> SDoc + +pprExpr :: (OutputableBndrId (GhcPass p)) => HsExpr (GhcPass p) -> SDoc + +pprSplice :: (OutputableBndrId (GhcPass p)) => HsSplice (GhcPass p) -> SDoc + +pprSpliceDecl :: (OutputableBndrId (GhcPass p)) + => HsSplice (GhcPass p) -> SpliceExplicitFlag -> SDoc + +pprPatBind :: forall bndr p body. (OutputableBndrId (GhcPass bndr), + OutputableBndrId (GhcPass p), + Outputable body) + => LPat (GhcPass bndr) -> GRHSs (GhcPass p) body -> SDoc + +pprFunBind :: (OutputableBndrId (GhcPass idR), Outputable body) + => MatchGroup (GhcPass idR) body -> SDoc diff --git a/compiler/hsSyn/HsExtension.hs b/compiler/hsSyn/HsExtension.hs new file mode 100644 --- /dev/null +++ b/compiler/hsSyn/HsExtension.hs @@ -0,0 +1,1111 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] + -- in module PlaceHolder + +module HsExtension where + +-- This module captures the type families to precisely identify the extension +-- points for HsSyn + +import GhcPrelude + +import Data.Data hiding ( Fixity ) +import PlaceHolder +import Name +import RdrName +import Var +import Outputable +import SrcLoc (Located) + +import Data.Kind + +{- +Note [Trees that grow] +~~~~~~~~~~~~~~~~~~~~~~ + +See https://gitlab.haskell.org/ghc/ghc/wikis/implementing-trees-that-grow + +The hsSyn AST is reused across multiple compiler passes. We also have the +Template Haskell AST, and the haskell-src-exts one (outside of GHC) + +Supporting multiple passes means the AST has various warts on it to cope with +the specifics for the phases, such as the 'ValBindsOut', 'ConPatOut', +'SigPatOut' etc. + +The growable AST will allow each of these variants to be captured explicitly, +such that they only exist in the given compiler pass AST, as selected by the +type parameter to the AST. + +In addition it will allow tool writers to define their own extensions to capture +additional information for the tool, in a natural way. + +A further goal is to provide a means to harmonise the Template Haskell and +haskell-src-exts ASTs as well. + +-} + +-- | used as place holder in TTG values +data NoExt = NoExt + deriving (Data,Eq,Ord) + +instance Outputable NoExt where + ppr _ = text "NoExt" + +-- | Used when constructing a term with an unused extension point. +noExt :: NoExt +noExt = NoExt + +-- | Used as a data type index for the hsSyn AST +data GhcPass (c :: Pass) +deriving instance Eq (GhcPass c) +deriving instance Typeable c => Data (GhcPass c) + +data Pass = Parsed | Renamed | Typechecked + deriving (Data) + +-- Type synonyms as a shorthand for tagging +type GhcPs = GhcPass 'Parsed -- Old 'RdrName' type param +type GhcRn = GhcPass 'Renamed -- Old 'Name' type param +type GhcTc = GhcPass 'Typechecked -- Old 'Id' type para, +type GhcTcId = GhcTc -- Old 'TcId' type param + +-- | Maps the "normal" id type for a given pass +type family IdP p +type instance IdP GhcPs = RdrName +type instance IdP GhcRn = Name +type instance IdP GhcTc = Id + +type LIdP p = Located (IdP p) + +-- | Marks that a field uses the GhcRn variant even when the pass +-- parameter is GhcTc. Useful for storing HsTypes in HsExprs, say, because +-- HsType GhcTc should never occur. +type family NoGhcTc (p :: Type) where + -- this way, GHC can figure out that the result is a GhcPass + NoGhcTc (GhcPass pass) = GhcPass (NoGhcTcPass pass) + NoGhcTc other = other + +type family NoGhcTcPass (p :: Pass) :: Pass where + NoGhcTcPass 'Typechecked = 'Renamed + NoGhcTcPass other = other + +-- ===================================================================== +-- Type families for the HsBinds extension points + +-- HsLocalBindsLR type families +type family XHsValBinds x x' +type family XHsIPBinds x x' +type family XEmptyLocalBinds x x' +type family XXHsLocalBindsLR x x' + +type ForallXHsLocalBindsLR (c :: * -> Constraint) (x :: *) (x' :: *) = + ( c (XHsValBinds x x') + , c (XHsIPBinds x x') + , c (XEmptyLocalBinds x x') + , c (XXHsLocalBindsLR x x') + ) + +-- ValBindsLR type families +type family XValBinds x x' +type family XXValBindsLR x x' + +type ForallXValBindsLR (c :: * -> Constraint) (x :: *) (x' :: *) = + ( c (XValBinds x x') + , c (XXValBindsLR x x') + ) + + +-- HsBindsLR type families +type family XFunBind x x' +type family XPatBind x x' +type family XVarBind x x' +type family XAbsBinds x x' +type family XPatSynBind x x' +type family XXHsBindsLR x x' + +type ForallXHsBindsLR (c :: * -> Constraint) (x :: *) (x' :: *) = + ( c (XFunBind x x') + , c (XPatBind x x') + , c (XVarBind x x') + , c (XAbsBinds x x') + , c (XPatSynBind x x') + , c (XXHsBindsLR x x') + ) + +-- ABExport type families +type family XABE x +type family XXABExport x + +type ForallXABExport (c :: * -> Constraint) (x :: *) = + ( c (XABE x) + , c (XXABExport x) + ) + +-- PatSynBind type families +type family XPSB x x' +type family XXPatSynBind x x' + +type ForallXPatSynBind (c :: * -> Constraint) (x :: *) (x' :: *) = + ( c (XPSB x x') + , c (XXPatSynBind x x') + ) + +-- HsIPBinds type families +type family XIPBinds x +type family XXHsIPBinds x + +type ForallXHsIPBinds (c :: * -> Constraint) (x :: *) = + ( c (XIPBinds x) + , c (XXHsIPBinds x) + ) + +-- IPBind type families +type family XCIPBind x +type family XXIPBind x + +type ForallXIPBind (c :: * -> Constraint) (x :: *) = + ( c (XCIPBind x) + , c (XXIPBind x) + ) + +-- Sig type families +type family XTypeSig x +type family XPatSynSig x +type family XClassOpSig x +type family XIdSig x +type family XFixSig x +type family XInlineSig x +type family XSpecSig x +type family XSpecInstSig x +type family XMinimalSig x +type family XSCCFunSig x +type family XCompleteMatchSig x +type family XXSig x + +type ForallXSig (c :: * -> Constraint) (x :: *) = + ( c (XTypeSig x) + , c (XPatSynSig x) + , c (XClassOpSig x) + , c (XIdSig x) + , c (XFixSig x) + , c (XInlineSig x) + , c (XSpecSig x) + , c (XSpecInstSig x) + , c (XMinimalSig x) + , c (XSCCFunSig x) + , c (XCompleteMatchSig x) + , c (XXSig x) + ) + +-- FixitySig type families +type family XFixitySig x +type family XXFixitySig x + +type ForallXFixitySig (c :: * -> Constraint) (x :: *) = + ( c (XFixitySig x) + , c (XXFixitySig x) + ) + +-- ===================================================================== +-- Type families for the HsDecls extension points + +-- HsDecl type families +type family XTyClD x +type family XInstD x +type family XDerivD x +type family XValD x +type family XSigD x +type family XDefD x +type family XForD x +type family XWarningD x +type family XAnnD x +type family XRuleD x +type family XSpliceD x +type family XDocD x +type family XRoleAnnotD x +type family XXHsDecl x + +type ForallXHsDecl (c :: * -> Constraint) (x :: *) = + ( c (XTyClD x) + , c (XInstD x) + , c (XDerivD x) + , c (XValD x) + , c (XSigD x) + , c (XDefD x) + , c (XForD x) + , c (XWarningD x) + , c (XAnnD x) + , c (XRuleD x) + , c (XSpliceD x) + , c (XDocD x) + , c (XRoleAnnotD x) + , c (XXHsDecl x) + ) + +-- ------------------------------------- +-- HsGroup type families +type family XCHsGroup x +type family XXHsGroup x + +type ForallXHsGroup (c :: * -> Constraint) (x :: *) = + ( c (XCHsGroup x) + , c (XXHsGroup x) + ) + +-- ------------------------------------- +-- SpliceDecl type families +type family XSpliceDecl x +type family XXSpliceDecl x + +type ForallXSpliceDecl (c :: * -> Constraint) (x :: *) = + ( c (XSpliceDecl x) + , c (XXSpliceDecl x) + ) + +-- ------------------------------------- +-- TyClDecl type families +type family XFamDecl x +type family XSynDecl x +type family XDataDecl x +type family XClassDecl x +type family XXTyClDecl x + +type ForallXTyClDecl (c :: * -> Constraint) (x :: *) = + ( c (XFamDecl x) + , c (XSynDecl x) + , c (XDataDecl x) + , c (XClassDecl x) + , c (XXTyClDecl x) + ) + +-- ------------------------------------- +-- TyClGroup type families +type family XCTyClGroup x +type family XXTyClGroup x + +type ForallXTyClGroup (c :: * -> Constraint) (x :: *) = + ( c (XCTyClGroup x) + , c (XXTyClGroup x) + ) + +-- ------------------------------------- +-- FamilyResultSig type families +type family XNoSig x +type family XCKindSig x -- Clashes with XKindSig above +type family XTyVarSig x +type family XXFamilyResultSig x + +type ForallXFamilyResultSig (c :: * -> Constraint) (x :: *) = + ( c (XNoSig x) + , c (XCKindSig x) + , c (XTyVarSig x) + , c (XXFamilyResultSig x) + ) + +-- ------------------------------------- +-- FamilyDecl type families +type family XCFamilyDecl x +type family XXFamilyDecl x + +type ForallXFamilyDecl (c :: * -> Constraint) (x :: *) = + ( c (XCFamilyDecl x) + , c (XXFamilyDecl x) + ) + +-- ------------------------------------- +-- HsDataDefn type families +type family XCHsDataDefn x +type family XXHsDataDefn x + +type ForallXHsDataDefn (c :: * -> Constraint) (x :: *) = + ( c (XCHsDataDefn x) + , c (XXHsDataDefn x) + ) + +-- ------------------------------------- +-- HsDerivingClause type families +type family XCHsDerivingClause x +type family XXHsDerivingClause x + +type ForallXHsDerivingClause (c :: * -> Constraint) (x :: *) = + ( c (XCHsDerivingClause x) + , c (XXHsDerivingClause x) + ) + +-- ------------------------------------- +-- ConDecl type families +type family XConDeclGADT x +type family XConDeclH98 x +type family XXConDecl x + +type ForallXConDecl (c :: * -> Constraint) (x :: *) = + ( c (XConDeclGADT x) + , c (XConDeclH98 x) + , c (XXConDecl x) + ) + +-- ------------------------------------- +-- FamEqn type families +type family XCFamEqn x p r +type family XXFamEqn x p r + +type ForallXFamEqn (c :: * -> Constraint) (x :: *) (p :: *) (r :: *) = + ( c (XCFamEqn x p r) + , c (XXFamEqn x p r) + ) + +-- ------------------------------------- +-- ClsInstDecl type families +type family XCClsInstDecl x +type family XXClsInstDecl x + +type ForallXClsInstDecl (c :: * -> Constraint) (x :: *) = + ( c (XCClsInstDecl x) + , c (XXClsInstDecl x) + ) + +-- ------------------------------------- +-- ClsInstDecl type families +type family XClsInstD x +type family XDataFamInstD x +type family XTyFamInstD x +type family XXInstDecl x + +type ForallXInstDecl (c :: * -> Constraint) (x :: *) = + ( c (XClsInstD x) + , c (XDataFamInstD x) + , c (XTyFamInstD x) + , c (XXInstDecl x) + ) + +-- ------------------------------------- +-- DerivDecl type families +type family XCDerivDecl x +type family XXDerivDecl x + +type ForallXDerivDecl (c :: * -> Constraint) (x :: *) = + ( c (XCDerivDecl x) + , c (XXDerivDecl x) + ) + +-- ------------------------------------- +-- DerivStrategy type family +type family XViaStrategy x + +-- ------------------------------------- +-- DefaultDecl type families +type family XCDefaultDecl x +type family XXDefaultDecl x + +type ForallXDefaultDecl (c :: * -> Constraint) (x :: *) = + ( c (XCDefaultDecl x) + , c (XXDefaultDecl x) + ) + +-- ------------------------------------- +-- DefaultDecl type families +type family XForeignImport x +type family XForeignExport x +type family XXForeignDecl x + +type ForallXForeignDecl (c :: * -> Constraint) (x :: *) = + ( c (XForeignImport x) + , c (XForeignExport x) + , c (XXForeignDecl x) + ) + +-- ------------------------------------- +-- RuleDecls type families +type family XCRuleDecls x +type family XXRuleDecls x + +type ForallXRuleDecls (c :: * -> Constraint) (x :: *) = + ( c (XCRuleDecls x) + , c (XXRuleDecls x) + ) + + +-- ------------------------------------- +-- RuleDecl type families +type family XHsRule x +type family XXRuleDecl x + +type ForallXRuleDecl (c :: * -> Constraint) (x :: *) = + ( c (XHsRule x) + , c (XXRuleDecl x) + ) + +-- ------------------------------------- +-- RuleBndr type families +type family XCRuleBndr x +type family XRuleBndrSig x +type family XXRuleBndr x + +type ForallXRuleBndr (c :: * -> Constraint) (x :: *) = + ( c (XCRuleBndr x) + , c (XRuleBndrSig x) + , c (XXRuleBndr x) + ) + +-- ------------------------------------- +-- WarnDecls type families +type family XWarnings x +type family XXWarnDecls x + +type ForallXWarnDecls (c :: * -> Constraint) (x :: *) = + ( c (XWarnings x) + , c (XXWarnDecls x) + ) + +-- ------------------------------------- +-- AnnDecl type families +type family XWarning x +type family XXWarnDecl x + +type ForallXWarnDecl (c :: * -> Constraint) (x :: *) = + ( c (XWarning x) + , c (XXWarnDecl x) + ) + +-- ------------------------------------- +-- AnnDecl type families +type family XHsAnnotation x +type family XXAnnDecl x + +type ForallXAnnDecl (c :: * -> Constraint) (x :: *) = + ( c (XHsAnnotation x) + , c (XXAnnDecl x) + ) + +-- ------------------------------------- +-- RoleAnnotDecl type families +type family XCRoleAnnotDecl x +type family XXRoleAnnotDecl x + +type ForallXRoleAnnotDecl (c :: * -> Constraint) (x :: *) = + ( c (XCRoleAnnotDecl x) + , c (XXRoleAnnotDecl x) + ) + +-- ===================================================================== +-- Type families for the HsExpr extension points + +type family XVar x +type family XUnboundVar x +type family XConLikeOut x +type family XRecFld x +type family XOverLabel x +type family XIPVar x +type family XOverLitE x +type family XLitE x +type family XLam x +type family XLamCase x +type family XApp x +type family XAppTypeE x +type family XOpApp x +type family XNegApp x +type family XPar x +type family XSectionL x +type family XSectionR x +type family XExplicitTuple x +type family XExplicitSum x +type family XCase x +type family XIf x +type family XMultiIf x +type family XLet x +type family XDo x +type family XExplicitList x +type family XRecordCon x +type family XRecordUpd x +type family XExprWithTySig x +type family XArithSeq x +type family XSCC x +type family XCoreAnn x +type family XBracket x +type family XRnBracketOut x +type family XTcBracketOut x +type family XSpliceE x +type family XProc x +type family XStatic x +type family XTick x +type family XBinTick x +type family XTickPragma x +type family XEWildPat x +type family XEAsPat x +type family XEViewPat x +type family XELazyPat x +type family XWrap x +type family XXExpr x + +type ForallXExpr (c :: * -> Constraint) (x :: *) = + ( c (XVar x) + , c (XUnboundVar x) + , c (XConLikeOut x) + , c (XRecFld x) + , c (XOverLabel x) + , c (XIPVar x) + , c (XOverLitE x) + , c (XLitE x) + , c (XLam x) + , c (XLamCase x) + , c (XApp x) + , c (XAppTypeE x) + , c (XOpApp x) + , c (XNegApp x) + , c (XPar x) + , c (XSectionL x) + , c (XSectionR x) + , c (XExplicitTuple x) + , c (XExplicitSum x) + , c (XCase x) + , c (XIf x) + , c (XMultiIf x) + , c (XLet x) + , c (XDo x) + , c (XExplicitList x) + , c (XRecordCon x) + , c (XRecordUpd x) + , c (XExprWithTySig x) + , c (XArithSeq x) + , c (XSCC x) + , c (XCoreAnn x) + , c (XBracket x) + , c (XRnBracketOut x) + , c (XTcBracketOut x) + , c (XSpliceE x) + , c (XProc x) + , c (XStatic x) + , c (XTick x) + , c (XBinTick x) + , c (XTickPragma x) + , c (XEWildPat x) + , c (XEAsPat x) + , c (XEViewPat x) + , c (XELazyPat x) + , c (XWrap x) + , c (XXExpr x) + ) +-- --------------------------------------------------------------------- + +type family XUnambiguous x +type family XAmbiguous x +type family XXAmbiguousFieldOcc x + +type ForallXAmbiguousFieldOcc (c :: * -> Constraint) (x :: *) = + ( c (XUnambiguous x) + , c (XAmbiguous x) + , c (XXAmbiguousFieldOcc x) + ) + +-- ---------------------------------------------------------------------- + +type family XPresent x +type family XMissing x +type family XXTupArg x + +type ForallXTupArg (c :: * -> Constraint) (x :: *) = + ( c (XPresent x) + , c (XMissing x) + , c (XXTupArg x) + ) + +-- --------------------------------------------------------------------- + +type family XTypedSplice x +type family XUntypedSplice x +type family XQuasiQuote x +type family XSpliced x +type family XXSplice x + +type ForallXSplice (c :: * -> Constraint) (x :: *) = + ( c (XTypedSplice x) + , c (XUntypedSplice x) + , c (XQuasiQuote x) + , c (XSpliced x) + , c (XXSplice x) + ) + +-- --------------------------------------------------------------------- + +type family XExpBr x +type family XPatBr x +type family XDecBrL x +type family XDecBrG x +type family XTypBr x +type family XVarBr x +type family XTExpBr x +type family XXBracket x + +type ForallXBracket (c :: * -> Constraint) (x :: *) = + ( c (XExpBr x) + , c (XPatBr x) + , c (XDecBrL x) + , c (XDecBrG x) + , c (XTypBr x) + , c (XVarBr x) + , c (XTExpBr x) + , c (XXBracket x) + ) + +-- --------------------------------------------------------------------- + +type family XCmdTop x +type family XXCmdTop x + +type ForallXCmdTop (c :: * -> Constraint) (x :: *) = + ( c (XCmdTop x) + , c (XXCmdTop x) + ) + +-- ------------------------------------- + +type family XMG x b +type family XXMatchGroup x b + +type ForallXMatchGroup (c :: * -> Constraint) (x :: *) (b :: *) = + ( c (XMG x b) + , c (XXMatchGroup x b) + ) + +-- ------------------------------------- + +type family XCMatch x b +type family XXMatch x b + +type ForallXMatch (c :: * -> Constraint) (x :: *) (b :: *) = + ( c (XCMatch x b) + , c (XXMatch x b) + ) + +-- ------------------------------------- + +type family XCGRHSs x b +type family XXGRHSs x b + +type ForallXGRHSs (c :: * -> Constraint) (x :: *) (b :: *) = + ( c (XCGRHSs x b) + , c (XXGRHSs x b) + ) + +-- ------------------------------------- + +type family XCGRHS x b +type family XXGRHS x b + +type ForallXGRHS (c :: * -> Constraint) (x :: *) (b :: *) = + ( c (XCGRHS x b) + , c (XXGRHS x b) + ) + +-- ------------------------------------- + +type family XLastStmt x x' b +type family XBindStmt x x' b +type family XApplicativeStmt x x' b +type family XBodyStmt x x' b +type family XLetStmt x x' b +type family XParStmt x x' b +type family XTransStmt x x' b +type family XRecStmt x x' b +type family XXStmtLR x x' b + +type ForallXStmtLR (c :: * -> Constraint) (x :: *) (x' :: *) (b :: *) = + ( c (XLastStmt x x' b) + , c (XBindStmt x x' b) + , c (XApplicativeStmt x x' b) + , c (XBodyStmt x x' b) + , c (XLetStmt x x' b) + , c (XParStmt x x' b) + , c (XTransStmt x x' b) + , c (XRecStmt x x' b) + , c (XXStmtLR x x' b) + ) + +-- --------------------------------------------------------------------- + +type family XCmdArrApp x +type family XCmdArrForm x +type family XCmdApp x +type family XCmdLam x +type family XCmdPar x +type family XCmdCase x +type family XCmdIf x +type family XCmdLet x +type family XCmdDo x +type family XCmdWrap x +type family XXCmd x + +type ForallXCmd (c :: * -> Constraint) (x :: *) = + ( c (XCmdArrApp x) + , c (XCmdArrForm x) + , c (XCmdApp x) + , c (XCmdLam x) + , c (XCmdPar x) + , c (XCmdCase x) + , c (XCmdIf x) + , c (XCmdLet x) + , c (XCmdDo x) + , c (XCmdWrap x) + , c (XXCmd x) + ) + +-- --------------------------------------------------------------------- + +type family XParStmtBlock x x' +type family XXParStmtBlock x x' + +type ForallXParStmtBlock (c :: * -> Constraint) (x :: *) (x' :: *) = + ( c (XParStmtBlock x x') + , c (XXParStmtBlock x x') + ) + +-- --------------------------------------------------------------------- + +type family XApplicativeArgOne x +type family XApplicativeArgMany x +type family XXApplicativeArg x + +type ForallXApplicativeArg (c :: * -> Constraint) (x :: *) = + ( c (XApplicativeArgOne x) + , c (XApplicativeArgMany x) + , c (XXApplicativeArg x) + ) + +-- ===================================================================== +-- Type families for the HsImpExp extension points + +-- TODO + +-- ===================================================================== +-- Type families for the HsLit extension points + +-- We define a type family for each extension point. This is based on prepending +-- 'X' to the constructor name, for ease of reference. +type family XHsChar x +type family XHsCharPrim x +type family XHsString x +type family XHsStringPrim x +type family XHsInt x +type family XHsIntPrim x +type family XHsWordPrim x +type family XHsInt64Prim x +type family XHsWord64Prim x +type family XHsInteger x +type family XHsRat x +type family XHsFloatPrim x +type family XHsDoublePrim x +type family XXLit x + +-- | Helper to apply a constraint to all extension points. It has one +-- entry per extension point type family. +type ForallXHsLit (c :: * -> Constraint) (x :: *) = + ( c (XHsChar x) + , c (XHsCharPrim x) + , c (XHsDoublePrim x) + , c (XHsFloatPrim x) + , c (XHsInt x) + , c (XHsInt64Prim x) + , c (XHsIntPrim x) + , c (XHsInteger x) + , c (XHsRat x) + , c (XHsString x) + , c (XHsStringPrim x) + , c (XHsWord64Prim x) + , c (XHsWordPrim x) + , c (XXLit x) + ) + +type family XOverLit x +type family XXOverLit x + +type ForallXOverLit (c :: * -> Constraint) (x :: *) = + ( c (XOverLit x) + , c (XXOverLit x) + ) + +-- ===================================================================== +-- Type families for the HsPat extension points + +type family XWildPat x +type family XVarPat x +type family XLazyPat x +type family XAsPat x +type family XParPat x +type family XBangPat x +type family XListPat x +type family XTuplePat x +type family XSumPat x +type family XConPat x +type family XViewPat x +type family XSplicePat x +type family XLitPat x +type family XNPat x +type family XNPlusKPat x +type family XSigPat x +type family XCoPat x +type family XXPat x + + +type ForallXPat (c :: * -> Constraint) (x :: *) = + ( c (XWildPat x) + , c (XVarPat x) + , c (XLazyPat x) + , c (XAsPat x) + , c (XParPat x) + , c (XBangPat x) + , c (XListPat x) + , c (XTuplePat x) + , c (XSumPat x) + , c (XViewPat x) + , c (XSplicePat x) + , c (XLitPat x) + , c (XNPat x) + , c (XNPlusKPat x) + , c (XSigPat x) + , c (XCoPat x) + , c (XXPat x) + ) + +-- ===================================================================== +-- Type families for the HsTypes type families + +type family XHsQTvs x +type family XXLHsQTyVars x + +type ForallXLHsQTyVars (c :: * -> Constraint) (x :: *) = + ( c (XHsQTvs x) + , c (XXLHsQTyVars x) + ) + +-- ------------------------------------- + +type family XHsIB x b +type family XXHsImplicitBndrs x b + +type ForallXHsImplicitBndrs (c :: * -> Constraint) (x :: *) (b :: *) = + ( c (XHsIB x b) + , c (XXHsImplicitBndrs x b) + ) + +-- ------------------------------------- + +type family XHsWC x b +type family XXHsWildCardBndrs x b + +type ForallXHsWildCardBndrs(c :: * -> Constraint) (x :: *) (b :: *) = + ( c (XHsWC x b) + , c (XXHsWildCardBndrs x b) + ) + +-- ------------------------------------- + +type family XForAllTy x +type family XQualTy x +type family XTyVar x +type family XAppTy x +type family XAppKindTy x +type family XFunTy x +type family XListTy x +type family XTupleTy x +type family XSumTy x +type family XOpTy x +type family XParTy x +type family XIParamTy x +type family XStarTy x +type family XKindSig x +type family XSpliceTy x +type family XDocTy x +type family XBangTy x +type family XRecTy x +type family XExplicitListTy x +type family XExplicitTupleTy x +type family XTyLit x +type family XWildCardTy x +type family XXType x + +-- | Helper to apply a constraint to all extension points. It has one +-- entry per extension point type family. +type ForallXType (c :: * -> Constraint) (x :: *) = + ( c (XForAllTy x) + , c (XQualTy x) + , c (XTyVar x) + , c (XAppTy x) + , c (XAppKindTy x) + , c (XFunTy x) + , c (XListTy x) + , c (XTupleTy x) + , c (XSumTy x) + , c (XOpTy x) + , c (XParTy x) + , c (XIParamTy x) + , c (XStarTy x) + , c (XKindSig x) + , c (XSpliceTy x) + , c (XDocTy x) + , c (XBangTy x) + , c (XRecTy x) + , c (XExplicitListTy x) + , c (XExplicitTupleTy x) + , c (XTyLit x) + , c (XWildCardTy x) + , c (XXType x) + ) + +-- --------------------------------------------------------------------- + +type family XUserTyVar x +type family XKindedTyVar x +type family XXTyVarBndr x + +type ForallXTyVarBndr (c :: * -> Constraint) (x :: *) = + ( c (XUserTyVar x) + , c (XKindedTyVar x) + , c (XXTyVarBndr x) + ) + +-- --------------------------------------------------------------------- + +type family XConDeclField x +type family XXConDeclField x + +type ForallXConDeclField (c :: * -> Constraint) (x :: *) = + ( c (XConDeclField x) + , c (XXConDeclField x) + ) + +-- --------------------------------------------------------------------- + +type family XCFieldOcc x +type family XXFieldOcc x + +type ForallXFieldOcc (c :: * -> Constraint) (x :: *) = + ( c (XCFieldOcc x) + , c (XXFieldOcc x) + ) + + +-- ===================================================================== +-- Type families for the HsImpExp type families + +type family XCImportDecl x +type family XXImportDecl x + +type ForallXImportDecl (c :: * -> Constraint) (x :: *) = + ( c (XCImportDecl x) + , c (XXImportDecl x) + ) + +-- ------------------------------------- + +type family XIEVar x +type family XIEThingAbs x +type family XIEThingAll x +type family XIEThingWith x +type family XIEModuleContents x +type family XIEGroup x +type family XIEDoc x +type family XIEDocNamed x +type family XXIE x + +type ForallXIE (c :: * -> Constraint) (x :: *) = + ( c (XIEVar x) + , c (XIEThingAbs x) + , c (XIEThingAll x) + , c (XIEThingWith x) + , c (XIEModuleContents x) + , c (XIEGroup x) + , c (XIEDoc x) + , c (XIEDocNamed x) + , c (XXIE x) + ) + +-- ------------------------------------- + + +-- ===================================================================== +-- End of Type family definitions +-- ===================================================================== + +-- ---------------------------------------------------------------------- +-- | Conversion of annotations from one type index to another. This is required +-- where the AST is converted from one pass to another, and the extension values +-- need to be brought along if possible. So for example a 'SourceText' is +-- converted via 'id', but needs a type signature to keep the type checker +-- happy. +class Convertable a b | a -> b where + convert :: a -> b + +instance Convertable a a where + convert = id + +-- | A constraint capturing all the extension points that can be converted via +-- @instance Convertable a a@ +type ConvertIdX a b = + (XHsDoublePrim a ~ XHsDoublePrim b, + XHsFloatPrim a ~ XHsFloatPrim b, + XHsRat a ~ XHsRat b, + XHsInteger a ~ XHsInteger b, + XHsWord64Prim a ~ XHsWord64Prim b, + XHsInt64Prim a ~ XHsInt64Prim b, + XHsWordPrim a ~ XHsWordPrim b, + XHsIntPrim a ~ XHsIntPrim b, + XHsInt a ~ XHsInt b, + XHsStringPrim a ~ XHsStringPrim b, + XHsString a ~ XHsString b, + XHsCharPrim a ~ XHsCharPrim b, + XHsChar a ~ XHsChar b, + XXLit a ~ XXLit b) + +-- ---------------------------------------------------------------------- + +-- Note [OutputableX] +-- ~~~~~~~~~~~~~~~~~~ +-- +-- is required because the type family resolution +-- process cannot determine that all cases are handled for a `GhcPass p` +-- case where the cases are listed separately. +-- +-- So +-- +-- type instance XXHsIPBinds (GhcPass p) = NoExt +-- +-- will correctly deduce Outputable for (GhcPass p), but +-- +-- type instance XIPBinds GhcPs = NoExt +-- type instance XIPBinds GhcRn = NoExt +-- type instance XIPBinds GhcTc = TcEvBinds +-- +-- will not. + + +-- | Provide a summary constraint that gives all am Outputable constraint to +-- extension points needing one +type OutputableX p = -- See Note [OutputableX] + ( Outputable (XIPBinds p) + , Outputable (XViaStrategy p) + , Outputable (XViaStrategy GhcRn) + ) +-- TODO: Should OutputableX be included in OutputableBndrId? + +-- ---------------------------------------------------------------------- + +-- |Constraint type to bundle up the requirement for 'OutputableBndr' on both +-- the @id@ and the 'NameOrRdrName' type for it +type OutputableBndrId id = + ( OutputableBndr (NameOrRdrName (IdP id)) + , OutputableBndr (IdP id) + , OutputableBndr (NameOrRdrName (IdP (NoGhcTc id))) + , OutputableBndr (IdP (NoGhcTc id)) + , NoGhcTc id ~ NoGhcTc (NoGhcTc id) + , OutputableX id + , OutputableX (NoGhcTc id) + ) diff --git a/compiler/hsSyn/HsImpExp.hs b/compiler/hsSyn/HsImpExp.hs new file mode 100644 --- /dev/null +++ b/compiler/hsSyn/HsImpExp.hs @@ -0,0 +1,339 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +HsImpExp: Abstract syntax: imports, exports, interfaces +-} + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] + -- in module PlaceHolder + +module HsImpExp where + +import GhcPrelude + +import Module ( ModuleName ) +import HsDoc ( HsDocString ) +import OccName ( HasOccName(..), isTcOcc, isSymOcc ) +import BasicTypes ( SourceText(..), StringLiteral(..), pprWithSourceText ) +import FieldLabel ( FieldLbl(..) ) + +import Outputable +import FastString +import SrcLoc +import HsExtension + +import Data.Data + +{- +************************************************************************ +* * +\subsection{Import and export declaration lists} +* * +************************************************************************ + +One per \tr{import} declaration in a module. +-} + +-- | Located Import Declaration +type LImportDecl pass = Located (ImportDecl pass) + -- ^ When in a list this may have + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnSemi' + + -- For details on above see note [Api annotations] in ApiAnnotation + +-- | Import Declaration +-- +-- A single Haskell @import@ declaration. +data ImportDecl pass + = ImportDecl { + ideclExt :: XCImportDecl pass, + ideclSourceSrc :: SourceText, + -- Note [Pragma source text] in BasicTypes + ideclName :: Located ModuleName, -- ^ Module name. + ideclPkgQual :: Maybe StringLiteral, -- ^ Package qualifier. + ideclSource :: Bool, -- ^ True <=> {-\# SOURCE \#-} import + ideclSafe :: Bool, -- ^ True => safe import + ideclQualified :: Bool, -- ^ True => qualified + ideclImplicit :: Bool, -- ^ True => implicit import (of Prelude) + ideclAs :: Maybe (Located ModuleName), -- ^ as Module + ideclHiding :: Maybe (Bool, Located [LIE pass]) + -- ^ (True => hiding, names) + } + | XImportDecl (XXImportDecl pass) + -- ^ + -- 'ApiAnnotation.AnnKeywordId's + -- + -- - 'ApiAnnotation.AnnImport' + -- + -- - 'ApiAnnotation.AnnOpen', 'ApiAnnotation.AnnClose' for ideclSource + -- + -- - 'ApiAnnotation.AnnSafe','ApiAnnotation.AnnQualified', + -- 'ApiAnnotation.AnnPackageName','ApiAnnotation.AnnAs', + -- 'ApiAnnotation.AnnVal' + -- + -- - 'ApiAnnotation.AnnHiding','ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnClose' attached + -- to location in ideclHiding + + -- For details on above see note [Api annotations] in ApiAnnotation + +type instance XCImportDecl (GhcPass _) = NoExt +type instance XXImportDecl (GhcPass _) = NoExt + +simpleImportDecl :: ModuleName -> ImportDecl (GhcPass p) +simpleImportDecl mn = ImportDecl { + ideclExt = noExt, + ideclSourceSrc = NoSourceText, + ideclName = noLoc mn, + ideclPkgQual = Nothing, + ideclSource = False, + ideclSafe = False, + ideclImplicit = False, + ideclQualified = False, + ideclAs = Nothing, + ideclHiding = Nothing + } + +instance (p ~ GhcPass pass,OutputableBndrId p) + => Outputable (ImportDecl p) where + ppr (ImportDecl { ideclSourceSrc = mSrcText, ideclName = mod' + , ideclPkgQual = pkg + , ideclSource = from, ideclSafe = safe + , ideclQualified = qual, ideclImplicit = implicit + , ideclAs = as, ideclHiding = spec }) + = hang (hsep [text "import", ppr_imp from, pp_implicit implicit, pp_safe safe, + pp_qual qual, pp_pkg pkg, ppr mod', pp_as as]) + 4 (pp_spec spec) + where + pp_implicit False = empty + pp_implicit True = ptext (sLit ("(implicit)")) + + pp_pkg Nothing = empty + pp_pkg (Just (StringLiteral st p)) + = pprWithSourceText st (doubleQuotes (ftext p)) + + pp_qual False = empty + pp_qual True = text "qualified" + + pp_safe False = empty + pp_safe True = text "safe" + + pp_as Nothing = empty + pp_as (Just a) = text "as" <+> ppr a + + ppr_imp True = case mSrcText of + NoSourceText -> text "{-# SOURCE #-}" + SourceText src -> text src <+> text "#-}" + ppr_imp False = empty + + pp_spec Nothing = empty + pp_spec (Just (False, (L _ ies))) = ppr_ies ies + pp_spec (Just (True, (L _ ies))) = text "hiding" <+> ppr_ies ies + + ppr_ies [] = text "()" + ppr_ies ies = char '(' <+> interpp'SP ies <+> char ')' + ppr (XImportDecl x) = ppr x + +{- +************************************************************************ +* * +\subsection{Imported and exported entities} +* * +************************************************************************ +-} + +-- | A name in an import or export specification which may have adornments. Used +-- primarily for accurate pretty printing of ParsedSource, and API Annotation +-- placement. +data IEWrappedName name + = IEName (Located name) -- ^ no extra + | IEPattern (Located name) -- ^ pattern X + | IEType (Located name) -- ^ type (:+:) + deriving (Eq,Data) + +-- | Located name with possible adornment +-- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnType', +-- 'ApiAnnotation.AnnPattern' +type LIEWrappedName name = Located (IEWrappedName name) +-- For details on above see note [Api annotations] in ApiAnnotation + + +-- | Located Import or Export +type LIE pass = Located (IE pass) + -- ^ When in a list this may have + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' + + -- For details on above see note [Api annotations] in ApiAnnotation + +-- | Imported or exported entity. +data IE pass + = IEVar (XIEVar pass) (LIEWrappedName (IdP pass)) + -- ^ Imported or Exported Variable + + | IEThingAbs (XIEThingAbs pass) (LIEWrappedName (IdP pass)) + -- ^ Imported or exported Thing with Absent list + -- + -- The thing is a Class/Type (can't tell) + -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnPattern', + -- 'ApiAnnotation.AnnType','ApiAnnotation.AnnVal' + + -- For details on above see note [Api annotations] in ApiAnnotation + -- See Note [Located RdrNames] in HsExpr + | IEThingAll (XIEThingAll pass) (LIEWrappedName (IdP pass)) + -- ^ Imported or exported Thing with All imported or exported + -- + -- The thing is a Class/Type and the All refers to methods/constructors + -- + -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnDotdot','ApiAnnotation.AnnClose', + -- 'ApiAnnotation.AnnType' + + -- For details on above see note [Api annotations] in ApiAnnotation + -- See Note [Located RdrNames] in HsExpr + + | IEThingWith (XIEThingWith pass) + (LIEWrappedName (IdP pass)) + IEWildcard + [LIEWrappedName (IdP pass)] + [Located (FieldLbl (IdP pass))] + -- ^ Imported or exported Thing With given imported or exported + -- + -- The thing is a Class/Type and the imported or exported things are + -- methods/constructors and record fields; see Note [IEThingWith] + -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnClose', + -- 'ApiAnnotation.AnnComma', + -- 'ApiAnnotation.AnnType' + + -- For details on above see note [Api annotations] in ApiAnnotation + | IEModuleContents (XIEModuleContents pass) (Located ModuleName) + -- ^ Imported or exported module contents + -- + -- (Export Only) + -- + -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnModule' + + -- For details on above see note [Api annotations] in ApiAnnotation + | IEGroup (XIEGroup pass) Int HsDocString -- ^ Doc section heading + | IEDoc (XIEDoc pass) HsDocString -- ^ Some documentation + | IEDocNamed (XIEDocNamed pass) String -- ^ Reference to named doc + | XIE (XXIE pass) + +type instance XIEVar (GhcPass _) = NoExt +type instance XIEThingAbs (GhcPass _) = NoExt +type instance XIEThingAll (GhcPass _) = NoExt +type instance XIEThingWith (GhcPass _) = NoExt +type instance XIEModuleContents (GhcPass _) = NoExt +type instance XIEGroup (GhcPass _) = NoExt +type instance XIEDoc (GhcPass _) = NoExt +type instance XIEDocNamed (GhcPass _) = NoExt +type instance XXIE (GhcPass _) = NoExt + +-- | Imported or Exported Wildcard +data IEWildcard = NoIEWildcard | IEWildcard Int deriving (Eq, Data) + +{- +Note [IEThingWith] +~~~~~~~~~~~~~~~~~~ + +A definition like + + module M ( T(MkT, x) ) where + data T = MkT { x :: Int } + +gives rise to + + IEThingWith T [MkT] [FieldLabel "x" False x)] (without DuplicateRecordFields) + IEThingWith T [MkT] [FieldLabel "x" True $sel:x:MkT)] (with DuplicateRecordFields) + +See Note [Representing fields in AvailInfo] in Avail for more details. +-} + +ieName :: IE pass -> IdP pass +ieName (IEVar _ (L _ n)) = ieWrappedName n +ieName (IEThingAbs _ (L _ n)) = ieWrappedName n +ieName (IEThingWith _ (L _ n) _ _ _) = ieWrappedName n +ieName (IEThingAll _ (L _ n)) = ieWrappedName n +ieName _ = panic "ieName failed pattern match!" + +ieNames :: IE pass -> [IdP pass] +ieNames (IEVar _ (L _ n) ) = [ieWrappedName n] +ieNames (IEThingAbs _ (L _ n) ) = [ieWrappedName n] +ieNames (IEThingAll _ (L _ n) ) = [ieWrappedName n] +ieNames (IEThingWith _ (L _ n) _ ns _) = ieWrappedName n + : map (ieWrappedName . unLoc) ns +ieNames (IEModuleContents {}) = [] +ieNames (IEGroup {}) = [] +ieNames (IEDoc {}) = [] +ieNames (IEDocNamed {}) = [] +ieNames (XIE {}) = panic "ieNames" + +ieWrappedName :: IEWrappedName name -> name +ieWrappedName (IEName (L _ n)) = n +ieWrappedName (IEPattern (L _ n)) = n +ieWrappedName (IEType (L _ n)) = n + +lieWrappedName :: LIEWrappedName name -> name +lieWrappedName (L _ n) = ieWrappedName n + +ieLWrappedName :: LIEWrappedName name -> Located name +ieLWrappedName (L l n) = L l (ieWrappedName n) + +replaceWrappedName :: IEWrappedName name1 -> name2 -> IEWrappedName name2 +replaceWrappedName (IEName (L l _)) n = IEName (L l n) +replaceWrappedName (IEPattern (L l _)) n = IEPattern (L l n) +replaceWrappedName (IEType (L l _)) n = IEType (L l n) + +replaceLWrappedName :: LIEWrappedName name1 -> name2 -> LIEWrappedName name2 +replaceLWrappedName (L l n) n' = L l (replaceWrappedName n n') + +instance (p ~ GhcPass pass,OutputableBndrId p) => Outputable (IE p) where + ppr (IEVar _ var) = ppr (unLoc var) + ppr (IEThingAbs _ thing) = ppr (unLoc thing) + ppr (IEThingAll _ thing) = hcat [ppr (unLoc thing), text "(..)"] + ppr (IEThingWith _ thing wc withs flds) + = ppr (unLoc thing) <> parens (fsep (punctuate comma + (ppWiths ++ + map (ppr . flLabel . unLoc) flds))) + where + ppWiths = + case wc of + NoIEWildcard -> + map (ppr . unLoc) withs + IEWildcard pos -> + let (bs, as) = splitAt pos (map (ppr . unLoc) withs) + in bs ++ [text ".."] ++ as + ppr (IEModuleContents _ mod') + = text "module" <+> ppr mod' + ppr (IEGroup _ n _) = text ("") + ppr (IEDoc _ doc) = ppr doc + ppr (IEDocNamed _ string) = text ("") + ppr (XIE x) = ppr x + +instance (HasOccName name) => HasOccName (IEWrappedName name) where + occName w = occName (ieWrappedName w) + +instance (OutputableBndr name) => OutputableBndr (IEWrappedName name) where + pprBndr bs w = pprBndr bs (ieWrappedName w) + pprPrefixOcc w = pprPrefixOcc (ieWrappedName w) + pprInfixOcc w = pprInfixOcc (ieWrappedName w) + +instance (OutputableBndr name) => Outputable (IEWrappedName name) where + ppr (IEName n) = pprPrefixOcc (unLoc n) + ppr (IEPattern n) = text "pattern" <+> pprPrefixOcc (unLoc n) + ppr (IEType n) = text "type" <+> pprPrefixOcc (unLoc n) + +pprImpExp :: (HasOccName name, OutputableBndr name) => name -> SDoc +pprImpExp name = type_pref <+> pprPrefixOcc name + where + occ = occName name + type_pref | isTcOcc occ && isSymOcc occ = text "type" + | otherwise = empty diff --git a/compiler/hsSyn/HsInstances.hs b/compiler/hsSyn/HsInstances.hs new file mode 100644 --- /dev/null +++ b/compiler/hsSyn/HsInstances.hs @@ -0,0 +1,420 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module HsInstances where + +-- This module defines the Data instances for the hsSyn AST. + +-- It happens here to avoid massive constraint types on the AST with concomitant +-- slow GHC bootstrap times. + +-- UndecidableInstances ? + +import Data.Data hiding ( Fixity ) + +import GhcPrelude +import HsExtension +import HsBinds +import HsDecls +import HsExpr +import HsLit +import HsTypes +import HsPat +import HsImpExp + +-- --------------------------------------------------------------------- +-- Data derivations from HsSyn ----------------------------------------- + +-- --------------------------------------------------------------------- +-- Data derivations from HsBinds --------------------------------------- + +-- deriving instance (DataIdLR pL pR) => Data (HsLocalBindsLR pL pR) +deriving instance Data (HsLocalBindsLR GhcPs GhcPs) +deriving instance Data (HsLocalBindsLR GhcPs GhcRn) +deriving instance Data (HsLocalBindsLR GhcRn GhcRn) +deriving instance Data (HsLocalBindsLR GhcTc GhcTc) + +-- deriving instance (DataIdLR pL pR) => Data (HsValBindsLR pL pR) +deriving instance Data (HsValBindsLR GhcPs GhcPs) +deriving instance Data (HsValBindsLR GhcPs GhcRn) +deriving instance Data (HsValBindsLR GhcRn GhcRn) +deriving instance Data (HsValBindsLR GhcTc GhcTc) + +-- deriving instance (DataIdLR pL pL) => Data (NHsValBindsLR pL) +deriving instance Data (NHsValBindsLR GhcPs) +deriving instance Data (NHsValBindsLR GhcRn) +deriving instance Data (NHsValBindsLR GhcTc) + +-- deriving instance (DataIdLR pL pR) => Data (HsBindLR pL pR) +deriving instance Data (HsBindLR GhcPs GhcPs) +deriving instance Data (HsBindLR GhcPs GhcRn) +deriving instance Data (HsBindLR GhcRn GhcRn) +deriving instance Data (HsBindLR GhcTc GhcTc) + +-- deriving instance (DataId p) => Data (ABExport p) +deriving instance Data (ABExport GhcPs) +deriving instance Data (ABExport GhcRn) +deriving instance Data (ABExport GhcTc) + +-- deriving instance (DataIdLR pL pR) => Data (PatSynBind pL pR) +deriving instance Data (PatSynBind GhcPs GhcPs) +deriving instance Data (PatSynBind GhcPs GhcRn) +deriving instance Data (PatSynBind GhcRn GhcRn) +deriving instance Data (PatSynBind GhcTc GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsIPBinds p) +deriving instance Data (HsIPBinds GhcPs) +deriving instance Data (HsIPBinds GhcRn) +deriving instance Data (HsIPBinds GhcTc) + +-- deriving instance (DataIdLR p p) => Data (IPBind p) +deriving instance Data (IPBind GhcPs) +deriving instance Data (IPBind GhcRn) +deriving instance Data (IPBind GhcTc) + +-- deriving instance (DataIdLR p p) => Data (Sig p) +deriving instance Data (Sig GhcPs) +deriving instance Data (Sig GhcRn) +deriving instance Data (Sig GhcTc) + +-- deriving instance (DataId p) => Data (FixitySig p) +deriving instance Data (FixitySig GhcPs) +deriving instance Data (FixitySig GhcRn) +deriving instance Data (FixitySig GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsPatSynDir p) +deriving instance Data (HsPatSynDir GhcPs) +deriving instance Data (HsPatSynDir GhcRn) +deriving instance Data (HsPatSynDir GhcTc) + +-- --------------------------------------------------------------------- +-- Data derivations from HsDecls --------------------------------------- + +-- deriving instance (DataIdLR p p) => Data (HsDecl p) +deriving instance Data (HsDecl GhcPs) +deriving instance Data (HsDecl GhcRn) +deriving instance Data (HsDecl GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsGroup p) +deriving instance Data (HsGroup GhcPs) +deriving instance Data (HsGroup GhcRn) +deriving instance Data (HsGroup GhcTc) + +-- deriving instance (DataIdLR p p) => Data (SpliceDecl p) +deriving instance Data (SpliceDecl GhcPs) +deriving instance Data (SpliceDecl GhcRn) +deriving instance Data (SpliceDecl GhcTc) + +-- deriving instance (DataIdLR p p) => Data (TyClDecl p) +deriving instance Data (TyClDecl GhcPs) +deriving instance Data (TyClDecl GhcRn) +deriving instance Data (TyClDecl GhcTc) + +-- deriving instance (DataIdLR p p) => Data (TyClGroup p) +deriving instance Data (TyClGroup GhcPs) +deriving instance Data (TyClGroup GhcRn) +deriving instance Data (TyClGroup GhcTc) + +-- deriving instance (DataIdLR p p) => Data (FamilyResultSig p) +deriving instance Data (FamilyResultSig GhcPs) +deriving instance Data (FamilyResultSig GhcRn) +deriving instance Data (FamilyResultSig GhcTc) + +-- deriving instance (DataIdLR p p) => Data (FamilyDecl p) +deriving instance Data (FamilyDecl GhcPs) +deriving instance Data (FamilyDecl GhcRn) +deriving instance Data (FamilyDecl GhcTc) + +-- deriving instance (DataIdLR p p) => Data (InjectivityAnn p) +deriving instance Data (InjectivityAnn GhcPs) +deriving instance Data (InjectivityAnn GhcRn) +deriving instance Data (InjectivityAnn GhcTc) + +-- deriving instance (DataIdLR p p) => Data (FamilyInfo p) +deriving instance Data (FamilyInfo GhcPs) +deriving instance Data (FamilyInfo GhcRn) +deriving instance Data (FamilyInfo GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsDataDefn p) +deriving instance Data (HsDataDefn GhcPs) +deriving instance Data (HsDataDefn GhcRn) +deriving instance Data (HsDataDefn GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsDerivingClause p) +deriving instance Data (HsDerivingClause GhcPs) +deriving instance Data (HsDerivingClause GhcRn) +deriving instance Data (HsDerivingClause GhcTc) + +-- deriving instance (DataIdLR p p) => Data (ConDecl p) +deriving instance Data (ConDecl GhcPs) +deriving instance Data (ConDecl GhcRn) +deriving instance Data (ConDecl GhcTc) + +-- deriving instance DataIdLR p p => Data (TyFamInstDecl p) +deriving instance Data (TyFamInstDecl GhcPs) +deriving instance Data (TyFamInstDecl GhcRn) +deriving instance Data (TyFamInstDecl GhcTc) + +-- deriving instance DataIdLR p p => Data (DataFamInstDecl p) +deriving instance Data (DataFamInstDecl GhcPs) +deriving instance Data (DataFamInstDecl GhcRn) +deriving instance Data (DataFamInstDecl GhcTc) + +-- deriving instance (DataIdLR p p,Data pats,Data rhs)=>Data (FamEqn p pats rhs) +deriving instance (Data pats,Data rhs) => Data (FamEqn GhcPs pats rhs) +deriving instance (Data pats,Data rhs) => Data (FamEqn GhcRn pats rhs) +deriving instance (Data pats,Data rhs) => Data (FamEqn GhcTc pats rhs) + +-- deriving instance (DataIdLR p p) => Data (ClsInstDecl p) +deriving instance Data (ClsInstDecl GhcPs) +deriving instance Data (ClsInstDecl GhcRn) +deriving instance Data (ClsInstDecl GhcTc) + +-- deriving instance (DataIdLR p p) => Data (InstDecl p) +deriving instance Data (InstDecl GhcPs) +deriving instance Data (InstDecl GhcRn) +deriving instance Data (InstDecl GhcTc) + +-- deriving instance (DataIdLR p p) => Data (DerivDecl p) +deriving instance Data (DerivDecl GhcPs) +deriving instance Data (DerivDecl GhcRn) +deriving instance Data (DerivDecl GhcTc) + +-- deriving instance (DataIdLR p p) => Data (DerivStrategy p) +deriving instance Data (DerivStrategy GhcPs) +deriving instance Data (DerivStrategy GhcRn) +deriving instance Data (DerivStrategy GhcTc) + +-- deriving instance (DataIdLR p p) => Data (DefaultDecl p) +deriving instance Data (DefaultDecl GhcPs) +deriving instance Data (DefaultDecl GhcRn) +deriving instance Data (DefaultDecl GhcTc) + +-- deriving instance (DataIdLR p p) => Data (ForeignDecl p) +deriving instance Data (ForeignDecl GhcPs) +deriving instance Data (ForeignDecl GhcRn) +deriving instance Data (ForeignDecl GhcTc) + +-- deriving instance (DataIdLR p p) => Data (RuleDecls p) +deriving instance Data (RuleDecls GhcPs) +deriving instance Data (RuleDecls GhcRn) +deriving instance Data (RuleDecls GhcTc) + +-- deriving instance (DataIdLR p p) => Data (RuleDecl p) +deriving instance Data (RuleDecl GhcPs) +deriving instance Data (RuleDecl GhcRn) +deriving instance Data (RuleDecl GhcTc) + +-- deriving instance (DataIdLR p p) => Data (RuleBndr p) +deriving instance Data (RuleBndr GhcPs) +deriving instance Data (RuleBndr GhcRn) +deriving instance Data (RuleBndr GhcTc) + +-- deriving instance (DataId p) => Data (WarnDecls p) +deriving instance Data (WarnDecls GhcPs) +deriving instance Data (WarnDecls GhcRn) +deriving instance Data (WarnDecls GhcTc) + +-- deriving instance (DataId p) => Data (WarnDecl p) +deriving instance Data (WarnDecl GhcPs) +deriving instance Data (WarnDecl GhcRn) +deriving instance Data (WarnDecl GhcTc) + +-- deriving instance (DataIdLR p p) => Data (AnnDecl p) +deriving instance Data (AnnDecl GhcPs) +deriving instance Data (AnnDecl GhcRn) +deriving instance Data (AnnDecl GhcTc) + +-- deriving instance (DataId p) => Data (RoleAnnotDecl p) +deriving instance Data (RoleAnnotDecl GhcPs) +deriving instance Data (RoleAnnotDecl GhcRn) +deriving instance Data (RoleAnnotDecl GhcTc) + +-- --------------------------------------------------------------------- +-- Data derivations from HsExpr ---------------------------------------- + +-- deriving instance (DataIdLR p p) => Data (SyntaxExpr p) +deriving instance Data (SyntaxExpr GhcPs) +deriving instance Data (SyntaxExpr GhcRn) +deriving instance Data (SyntaxExpr GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsExpr p) +deriving instance Data (HsExpr GhcPs) +deriving instance Data (HsExpr GhcRn) +deriving instance Data (HsExpr GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsTupArg p) +deriving instance Data (HsTupArg GhcPs) +deriving instance Data (HsTupArg GhcRn) +deriving instance Data (HsTupArg GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsCmd p) +deriving instance Data (HsCmd GhcPs) +deriving instance Data (HsCmd GhcRn) +deriving instance Data (HsCmd GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsCmdTop p) +deriving instance Data (HsCmdTop GhcPs) +deriving instance Data (HsCmdTop GhcRn) +deriving instance Data (HsCmdTop GhcTc) + +-- deriving instance (DataIdLR p p,Data body) => Data (MatchGroup p body) +deriving instance (Data body) => Data (MatchGroup GhcPs body) +deriving instance (Data body) => Data (MatchGroup GhcRn body) +deriving instance (Data body) => Data (MatchGroup GhcTc body) + +-- deriving instance (DataIdLR p p,Data body) => Data (Match p body) +deriving instance (Data body) => Data (Match GhcPs body) +deriving instance (Data body) => Data (Match GhcRn body) +deriving instance (Data body) => Data (Match GhcTc body) + +-- deriving instance (DataIdLR p p,Data body) => Data (GRHSs p body) +deriving instance (Data body) => Data (GRHSs GhcPs body) +deriving instance (Data body) => Data (GRHSs GhcRn body) +deriving instance (Data body) => Data (GRHSs GhcTc body) + +-- deriving instance (DataIdLR p p,Data body) => Data (GRHS p body) +deriving instance (Data body) => Data (GRHS GhcPs body) +deriving instance (Data body) => Data (GRHS GhcRn body) +deriving instance (Data body) => Data (GRHS GhcTc body) + +-- deriving instance (DataIdLR p p,Data body) => Data (StmtLR p p body) +deriving instance (Data body) => Data (StmtLR GhcPs GhcPs body) +deriving instance (Data body) => Data (StmtLR GhcPs GhcRn body) +deriving instance (Data body) => Data (StmtLR GhcRn GhcRn body) +deriving instance (Data body) => Data (StmtLR GhcTc GhcTc body) + +deriving instance Data RecStmtTc + +-- deriving instance (DataIdLR p p) => Data (ParStmtBlock p p) +deriving instance Data (ParStmtBlock GhcPs GhcPs) +deriving instance Data (ParStmtBlock GhcPs GhcRn) +deriving instance Data (ParStmtBlock GhcRn GhcRn) +deriving instance Data (ParStmtBlock GhcTc GhcTc) + +-- deriving instance (DataIdLR p p) => Data (ApplicativeArg p) +deriving instance Data (ApplicativeArg GhcPs) +deriving instance Data (ApplicativeArg GhcRn) +deriving instance Data (ApplicativeArg GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsSplice p) +deriving instance Data (HsSplice GhcPs) +deriving instance Data (HsSplice GhcRn) +deriving instance Data (HsSplice GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsSplicedThing p) +deriving instance Data (HsSplicedThing GhcPs) +deriving instance Data (HsSplicedThing GhcRn) +deriving instance Data (HsSplicedThing GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsBracket p) +deriving instance Data (HsBracket GhcPs) +deriving instance Data (HsBracket GhcRn) +deriving instance Data (HsBracket GhcTc) + +-- deriving instance (DataIdLR p p) => Data (ArithSeqInfo p) +deriving instance Data (ArithSeqInfo GhcPs) +deriving instance Data (ArithSeqInfo GhcRn) +deriving instance Data (ArithSeqInfo GhcTc) + +deriving instance Data RecordConTc +deriving instance Data CmdTopTc +deriving instance Data PendingRnSplice +deriving instance Data PendingTcSplice + +-- --------------------------------------------------------------------- +-- Data derivations from HsLit ---------------------------------------- + +-- deriving instance (DataId p) => Data (HsLit p) +deriving instance Data (HsLit GhcPs) +deriving instance Data (HsLit GhcRn) +deriving instance Data (HsLit GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsOverLit p) +deriving instance Data (HsOverLit GhcPs) +deriving instance Data (HsOverLit GhcRn) +deriving instance Data (HsOverLit GhcTc) + +-- --------------------------------------------------------------------- +-- Data derivations from HsPat ----------------------------------------- + +-- deriving instance (DataIdLR p p) => Data (Pat p) +deriving instance Data (Pat GhcPs) +deriving instance Data (Pat GhcRn) +deriving instance Data (Pat GhcTc) + +deriving instance Data ListPatTc + +-- deriving instance (DataIdLR p p, Data body) => Data (HsRecFields p body) +deriving instance (Data body) => Data (HsRecFields GhcPs body) +deriving instance (Data body) => Data (HsRecFields GhcRn body) +deriving instance (Data body) => Data (HsRecFields GhcTc body) + +-- --------------------------------------------------------------------- +-- Data derivations from HsTypes --------------------------------------- + +-- deriving instance (DataIdLR p p) => Data (LHsQTyVars p) +deriving instance Data (LHsQTyVars GhcPs) +deriving instance Data (LHsQTyVars GhcRn) +deriving instance Data (LHsQTyVars GhcTc) + +-- deriving instance (DataIdLR p p, Data thing) =>Data (HsImplicitBndrs p thing) +deriving instance (Data thing) => Data (HsImplicitBndrs GhcPs thing) +deriving instance (Data thing) => Data (HsImplicitBndrs GhcRn thing) +deriving instance (Data thing) => Data (HsImplicitBndrs GhcTc thing) + +-- deriving instance (DataIdLR p p, Data thing) =>Data (HsWildCardBndrs p thing) +deriving instance (Data thing) => Data (HsWildCardBndrs GhcPs thing) +deriving instance (Data thing) => Data (HsWildCardBndrs GhcRn thing) +deriving instance (Data thing) => Data (HsWildCardBndrs GhcTc thing) + +-- deriving instance (DataIdLR p p) => Data (HsTyVarBndr p) +deriving instance Data (HsTyVarBndr GhcPs) +deriving instance Data (HsTyVarBndr GhcRn) +deriving instance Data (HsTyVarBndr GhcTc) + +-- deriving instance (DataIdLR p p) => Data (HsType p) +deriving instance Data (HsType GhcPs) +deriving instance Data (HsType GhcRn) +deriving instance Data (HsType GhcTc) + +deriving instance Data (LHsTypeArg GhcPs) +deriving instance Data (LHsTypeArg GhcRn) +deriving instance Data (LHsTypeArg GhcTc) + +-- deriving instance (DataIdLR p p) => Data (ConDeclField p) +deriving instance Data (ConDeclField GhcPs) +deriving instance Data (ConDeclField GhcRn) +deriving instance Data (ConDeclField GhcTc) + +-- deriving instance (DataId p) => Data (FieldOcc p) +deriving instance Data (FieldOcc GhcPs) +deriving instance Data (FieldOcc GhcRn) +deriving instance Data (FieldOcc GhcTc) + +-- deriving instance DataId p => Data (AmbiguousFieldOcc p) +deriving instance Data (AmbiguousFieldOcc GhcPs) +deriving instance Data (AmbiguousFieldOcc GhcRn) +deriving instance Data (AmbiguousFieldOcc GhcTc) + + +-- deriving instance (DataId name) => Data (ImportDecl name) +deriving instance Data (ImportDecl GhcPs) +deriving instance Data (ImportDecl GhcRn) +deriving instance Data (ImportDecl GhcTc) + +-- deriving instance (DataId name) => Data (IE name) +deriving instance Data (IE GhcPs) +deriving instance Data (IE GhcRn) +deriving instance Data (IE GhcTc) + +-- deriving instance (Eq name, Eq (IdP name)) => Eq (IE name) +deriving instance Eq (IE GhcPs) +deriving instance Eq (IE GhcRn) +deriving instance Eq (IE GhcTc) + +-- --------------------------------------------------------------------- diff --git a/compiler/hsSyn/HsLit.hs b/compiler/hsSyn/HsLit.hs new file mode 100644 --- /dev/null +++ b/compiler/hsSyn/HsLit.hs @@ -0,0 +1,314 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[HsLit]{Abstract syntax: source-language literals} +-} + +{-# LANGUAGE CPP, DeriveDataTypeable #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] + -- in module PlaceHolder +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeFamilies #-} + +module HsLit where + +#include "HsVersions.h" + +import GhcPrelude + +import {-# SOURCE #-} HsExpr( HsExpr, pprExpr ) +import BasicTypes ( IntegralLit(..),FractionalLit(..),negateIntegralLit, + negateFractionalLit,SourceText(..),pprWithSourceText ) +import Type +import Outputable +import FastString +import HsExtension + +import Data.ByteString (ByteString) +import Data.Data hiding ( Fixity ) + +{- +************************************************************************ +* * +\subsection[HsLit]{Literals} +* * +************************************************************************ +-} + +-- Note [Literal source text] in BasicTypes for SourceText fields in +-- the following +-- Note [Trees that grow] in HsExtension for the Xxxxx fields in the following +-- | Haskell Literal +data HsLit x + = HsChar (XHsChar x) {- SourceText -} Char + -- ^ Character + | HsCharPrim (XHsCharPrim x) {- SourceText -} Char + -- ^ Unboxed character + | HsString (XHsString x) {- SourceText -} FastString + -- ^ String + | HsStringPrim (XHsStringPrim x) {- SourceText -} ByteString + -- ^ Packed bytes + | HsInt (XHsInt x) IntegralLit + -- ^ Genuinely an Int; arises from + -- @TcGenDeriv@, and from TRANSLATION + | HsIntPrim (XHsIntPrim x) {- SourceText -} Integer + -- ^ literal @Int#@ + | HsWordPrim (XHsWordPrim x) {- SourceText -} Integer + -- ^ literal @Word#@ + | HsInt64Prim (XHsInt64Prim x) {- SourceText -} Integer + -- ^ literal @Int64#@ + | HsWord64Prim (XHsWord64Prim x) {- SourceText -} Integer + -- ^ literal @Word64#@ + | HsInteger (XHsInteger x) {- SourceText -} Integer Type + -- ^ Genuinely an integer; arises only + -- from TRANSLATION (overloaded + -- literals are done with HsOverLit) + | HsRat (XHsRat x) FractionalLit Type + -- ^ Genuinely a rational; arises only from + -- TRANSLATION (overloaded literals are + -- done with HsOverLit) + | HsFloatPrim (XHsFloatPrim x) FractionalLit + -- ^ Unboxed Float + | HsDoublePrim (XHsDoublePrim x) FractionalLit + -- ^ Unboxed Double + + | XLit (XXLit x) + +type instance XHsChar (GhcPass _) = SourceText +type instance XHsCharPrim (GhcPass _) = SourceText +type instance XHsString (GhcPass _) = SourceText +type instance XHsStringPrim (GhcPass _) = SourceText +type instance XHsInt (GhcPass _) = NoExt +type instance XHsIntPrim (GhcPass _) = SourceText +type instance XHsWordPrim (GhcPass _) = SourceText +type instance XHsInt64Prim (GhcPass _) = SourceText +type instance XHsWord64Prim (GhcPass _) = SourceText +type instance XHsInteger (GhcPass _) = SourceText +type instance XHsRat (GhcPass _) = NoExt +type instance XHsFloatPrim (GhcPass _) = NoExt +type instance XHsDoublePrim (GhcPass _) = NoExt +type instance XXLit (GhcPass _) = NoExt + +instance Eq (HsLit x) where + (HsChar _ x1) == (HsChar _ x2) = x1==x2 + (HsCharPrim _ x1) == (HsCharPrim _ x2) = x1==x2 + (HsString _ x1) == (HsString _ x2) = x1==x2 + (HsStringPrim _ x1) == (HsStringPrim _ x2) = x1==x2 + (HsInt _ x1) == (HsInt _ x2) = x1==x2 + (HsIntPrim _ x1) == (HsIntPrim _ x2) = x1==x2 + (HsWordPrim _ x1) == (HsWordPrim _ x2) = x1==x2 + (HsInt64Prim _ x1) == (HsInt64Prim _ x2) = x1==x2 + (HsWord64Prim _ x1) == (HsWord64Prim _ x2) = x1==x2 + (HsInteger _ x1 _) == (HsInteger _ x2 _) = x1==x2 + (HsRat _ x1 _) == (HsRat _ x2 _) = x1==x2 + (HsFloatPrim _ x1) == (HsFloatPrim _ x2) = x1==x2 + (HsDoublePrim _ x1) == (HsDoublePrim _ x2) = x1==x2 + _ == _ = False + +-- | Haskell Overloaded Literal +data HsOverLit p + = OverLit { + ol_ext :: (XOverLit p), + ol_val :: OverLitVal, + ol_witness :: HsExpr p} -- Note [Overloaded literal witnesses] + + | XOverLit + (XXOverLit p) + +data OverLitTc + = OverLitTc { + ol_rebindable :: Bool, -- Note [ol_rebindable] + ol_type :: Type } + deriving Data + +type instance XOverLit GhcPs = NoExt +type instance XOverLit GhcRn = Bool -- Note [ol_rebindable] +type instance XOverLit GhcTc = OverLitTc + +type instance XXOverLit (GhcPass _) = NoExt + +-- Note [Literal source text] in BasicTypes for SourceText fields in +-- the following +-- | Overloaded Literal Value +data OverLitVal + = HsIntegral !IntegralLit -- ^ Integer-looking literals; + | HsFractional !FractionalLit -- ^ Frac-looking literals + | HsIsString !SourceText !FastString -- ^ String-looking literals + deriving Data + +negateOverLitVal :: OverLitVal -> OverLitVal +negateOverLitVal (HsIntegral i) = HsIntegral (negateIntegralLit i) +negateOverLitVal (HsFractional f) = HsFractional (negateFractionalLit f) +negateOverLitVal _ = panic "negateOverLitVal: argument is not a number" + +overLitType :: HsOverLit GhcTc -> Type +overLitType (OverLit (OverLitTc _ ty) _ _) = ty +overLitType XOverLit{} = panic "overLitType" + +-- | Convert a literal from one index type to another, updating the annotations +-- according to the relevant 'Convertable' instance +convertLit :: (ConvertIdX a b) => HsLit a -> HsLit b +convertLit (HsChar a x) = (HsChar (convert a) x) +convertLit (HsCharPrim a x) = (HsCharPrim (convert a) x) +convertLit (HsString a x) = (HsString (convert a) x) +convertLit (HsStringPrim a x) = (HsStringPrim (convert a) x) +convertLit (HsInt a x) = (HsInt (convert a) x) +convertLit (HsIntPrim a x) = (HsIntPrim (convert a) x) +convertLit (HsWordPrim a x) = (HsWordPrim (convert a) x) +convertLit (HsInt64Prim a x) = (HsInt64Prim (convert a) x) +convertLit (HsWord64Prim a x) = (HsWord64Prim (convert a) x) +convertLit (HsInteger a x b) = (HsInteger (convert a) x b) +convertLit (HsRat a x b) = (HsRat (convert a) x b) +convertLit (HsFloatPrim a x) = (HsFloatPrim (convert a) x) +convertLit (HsDoublePrim a x) = (HsDoublePrim (convert a) x) +convertLit (XLit a) = (XLit (convert a)) + +{- +Note [ol_rebindable] +~~~~~~~~~~~~~~~~~~~~ +The ol_rebindable field is True if this literal is actually +using rebindable syntax. Specifically: + + False iff ol_witness is the standard one + True iff ol_witness is non-standard + +Equivalently it's True if + a) RebindableSyntax is on + b) the witness for fromInteger/fromRational/fromString + that happens to be in scope isn't the standard one + +Note [Overloaded literal witnesses] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +*Before* type checking, the HsExpr in an HsOverLit is the +name of the coercion function, 'fromInteger' or 'fromRational'. +*After* type checking, it is a witness for the literal, such as + (fromInteger 3) or lit_78 +This witness should replace the literal. + +This dual role is unusual, because we're replacing 'fromInteger' with +a call to fromInteger. Reason: it allows commoning up of the fromInteger +calls, which wouldn't be possible if the desugarer made the application. + +The PostTcType in each branch records the type the overload literal is +found to have. +-} + +-- Comparison operations are needed when grouping literals +-- for compiling pattern-matching (module MatchLit) +instance (Eq (XXOverLit p)) => Eq (HsOverLit p) where + (OverLit _ val1 _) == (OverLit _ val2 _) = val1 == val2 + (XOverLit val1) == (XOverLit val2) = val1 == val2 + _ == _ = panic "Eq HsOverLit" + +instance Eq OverLitVal where + (HsIntegral i1) == (HsIntegral i2) = i1 == i2 + (HsFractional f1) == (HsFractional f2) = f1 == f2 + (HsIsString _ s1) == (HsIsString _ s2) = s1 == s2 + _ == _ = False + +instance (Ord (XXOverLit p)) => Ord (HsOverLit p) where + compare (OverLit _ val1 _) (OverLit _ val2 _) = val1 `compare` val2 + compare (XOverLit val1) (XOverLit val2) = val1 `compare` val2 + compare _ _ = panic "Ord HsOverLit" + +instance Ord OverLitVal where + compare (HsIntegral i1) (HsIntegral i2) = i1 `compare` i2 + compare (HsIntegral _) (HsFractional _) = LT + compare (HsIntegral _) (HsIsString _ _) = LT + compare (HsFractional f1) (HsFractional f2) = f1 `compare` f2 + compare (HsFractional _) (HsIntegral _) = GT + compare (HsFractional _) (HsIsString _ _) = LT + compare (HsIsString _ s1) (HsIsString _ s2) = s1 `compare` s2 + compare (HsIsString _ _) (HsIntegral _) = GT + compare (HsIsString _ _) (HsFractional _) = GT + +-- Instance specific to GhcPs, need the SourceText +instance p ~ GhcPass pass => Outputable (HsLit p) where + ppr (HsChar st c) = pprWithSourceText st (pprHsChar c) + ppr (HsCharPrim st c) = pp_st_suffix st primCharSuffix (pprPrimChar c) + ppr (HsString st s) = pprWithSourceText st (pprHsString s) + ppr (HsStringPrim st s) = pprWithSourceText st (pprHsBytes s) + ppr (HsInt _ i) + = pprWithSourceText (il_text i) (integer (il_value i)) + ppr (HsInteger st i _) = pprWithSourceText st (integer i) + ppr (HsRat _ f _) = ppr f + ppr (HsFloatPrim _ f) = ppr f <> primFloatSuffix + ppr (HsDoublePrim _ d) = ppr d <> primDoubleSuffix + ppr (HsIntPrim st i) = pprWithSourceText st (pprPrimInt i) + ppr (HsWordPrim st w) = pprWithSourceText st (pprPrimWord w) + ppr (HsInt64Prim st i) = pp_st_suffix st primInt64Suffix (pprPrimInt64 i) + ppr (HsWord64Prim st w) = pp_st_suffix st primWord64Suffix (pprPrimWord64 w) + ppr (XLit x) = ppr x + +pp_st_suffix :: SourceText -> SDoc -> SDoc -> SDoc +pp_st_suffix NoSourceText _ doc = doc +pp_st_suffix (SourceText st) suffix _ = text st <> suffix + +-- in debug mode, print the expression that it's resolved to, too +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (HsOverLit p) where + ppr (OverLit {ol_val=val, ol_witness=witness}) + = ppr val <+> (whenPprDebug (parens (pprExpr witness))) + ppr (XOverLit x) = ppr x + +instance Outputable OverLitVal where + ppr (HsIntegral i) = pprWithSourceText (il_text i) (integer (il_value i)) + ppr (HsFractional f) = ppr f + ppr (HsIsString st s) = pprWithSourceText st (pprHsString s) + +-- | pmPprHsLit pretty prints literals and is used when pretty printing pattern +-- match warnings. All are printed the same (i.e., without hashes if they are +-- primitive and not wrapped in constructors if they are boxed). This happens +-- mainly for too reasons: +-- * We do not want to expose their internal representation +-- * The warnings become too messy +pmPprHsLit :: HsLit (GhcPass x) -> SDoc +pmPprHsLit (HsChar _ c) = pprHsChar c +pmPprHsLit (HsCharPrim _ c) = pprHsChar c +pmPprHsLit (HsString st s) = pprWithSourceText st (pprHsString s) +pmPprHsLit (HsStringPrim _ s) = pprHsBytes s +pmPprHsLit (HsInt _ i) = integer (il_value i) +pmPprHsLit (HsIntPrim _ i) = integer i +pmPprHsLit (HsWordPrim _ w) = integer w +pmPprHsLit (HsInt64Prim _ i) = integer i +pmPprHsLit (HsWord64Prim _ w) = integer w +pmPprHsLit (HsInteger _ i _) = integer i +pmPprHsLit (HsRat _ f _) = ppr f +pmPprHsLit (HsFloatPrim _ f) = ppr f +pmPprHsLit (HsDoublePrim _ d) = ppr d +pmPprHsLit (XLit x) = ppr x + +-- | @'hsLitNeedsParens' p l@ returns 'True' if a literal @l@ needs +-- to be parenthesized under precedence @p@. +hsLitNeedsParens :: PprPrec -> HsLit x -> Bool +hsLitNeedsParens p = go + where + go (HsChar {}) = False + go (HsCharPrim {}) = False + go (HsString {}) = False + go (HsStringPrim {}) = False + go (HsInt _ x) = p > topPrec && il_neg x + go (HsIntPrim _ x) = p > topPrec && x < 0 + go (HsWordPrim {}) = False + go (HsInt64Prim _ x) = p > topPrec && x < 0 + go (HsWord64Prim {}) = False + go (HsInteger _ x _) = p > topPrec && x < 0 + go (HsRat _ x _) = p > topPrec && fl_neg x + go (HsFloatPrim _ x) = p > topPrec && fl_neg x + go (HsDoublePrim _ x) = p > topPrec && fl_neg x + go (XLit _) = False + +-- | @'hsOverLitNeedsParens' p ol@ returns 'True' if an overloaded literal +-- @ol@ needs to be parenthesized under precedence @p@. +hsOverLitNeedsParens :: PprPrec -> HsOverLit x -> Bool +hsOverLitNeedsParens p (OverLit { ol_val = olv }) = go olv + where + go :: OverLitVal -> Bool + go (HsIntegral x) = p > topPrec && il_neg x + go (HsFractional x) = p > topPrec && fl_neg x + go (HsIsString {}) = False +hsOverLitNeedsParens _ (XOverLit { }) = False diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs new file mode 100644 --- /dev/null +++ b/compiler/hsSyn/HsPat.hs @@ -0,0 +1,846 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[PatSyntax]{Abstract Haskell syntax---patterns} +-} + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] + -- in module PlaceHolder +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE FlexibleInstances #-} + +module HsPat ( + Pat(..), InPat, OutPat, LPat, + ListPatTc(..), + + HsConPatDetails, hsConPatArgs, + HsRecFields(..), HsRecField'(..), LHsRecField', + HsRecField, LHsRecField, + HsRecUpdField, LHsRecUpdField, + hsRecFields, hsRecFieldSel, hsRecFieldId, hsRecFieldsArgs, + hsRecUpdFieldId, hsRecUpdFieldOcc, hsRecUpdFieldRdr, + + mkPrefixConPat, mkCharLitPat, mkNilPat, + + looksLazyPatBind, + isBangedLPat, + patNeedsParens, parenthesizePat, + isIrrefutableHsPat, + + collectEvVarsPat, collectEvVarsPats, + + pprParendLPat, pprConArgs + ) where + +import GhcPrelude + +import {-# SOURCE #-} HsExpr (SyntaxExpr, LHsExpr, HsSplice, pprLExpr, pprSplice) + +-- friends: +import HsBinds +import HsLit +import HsExtension +import HsTypes +import TcEvidence +import BasicTypes +-- others: +import PprCore ( {- instance OutputableBndr TyVar -} ) +import TysWiredIn +import Var +import RdrName ( RdrName ) +import ConLike +import DataCon +import TyCon +import Outputable +import Type +import SrcLoc +import Bag -- collect ev vars from pats +import DynFlags( gopt, GeneralFlag(..) ) +import Maybes +-- libraries: +import Data.Data hiding (TyCon,Fixity) + +type InPat p = LPat p -- No 'Out' constructors +type OutPat p = LPat p -- No 'In' constructors + +type LPat p = Pat p + +-- | Pattern +-- +-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang' + +-- For details on above see note [Api annotations] in ApiAnnotation +data Pat p + = ------------ Simple patterns --------------- + WildPat (XWildPat p) -- ^ Wildcard Pattern + -- The sole reason for a type on a WildPat is to + -- support hsPatType :: Pat Id -> Type + + -- AZ:TODO above comment needs to be updated + | VarPat (XVarPat p) + (Located (IdP p)) -- ^ Variable Pattern + + -- See Note [Located RdrNames] in HsExpr + | LazyPat (XLazyPat p) + (LPat p) -- ^ Lazy Pattern + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde' + + -- For details on above see note [Api annotations] in ApiAnnotation + + | AsPat (XAsPat p) + (Located (IdP p)) (LPat p) -- ^ As pattern + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt' + + -- For details on above see note [Api annotations] in ApiAnnotation + + | ParPat (XParPat p) + (LPat p) -- ^ Parenthesised pattern + -- See Note [Parens in HsSyn] in HsExpr + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, + -- 'ApiAnnotation.AnnClose' @')'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + | BangPat (XBangPat p) + (LPat p) -- ^ Bang pattern + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnBang' + + -- For details on above see note [Api annotations] in ApiAnnotation + + ------------ Lists, tuples, arrays --------------- + | ListPat (XListPat p) + [LPat p] + -- For OverloadedLists a Just (ty,fn) gives + -- overall type of the pattern, and the toList +-- function to convert the scrutinee to a list value + + -- ^ Syntactic List + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@, + -- 'ApiAnnotation.AnnClose' @']'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + + | TuplePat (XTuplePat p) + -- after typechecking, holds the types of the tuple components + [LPat p] -- Tuple sub-patterns + Boxity -- UnitPat is TuplePat [] + -- You might think that the post typechecking Type was redundant, + -- because we can get the pattern type by getting the types of the + -- sub-patterns. + -- But it's essential + -- data T a where + -- T1 :: Int -> T Int + -- f :: (T a, a) -> Int + -- f (T1 x, z) = z + -- When desugaring, we must generate + -- f = /\a. \v::a. case v of (t::T a, w::a) -> + -- case t of (T1 (x::Int)) -> + -- Note the (w::a), NOT (w::Int), because we have not yet + -- refined 'a' to Int. So we must know that the second component + -- of the tuple is of type 'a' not Int. See selectMatchVar + -- (June 14: I'm not sure this comment is right; the sub-patterns + -- will be wrapped in CoPats, no?) + -- ^ Tuple sub-patterns + -- + -- - 'ApiAnnotation.AnnKeywordId' : + -- 'ApiAnnotation.AnnOpen' @'('@ or @'(#'@, + -- 'ApiAnnotation.AnnClose' @')'@ or @'#)'@ + + | SumPat (XSumPat p) -- PlaceHolder before typechecker, filled in + -- afterwards with the types of the + -- alternative + (LPat p) -- Sum sub-pattern + ConTag -- Alternative (one-based) + Arity -- Arity (INVARIANT: ≥ 2) + -- ^ Anonymous sum pattern + -- + -- - 'ApiAnnotation.AnnKeywordId' : + -- 'ApiAnnotation.AnnOpen' @'(#'@, + -- 'ApiAnnotation.AnnClose' @'#)'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + + ------------ Constructor patterns --------------- + | ConPatIn (Located (IdP p)) + (HsConPatDetails p) + -- ^ Constructor Pattern In + + | ConPatOut { + pat_con :: Located ConLike, + pat_arg_tys :: [Type], -- The universal arg types, 1-1 with the universal + -- tyvars of the constructor/pattern synonym + -- Use (conLikeResTy pat_con pat_arg_tys) to get + -- the type of the pattern + + pat_tvs :: [TyVar], -- Existentially bound type variables + -- in correctly-scoped order e.g. [k:*, x:k] + pat_dicts :: [EvVar], -- Ditto *coercion variables* and *dictionaries* + -- One reason for putting coercion variable here, I think, + -- is to ensure their kinds are zonked + + pat_binds :: TcEvBinds, -- Bindings involving those dictionaries + pat_args :: HsConPatDetails p, + pat_wrap :: HsWrapper -- Extra wrapper to pass to the matcher + -- Only relevant for pattern-synonyms; + -- ignored for data cons + } + -- ^ Constructor Pattern Out + + ------------ View patterns --------------- + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow' + + -- For details on above see note [Api annotations] in ApiAnnotation + | ViewPat (XViewPat p) -- The overall type of the pattern + -- (= the argument type of the view function) + -- for hsPatType. + (LHsExpr p) + (LPat p) + -- ^ View Pattern + + ------------ Pattern splices --------------- + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'$('@ + -- 'ApiAnnotation.AnnClose' @')'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + | SplicePat (XSplicePat p) + (HsSplice p) -- ^ Splice Pattern (Includes quasi-quotes) + + ------------ Literal and n+k patterns --------------- + | LitPat (XLitPat p) + (HsLit p) -- ^ Literal Pattern + -- Used for *non-overloaded* literal patterns: + -- Int#, Char#, Int, Char, String, etc. + + | NPat -- Natural Pattern + -- Used for all overloaded literals, + -- including overloaded strings with -XOverloadedStrings + (XNPat p) -- Overall type of pattern. Might be + -- different than the literal's type + -- if (==) or negate changes the type + (Located (HsOverLit p)) -- ALWAYS positive + (Maybe (SyntaxExpr p)) -- Just (Name of 'negate') for + -- negative patterns, Nothing + -- otherwise + (SyntaxExpr p) -- Equality checker, of type t->t->Bool + + -- ^ Natural Pattern + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVal' @'+'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + | NPlusKPat (XNPlusKPat p) -- Type of overall pattern + (Located (IdP p)) -- n+k pattern + (Located (HsOverLit p)) -- It'll always be an HsIntegral + (HsOverLit p) -- See Note [NPlusK patterns] in TcPat + -- NB: This could be (PostTc ...), but that induced a + -- a new hs-boot file. Not worth it. + + (SyntaxExpr p) -- (>=) function, of type t1->t2->Bool + (SyntaxExpr p) -- Name of '-' (see RnEnv.lookupSyntaxName) + -- ^ n+k pattern + + ------------ Pattern type signatures --------------- + -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon' + + -- For details on above see note [Api annotations] in ApiAnnotation + | SigPat (XSigPat p) -- After typechecker: Type + (LPat p) -- Pattern with a type signature + (LHsSigWcType (NoGhcTc p)) -- Signature can bind both + -- kind and type vars + + -- ^ Pattern with a type signature + + ------------ Pattern coercions (translation only) --------------- + | CoPat (XCoPat p) + HsWrapper -- Coercion Pattern + -- If co :: t1 ~ t2, p :: t2, + -- then (CoPat co p) :: t1 + (Pat p) -- Why not LPat? Ans: existing locn will do + Type -- Type of whole pattern, t1 + -- During desugaring a (CoPat co pat) turns into a cast with 'co' on + -- the scrutinee, followed by a match on 'pat' + -- ^ Coercion Pattern + + -- | Trees that Grow extension point for new constructors + | XPat + (XXPat p) + +-- --------------------------------------------------------------------- + +data ListPatTc + = ListPatTc + Type -- The type of the elements + (Maybe (Type, SyntaxExpr GhcTc)) -- For rebindable syntax + +type instance XWildPat GhcPs = NoExt +type instance XWildPat GhcRn = NoExt +type instance XWildPat GhcTc = Type + +type instance XVarPat (GhcPass _) = NoExt +type instance XLazyPat (GhcPass _) = NoExt +type instance XAsPat (GhcPass _) = NoExt +type instance XParPat (GhcPass _) = NoExt +type instance XBangPat (GhcPass _) = NoExt + +-- Note: XListPat cannot be extended when using GHC 8.0.2 as the bootstrap +-- compiler, as it triggers https://gitlab.haskell.org/ghc/ghc/issues/14396 for +-- `SyntaxExpr` +type instance XListPat GhcPs = NoExt +type instance XListPat GhcRn = Maybe (SyntaxExpr GhcRn) +type instance XListPat GhcTc = ListPatTc + +type instance XTuplePat GhcPs = NoExt +type instance XTuplePat GhcRn = NoExt +type instance XTuplePat GhcTc = [Type] + +type instance XSumPat GhcPs = NoExt +type instance XSumPat GhcRn = NoExt +type instance XSumPat GhcTc = [Type] + +type instance XViewPat GhcPs = NoExt +type instance XViewPat GhcRn = NoExt +type instance XViewPat GhcTc = Type + +type instance XSplicePat (GhcPass _) = NoExt +type instance XLitPat (GhcPass _) = NoExt + +type instance XNPat GhcPs = NoExt +type instance XNPat GhcRn = NoExt +type instance XNPat GhcTc = Type + +type instance XNPlusKPat GhcPs = NoExt +type instance XNPlusKPat GhcRn = NoExt +type instance XNPlusKPat GhcTc = Type + +type instance XSigPat GhcPs = NoExt +type instance XSigPat GhcRn = NoExt +type instance XSigPat GhcTc = Type + +type instance XCoPat (GhcPass _) = NoExt +type instance XXPat (GhcPass p) = Located (Pat (GhcPass p)) + + +{- +************************************************************************ +* * +* HasSrcSpan Instance +* * +************************************************************************ +-} + +type instance SrcSpanLess (LPat (GhcPass p)) = Pat (GhcPass p) +instance HasSrcSpan (LPat (GhcPass p)) where + -- NB: The following chooses the behaviour of the outer location + -- wrapper replacing the inner ones. + composeSrcSpan (L sp p) = if sp == noSrcSpan + then p + else XPat (L sp (stripSrcSpanPat p)) + + -- NB: The following only returns the top-level location, if any. + decomposeSrcSpan (XPat (L sp p)) = L sp (stripSrcSpanPat p) + decomposeSrcSpan p = L noSrcSpan p + +stripSrcSpanPat :: LPat (GhcPass p) -> Pat (GhcPass p) +stripSrcSpanPat (XPat (L _ p)) = stripSrcSpanPat p +stripSrcSpanPat p = p + + + +-- --------------------------------------------------------------------- + + +-- | Haskell Constructor Pattern Details +type HsConPatDetails p = HsConDetails (LPat p) (HsRecFields p (LPat p)) + +hsConPatArgs :: HsConPatDetails p -> [LPat p] +hsConPatArgs (PrefixCon ps) = ps +hsConPatArgs (RecCon fs) = map (hsRecFieldArg . unLoc) (rec_flds fs) +hsConPatArgs (InfixCon p1 p2) = [p1,p2] + +-- | Haskell Record Fields +-- +-- HsRecFields is used only for patterns and expressions (not data type +-- declarations) +data HsRecFields p arg -- A bunch of record fields + -- { x = 3, y = True } + -- Used for both expressions and patterns + = HsRecFields { rec_flds :: [LHsRecField p arg], + rec_dotdot :: Maybe (Located Int) } -- Note [DotDot fields] + deriving (Functor, Foldable, Traversable) + + +-- Note [DotDot fields] +-- ~~~~~~~~~~~~~~~~~~~~ +-- The rec_dotdot field means this: +-- Nothing => the normal case +-- Just n => the group uses ".." notation, +-- +-- In the latter case: +-- +-- *before* renamer: rec_flds are exactly the n user-written fields +-- +-- *after* renamer: rec_flds includes *all* fields, with +-- the first 'n' being the user-written ones +-- and the remainder being 'filled in' implicitly + +-- | Located Haskell Record Field +type LHsRecField' p arg = Located (HsRecField' p arg) + +-- | Located Haskell Record Field +type LHsRecField p arg = Located (HsRecField p arg) + +-- | Located Haskell Record Update Field +type LHsRecUpdField p = Located (HsRecUpdField p) + +-- | Haskell Record Field +type HsRecField p arg = HsRecField' (FieldOcc p) arg + +-- | Haskell Record Update Field +type HsRecUpdField p = HsRecField' (AmbiguousFieldOcc p) (LHsExpr p) + +-- | Haskell Record Field +-- +-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnEqual', +-- +-- For details on above see note [Api annotations] in ApiAnnotation +data HsRecField' id arg = HsRecField { + hsRecFieldLbl :: Located id, + hsRecFieldArg :: arg, -- ^ Filled in by renamer when punning + hsRecPun :: Bool -- ^ Note [Punning] + } deriving (Data, Functor, Foldable, Traversable) + + +-- Note [Punning] +-- ~~~~~~~~~~~~~~ +-- If you write T { x, y = v+1 }, the HsRecFields will be +-- HsRecField x x True ... +-- HsRecField y (v+1) False ... +-- That is, for "punned" field x is expanded (in the renamer) +-- to x=x; but with a punning flag so we can detect it later +-- (e.g. when pretty printing) +-- +-- If the original field was qualified, we un-qualify it, thus +-- T { A.x } means T { A.x = x } + + +-- Note [HsRecField and HsRecUpdField] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +-- A HsRecField (used for record construction and pattern matching) +-- contains an unambiguous occurrence of a field (i.e. a FieldOcc). +-- We can't just store the Name, because thanks to +-- DuplicateRecordFields this may not correspond to the label the user +-- wrote. +-- +-- A HsRecUpdField (used for record update) contains a potentially +-- ambiguous occurrence of a field (an AmbiguousFieldOcc). The +-- renamer will fill in the selector function if it can, but if the +-- selector is ambiguous the renamer will defer to the typechecker. +-- After the typechecker, a unique selector will have been determined. +-- +-- The renamer produces an Unambiguous result if it can, rather than +-- just doing the lookup in the typechecker, so that completely +-- unambiguous updates can be represented by 'DsMeta.repUpdFields'. +-- +-- For example, suppose we have: +-- +-- data S = MkS { x :: Int } +-- data T = MkT { x :: Int } +-- +-- f z = (z { x = 3 }) :: S +-- +-- The parsed HsRecUpdField corresponding to the record update will have: +-- +-- hsRecFieldLbl = Unambiguous "x" NoExt :: AmbiguousFieldOcc RdrName +-- +-- After the renamer, this will become: +-- +-- hsRecFieldLbl = Ambiguous "x" NoExt :: AmbiguousFieldOcc Name +-- +-- (note that the Unambiguous constructor is not type-correct here). +-- The typechecker will determine the particular selector: +-- +-- hsRecFieldLbl = Unambiguous "x" $sel:x:MkS :: AmbiguousFieldOcc Id +-- +-- See also Note [Disambiguating record fields] in TcExpr. + +hsRecFields :: HsRecFields p arg -> [XCFieldOcc p] +hsRecFields rbinds = map (unLoc . hsRecFieldSel . unLoc) (rec_flds rbinds) + +-- Probably won't typecheck at once, things have changed :/ +hsRecFieldsArgs :: HsRecFields p arg -> [arg] +hsRecFieldsArgs rbinds = map (hsRecFieldArg . unLoc) (rec_flds rbinds) + +hsRecFieldSel :: HsRecField pass arg -> Located (XCFieldOcc pass) +hsRecFieldSel = fmap extFieldOcc . hsRecFieldLbl + +hsRecFieldId :: HsRecField GhcTc arg -> Located Id +hsRecFieldId = hsRecFieldSel + +hsRecUpdFieldRdr :: HsRecUpdField (GhcPass p) -> Located RdrName +hsRecUpdFieldRdr = fmap rdrNameAmbiguousFieldOcc . hsRecFieldLbl + +hsRecUpdFieldId :: HsRecField' (AmbiguousFieldOcc GhcTc) arg -> Located Id +hsRecUpdFieldId = fmap extFieldOcc . hsRecUpdFieldOcc + +hsRecUpdFieldOcc :: HsRecField' (AmbiguousFieldOcc GhcTc) arg -> LFieldOcc GhcTc +hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hsRecFieldLbl + + +{- +************************************************************************ +* * +* Printing patterns +* * +************************************************************************ +-} + +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (Pat p) where + ppr = pprPat + +pprPatBndr :: OutputableBndr name => name -> SDoc +pprPatBndr var -- Print with type info if -dppr-debug is on + = getPprStyle $ \ sty -> + if debugStyle sty then + parens (pprBndr LambdaBind var) -- Could pass the site to pprPat + -- but is it worth it? + else + pprPrefixOcc var + +pprParendLPat :: (OutputableBndrId (GhcPass p)) + => PprPrec -> LPat (GhcPass p) -> SDoc +pprParendLPat p = pprParendPat p . unLoc + +pprParendPat :: (OutputableBndrId (GhcPass p)) + => PprPrec -> Pat (GhcPass p) -> SDoc +pprParendPat p pat = sdocWithDynFlags $ \ dflags -> + if need_parens dflags pat + then parens (pprPat pat) + else pprPat pat + where + need_parens dflags pat + | CoPat {} <- pat = gopt Opt_PrintTypecheckerElaboration dflags + | otherwise = patNeedsParens p pat + -- For a CoPat we need parens if we are going to show it, which + -- we do if -fprint-typechecker-elaboration is on (c.f. pprHsWrapper) + -- But otherwise the CoPat is discarded, so it + -- is the pattern inside that matters. Sigh. + +pprPat :: (OutputableBndrId (GhcPass p)) => Pat (GhcPass p) -> SDoc +pprPat (VarPat _ lvar) = pprPatBndr (unLoc lvar) +pprPat (WildPat _) = char '_' +pprPat (LazyPat _ pat) = char '~' <> pprParendLPat appPrec pat +pprPat (BangPat _ pat) = char '!' <> pprParendLPat appPrec pat +pprPat (AsPat _ name pat) = hcat [pprPrefixOcc (unLoc name), char '@', + pprParendLPat appPrec pat] +pprPat (ViewPat _ expr pat) = hcat [pprLExpr expr, text " -> ", ppr pat] +pprPat (ParPat _ pat) = parens (ppr pat) +pprPat (LitPat _ s) = ppr s +pprPat (NPat _ l Nothing _) = ppr l +pprPat (NPat _ l (Just _) _) = char '-' <> ppr l +pprPat (NPlusKPat _ n k _ _ _) = hcat [ppr n, char '+', ppr k] +pprPat (SplicePat _ splice) = pprSplice splice +pprPat (CoPat _ co pat _) = pprHsWrapper co $ \parens + -> if parens + then pprParendPat appPrec pat + else pprPat pat +pprPat (SigPat _ pat ty) = ppr pat <+> dcolon <+> ppr ty +pprPat (ListPat _ pats) = brackets (interpp'SP pats) +pprPat (TuplePat _ pats bx) = tupleParens (boxityTupleSort bx) + (pprWithCommas ppr pats) +pprPat (SumPat _ pat alt arity) = sumParens (pprAlternative ppr pat alt arity) +pprPat (ConPatIn con details) = pprUserCon (unLoc con) details +pprPat (ConPatOut { pat_con = con + , pat_tvs = tvs + , pat_dicts = dicts + , pat_binds = binds + , pat_args = details }) + = sdocWithDynFlags $ \dflags -> + -- Tiresome; in TcBinds.tcRhs we print out a + -- typechecked Pat in an error message, + -- and we want to make sure it prints nicely + if gopt Opt_PrintTypecheckerElaboration dflags then + ppr con + <> braces (sep [ hsep (map pprPatBndr (tvs ++ dicts)) + , ppr binds]) + <+> pprConArgs details + else pprUserCon (unLoc con) details +pprPat (XPat x) = ppr x + + +pprUserCon :: (OutputableBndr con, OutputableBndrId (GhcPass p)) + => con -> HsConPatDetails (GhcPass p) -> SDoc +pprUserCon c (InfixCon p1 p2) = ppr p1 <+> pprInfixOcc c <+> ppr p2 +pprUserCon c details = pprPrefixOcc c <+> pprConArgs details + +pprConArgs :: (OutputableBndrId (GhcPass p)) + => HsConPatDetails (GhcPass p) -> SDoc +pprConArgs (PrefixCon pats) = sep (map (pprParendLPat appPrec) pats) +pprConArgs (InfixCon p1 p2) = sep [ pprParendLPat appPrec p1 + , pprParendLPat appPrec p2 ] +pprConArgs (RecCon rpats) = ppr rpats + +instance (Outputable arg) + => Outputable (HsRecFields p arg) where + ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing }) + = braces (fsep (punctuate comma (map ppr flds))) + ppr (HsRecFields { rec_flds = flds, rec_dotdot = Just (unLoc -> n) }) + = braces (fsep (punctuate comma (map ppr (take n flds) ++ [dotdot]))) + where + dotdot = text ".." <+> whenPprDebug (ppr (drop n flds)) + +instance (Outputable p, Outputable arg) + => Outputable (HsRecField' p arg) where + ppr (HsRecField { hsRecFieldLbl = f, hsRecFieldArg = arg, + hsRecPun = pun }) + = ppr f <+> (ppUnless pun $ equals <+> ppr arg) + + +{- +************************************************************************ +* * +* Building patterns +* * +************************************************************************ +-} + +mkPrefixConPat :: DataCon -> + [OutPat (GhcPass p)] -> [Type] -> OutPat (GhcPass p) +-- Make a vanilla Prefix constructor pattern +mkPrefixConPat dc pats tys + = noLoc $ ConPatOut { pat_con = noLoc (RealDataCon dc) + , pat_tvs = [] + , pat_dicts = [] + , pat_binds = emptyTcEvBinds + , pat_args = PrefixCon pats + , pat_arg_tys = tys + , pat_wrap = idHsWrapper } + +mkNilPat :: Type -> OutPat (GhcPass p) +mkNilPat ty = mkPrefixConPat nilDataCon [] [ty] + +mkCharLitPat :: SourceText -> Char -> OutPat (GhcPass p) +mkCharLitPat src c = mkPrefixConPat charDataCon + [noLoc $ LitPat NoExt (HsCharPrim src c)] [] + +{- +************************************************************************ +* * +* Predicates for checking things about pattern-lists in EquationInfo * +* * +************************************************************************ + +\subsection[Pat-list-predicates]{Look for interesting things in patterns} + +Unlike in the Wadler chapter, where patterns are either ``variables'' +or ``constructors,'' here we distinguish between: +\begin{description} +\item[unfailable:] +Patterns that cannot fail to match: variables, wildcards, and lazy +patterns. + +These are the irrefutable patterns; the two other categories +are refutable patterns. + +\item[constructor:] +A non-literal constructor pattern (see next category). + +\item[literal patterns:] +At least the numeric ones may be overloaded. +\end{description} + +A pattern is in {\em exactly one} of the above three categories; `as' +patterns are treated specially, of course. + +The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are. +-} + +isBangedLPat :: LPat (GhcPass p) -> Bool +isBangedLPat = isBangedPat . unLoc + +isBangedPat :: Pat (GhcPass p) -> Bool +isBangedPat (ParPat _ p) = isBangedLPat p +isBangedPat (BangPat {}) = True +isBangedPat _ = False + +looksLazyPatBind :: HsBind (GhcPass p) -> Bool +-- Returns True of anything *except* +-- a StrictHsBind (as above) or +-- a VarPat +-- In particular, returns True of a pattern binding with a compound pattern, like (I# x) +-- Looks through AbsBinds +looksLazyPatBind (PatBind { pat_lhs = p }) + = looksLazyLPat p +looksLazyPatBind (AbsBinds { abs_binds = binds }) + = anyBag (looksLazyPatBind . unLoc) binds +looksLazyPatBind _ + = False + +looksLazyLPat :: LPat (GhcPass p) -> Bool +looksLazyLPat = looksLazyPat . unLoc + +looksLazyPat :: Pat (GhcPass p) -> Bool +looksLazyPat (ParPat _ p) = looksLazyLPat p +looksLazyPat (AsPat _ _ p) = looksLazyLPat p +looksLazyPat (BangPat {}) = False +looksLazyPat (VarPat {}) = False +looksLazyPat (WildPat {}) = False +looksLazyPat _ = True + +isIrrefutableHsPat :: (OutputableBndrId (GhcPass p)) => LPat (GhcPass p) -> Bool +-- (isIrrefutableHsPat p) is true if matching against p cannot fail, +-- in the sense of falling through to the next pattern. +-- (NB: this is not quite the same as the (silly) defn +-- in 3.17.2 of the Haskell 98 report.) +-- +-- WARNING: isIrrefutableHsPat returns False if it's in doubt. +-- Specifically on a ConPatIn, which is what it sees for a +-- (LPat Name) in the renamer, it doesn't know the size of the +-- constructor family, so it returns False. Result: only +-- tuple patterns are considered irrefuable at the renamer stage. +-- +-- But if it returns True, the pattern is definitely irrefutable +isIrrefutableHsPat + = goL + where + goL = go . unLoc + + go (WildPat {}) = True + go (VarPat {}) = True + go (LazyPat {}) = True + go (BangPat _ pat) = goL pat + go (CoPat _ _ pat _) = go pat + go (ParPat _ pat) = goL pat + go (AsPat _ _ pat) = goL pat + go (ViewPat _ _ pat) = goL pat + go (SigPat _ pat _) = goL pat + go (TuplePat _ pats _) = all goL pats + go (SumPat {}) = False + -- See Note [Unboxed sum patterns aren't irrefutable] + go (ListPat {}) = False + + go (ConPatIn {}) = False -- Conservative + go (ConPatOut + { pat_con = (dL->L _ (RealDataCon con)) + , pat_args = details }) + = + isJust (tyConSingleDataCon_maybe (dataConTyCon con)) + -- NB: tyConSingleDataCon_maybe, *not* isProductTyCon, because + -- the latter is false of existentials. See #4439 + && all goL (hsConPatArgs details) + go (ConPatOut + { pat_con = (dL->L _ (PatSynCon _pat)) }) + = False -- Conservative + go (ConPatOut{}) = panic "ConPatOut:Impossible Match" -- due to #15884 + go (LitPat {}) = False + go (NPat {}) = False + go (NPlusKPat {}) = False + + -- We conservatively assume that no TH splices are irrefutable + -- since we cannot know until the splice is evaluated. + go (SplicePat {}) = False + + go (XPat {}) = False + +{- Note [Unboxed sum patterns aren't irrefutable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Unlike unboxed tuples, unboxed sums are *not* irrefutable when used as +patterns. A simple example that demonstrates this is from #14228: + + pattern Just' x = (# x | #) + pattern Nothing' = (# | () #) + + foo x = case x of + Nothing' -> putStrLn "nothing" + Just' -> putStrLn "just" + +In foo, the pattern Nothing' (that is, (# x | #)) is certainly not irrefutable, +as does not match an unboxed sum value of the same arity—namely, (# | y #) +(covered by Just'). In fact, no unboxed sum pattern is irrefutable, since the +minimum unboxed sum arity is 2. + +Failing to mark unboxed sum patterns as non-irrefutable would cause the Just' +case in foo to be unreachable, as GHC would mistakenly believe that Nothing' +is the only thing that could possibly be matched! +-} + +-- | @'patNeedsParens' p pat@ returns 'True' if the pattern @pat@ needs +-- parentheses under precedence @p@. +patNeedsParens :: PprPrec -> Pat p -> Bool +patNeedsParens p = go + where + go (NPlusKPat {}) = p > opPrec + go (SplicePat {}) = False + go (ConPatIn _ ds) = conPatNeedsParens p ds + go cp@(ConPatOut {}) = conPatNeedsParens p (pat_args cp) + go (SigPat {}) = p >= sigPrec + go (ViewPat {}) = True + go (CoPat _ _ p _) = go p + go (WildPat {}) = False + go (VarPat {}) = False + go (LazyPat {}) = False + go (BangPat {}) = False + go (ParPat {}) = False + go (AsPat {}) = False + go (TuplePat {}) = False + go (SumPat {}) = False + go (ListPat {}) = False + go (LitPat _ l) = hsLitNeedsParens p l + go (NPat _ lol _ _) = hsOverLitNeedsParens p (unLoc lol) + go (XPat {}) = True -- conservative default + +-- | @'conPatNeedsParens' p cp@ returns 'True' if the constructor patterns @cp@ +-- needs parentheses under precedence @p@. +conPatNeedsParens :: PprPrec -> HsConDetails a b -> Bool +conPatNeedsParens p = go + where + go (PrefixCon args) = p >= appPrec && not (null args) + go (InfixCon {}) = p >= opPrec + go (RecCon {}) = False + +-- | @'parenthesizePat' p pat@ checks if @'patNeedsParens' p pat@ is true, and +-- if so, surrounds @pat@ with a 'ParPat'. Otherwise, it simply returns @pat@. +parenthesizePat :: PprPrec -> LPat (GhcPass p) -> LPat (GhcPass p) +parenthesizePat p lpat@(dL->L loc pat) + | patNeedsParens p pat = cL loc (ParPat NoExt lpat) + | otherwise = lpat + +{- +% Collect all EvVars from all constructor patterns +-} + +-- May need to add more cases +collectEvVarsPats :: [Pat GhcTc] -> Bag EvVar +collectEvVarsPats = unionManyBags . map collectEvVarsPat + +collectEvVarsLPat :: LPat GhcTc -> Bag EvVar +collectEvVarsLPat = collectEvVarsPat . unLoc + +collectEvVarsPat :: Pat GhcTc -> Bag EvVar +collectEvVarsPat pat = + case pat of + LazyPat _ p -> collectEvVarsLPat p + AsPat _ _ p -> collectEvVarsLPat p + ParPat _ p -> collectEvVarsLPat p + BangPat _ p -> collectEvVarsLPat p + ListPat _ ps -> unionManyBags $ map collectEvVarsLPat ps + TuplePat _ ps _ -> unionManyBags $ map collectEvVarsLPat ps + SumPat _ p _ _ -> collectEvVarsLPat p + ConPatOut {pat_dicts = dicts, pat_args = args} + -> unionBags (listToBag dicts) + $ unionManyBags + $ map collectEvVarsLPat + $ hsConPatArgs args + SigPat _ p _ -> collectEvVarsLPat p + CoPat _ _ p _ -> collectEvVarsPat p + ConPatIn _ _ -> panic "foldMapPatBag: ConPatIn" + _other_pat -> emptyBag diff --git a/compiler/hsSyn/HsPat.hs-boot b/compiler/hsSyn/HsPat.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/hsSyn/HsPat.hs-boot @@ -0,0 +1,18 @@ +{-# LANGUAGE CPP, KindSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] + -- in module PlaceHolder +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE TypeFamilies #-} + +module HsPat where + +import Outputable +import HsExtension ( OutputableBndrId, GhcPass ) + +type role Pat nominal +data Pat (i :: *) +type LPat i = Pat i + +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (Pat p) diff --git a/compiler/hsSyn/HsSyn.hs b/compiler/hsSyn/HsSyn.hs new file mode 100644 --- /dev/null +++ b/compiler/hsSyn/HsSyn.hs @@ -0,0 +1,153 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section{Haskell abstract syntax definition} + +This module glues together the pieces of the Haskell abstract syntax, +which is declared in the various \tr{Hs*} modules. This module, +therefore, is almost nothing but re-exporting. +-} + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] + -- in module PlaceHolder +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} -- For deriving instance Data + +module HsSyn ( + module HsBinds, + module HsDecls, + module HsExpr, + module HsImpExp, + module HsLit, + module HsPat, + module HsTypes, + module HsUtils, + module HsDoc, + module PlaceHolder, + module HsExtension, + Fixity, + + HsModule(..), +) where + +-- friends: +import GhcPrelude + +import HsDecls +import HsBinds +import HsExpr +import HsImpExp +import HsLit +import PlaceHolder +import HsExtension +import HsPat +import HsTypes +import BasicTypes ( Fixity, WarningTxt ) +import HsUtils +import HsDoc +import HsInstances () + +-- others: +import Outputable +import SrcLoc +import Module ( ModuleName ) + +-- libraries: +import Data.Data hiding ( Fixity ) + +-- | Haskell Module +-- +-- All we actually declare here is the top-level structure for a module. +data HsModule pass + = HsModule { + hsmodName :: Maybe (Located ModuleName), + -- ^ @Nothing@: \"module X where\" is omitted (in which case the next + -- field is Nothing too) + hsmodExports :: Maybe (Located [LIE pass]), + -- ^ Export list + -- + -- - @Nothing@: export list omitted, so export everything + -- + -- - @Just []@: export /nothing/ + -- + -- - @Just [...]@: as you would expect... + -- + -- + -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen' + -- ,'ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + hsmodImports :: [LImportDecl pass], + -- ^ We snaffle interesting stuff out of the imported interfaces early + -- on, adding that info to TyDecls/etc; so this list is often empty, + -- downstream. + hsmodDecls :: [LHsDecl pass], + -- ^ Type, class, value, and interface signature decls + hsmodDeprecMessage :: Maybe (Located WarningTxt), + -- ^ reason\/explanation for warning/deprecation of this module + -- + -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen' + -- ,'ApiAnnotation.AnnClose' + -- + + -- For details on above see note [Api annotations] in ApiAnnotation + hsmodHaddockModHeader :: Maybe LHsDocString + -- ^ Haddock module info and description, unparsed + -- + -- - 'ApiAnnotation.AnnKeywordId's : 'ApiAnnotation.AnnOpen' + -- ,'ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + } + -- ^ 'ApiAnnotation.AnnKeywordId's + -- + -- - 'ApiAnnotation.AnnModule','ApiAnnotation.AnnWhere' + -- + -- - 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnSemi', + -- 'ApiAnnotation.AnnClose' for explicit braces and semi around + -- hsmodImports,hsmodDecls if this style is used. + + -- For details on above see note [Api annotations] in ApiAnnotation +-- deriving instance (DataIdLR name name) => Data (HsModule name) +deriving instance Data (HsModule GhcPs) +deriving instance Data (HsModule GhcRn) +deriving instance Data (HsModule GhcTc) + +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsModule p) where + + ppr (HsModule Nothing _ imports decls _ mbDoc) + = pp_mb mbDoc $$ pp_nonnull imports + $$ pp_nonnull decls + + ppr (HsModule (Just name) exports imports decls deprec mbDoc) + = vcat [ + pp_mb mbDoc, + case exports of + Nothing -> pp_header (text "where") + Just es -> vcat [ + pp_header lparen, + nest 8 (fsep (punctuate comma (map ppr (unLoc es)))), + nest 4 (text ") where") + ], + pp_nonnull imports, + pp_nonnull decls + ] + where + pp_header rest = case deprec of + Nothing -> pp_modname <+> rest + Just d -> vcat [ pp_modname, ppr d, rest ] + + pp_modname = text "module" <+> ppr name + +pp_mb :: Outputable t => Maybe t -> SDoc +pp_mb (Just x) = ppr x +pp_mb Nothing = empty + +pp_nonnull :: Outputable t => [t] -> SDoc +pp_nonnull [] = empty +pp_nonnull xs = vcat (map ppr xs) diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs new file mode 100644 --- /dev/null +++ b/compiler/hsSyn/HsTypes.hs @@ -0,0 +1,1663 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +HsTypes: Abstract syntax: user-defined types +-} + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] + -- in module PlaceHolder +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} + +module HsTypes ( + HsType(..), NewHsTypeX(..), LHsType, HsKind, LHsKind, + HsTyVarBndr(..), LHsTyVarBndr, ForallVisFlag(..), + LHsQTyVars(..), + HsImplicitBndrs(..), + HsWildCardBndrs(..), + LHsSigType, LHsSigWcType, LHsWcType, + HsTupleSort(..), + HsContext, LHsContext, noLHsContext, + HsTyLit(..), + HsIPName(..), hsIPNameFS, + HsArg(..), numVisibleArgs, + LHsTypeArg, + + LBangType, BangType, + HsSrcBang(..), HsImplBang(..), + SrcStrictness(..), SrcUnpackedness(..), + getBangType, getBangStrictness, + + ConDeclField(..), LConDeclField, pprConDeclFields, + + HsConDetails(..), + + FieldOcc(..), LFieldOcc, mkFieldOcc, + AmbiguousFieldOcc(..), mkAmbiguousFieldOcc, + rdrNameAmbiguousFieldOcc, selectorAmbiguousFieldOcc, + unambiguousFieldOcc, ambiguousFieldOcc, + + mkAnonWildCardTy, pprAnonWildCard, + + mkHsImplicitBndrs, mkHsWildCardBndrs, hsImplicitBody, + mkEmptyImplicitBndrs, mkEmptyWildCardBndrs, + mkHsQTvs, hsQTvExplicit, emptyLHsQTvs, isEmptyLHsQTvs, + isHsKindedTyVar, hsTvbAllKinded, isLHsForAllTy, + hsScopedTvs, hsWcScopedTvs, dropWildCards, + hsTyVarName, hsAllLTyVarNames, hsLTyVarLocNames, + hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsExplicitLTyVarNames, + splitLHsInstDeclTy, getLHsInstDeclHead, getLHsInstDeclClass_maybe, + splitLHsPatSynTy, + splitLHsForAllTy, splitLHsForAllTyInvis, + splitLHsQualTy, splitLHsSigmaTy, splitLHsSigmaTyInvis, + splitHsFunType, hsTyGetAppHead_maybe, + mkHsOpTy, mkHsAppTy, mkHsAppTys, mkHsAppKindTy, + ignoreParens, hsSigType, hsSigWcType, + hsLTyVarBndrToType, hsLTyVarBndrsToTypes, + + -- Printing + pprHsType, pprHsForAll, pprHsForAllExtra, pprHsExplicitForAll, + pprLHsContext, + hsTypeNeedsParens, parenthesizeHsType, parenthesizeHsContext + ) where + +import GhcPrelude + +import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice ) + +import HsExtension +import HsLit () -- for instances + +import Id ( Id ) +import Name( Name ) +import RdrName ( RdrName ) +import DataCon( HsSrcBang(..), HsImplBang(..), + SrcStrictness(..), SrcUnpackedness(..) ) +import TysPrim( funTyConName ) +import Type +import HsDoc +import BasicTypes +import SrcLoc +import Outputable +import FastString +import Maybes( isJust ) +import Util ( count ) + +import Data.Data hiding ( Fixity, Prefix, Infix ) + +{- +************************************************************************ +* * +\subsection{Bang annotations} +* * +************************************************************************ +-} + +-- | Located Bang Type +type LBangType pass = Located (BangType pass) + +-- | Bang Type +type BangType pass = HsType pass -- Bangs are in the HsType data type + +getBangType :: LHsType a -> LHsType a +getBangType (L _ (HsBangTy _ _ ty)) = ty +getBangType ty = ty + +getBangStrictness :: LHsType a -> HsSrcBang +getBangStrictness (L _ (HsBangTy _ s _)) = s +getBangStrictness _ = (HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict) + +{- +************************************************************************ +* * +\subsection{Data types} +* * +************************************************************************ + +This is the syntax for types as seen in type signatures. + +Note [HsBSig binder lists] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a binder (or pattern) decorated with a type or kind, + \ (x :: a -> a). blah + forall (a :: k -> *) (b :: k). blah +Then we use a LHsBndrSig on the binder, so that the +renamer can decorate it with the variables bound +by the pattern ('a' in the first example, 'k' in the second), +assuming that neither of them is in scope already +See also Note [Kind and type-variable binders] in RnTypes + +Note [HsType binders] +~~~~~~~~~~~~~~~~~~~~~ +The system for recording type and kind-variable binders in HsTypes +is a bit complicated. Here's how it works. + +* In a HsType, + HsForAllTy represents an /explicit, user-written/ 'forall' + e.g. forall a b. {...} or + forall a b -> {...} + HsQualTy represents an /explicit, user-written/ context + e.g. (Eq a, Show a) => ... + The context can be empty if that's what the user wrote + These constructors represent what the user wrote, no more + and no less. + +* The ForallVisFlag field of HsForAllTy represents whether a forall is + invisible (e.g., forall a b. {...}, with a dot) or visible + (e.g., forall a b -> {...}, with an arrow). + +* HsTyVarBndr describes a quantified type variable written by the + user. For example + f :: forall a (b :: *). blah + here 'a' and '(b::*)' are each a HsTyVarBndr. A HsForAllTy has + a list of LHsTyVarBndrs. + +* HsImplicitBndrs is a wrapper that gives the implicitly-quantified + kind and type variables of the wrapped thing. It is filled in by + the renamer. For example, if the user writes + f :: a -> a + the HsImplicitBinders binds the 'a' (not a HsForAllTy!). + NB: this implicit quantification is purely lexical: we bind any + type or kind variables that are not in scope. The type checker + may subsequently quantify over further kind variables. + +* HsWildCardBndrs is a wrapper that binds the wildcard variables + of the wrapped thing. It is filled in by the renamer + f :: _a -> _ + The enclosing HsWildCardBndrs binds the wildcards _a and _. + +* The explicit presence of these wrappers specifies, in the HsSyn, + exactly where implicit quantification is allowed, and where + wildcards are allowed. + +* LHsQTyVars is used in data/class declarations, where the user gives + explicit *type* variable bindings, but we need to implicitly bind + *kind* variables. For example + class C (a :: k -> *) where ... + The 'k' is implicitly bound in the hsq_tvs field of LHsQTyVars + +Note [The wildcard story for types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Types can have wildcards in them, to support partial type signatures, +like f :: Int -> (_ , _a) -> _a + +A wildcard in a type can be + + * An anonymous wildcard, + written '_' + In HsType this is represented by HsWildCardTy. + The renamer leaves it untouched, and it is later given fresh meta tyvars in + the typechecker. + + * A named wildcard, + written '_a', '_foo', etc + In HsType this is represented by (HsTyVar "_a") + i.e. a perfectly ordinary type variable that happens + to start with an underscore + +Note carefully: + +* When NamedWildCards is off, type variables that start with an + underscore really /are/ ordinary type variables. And indeed, even + when NamedWildCards is on you can bind _a explicitly as an ordinary + type variable: + data T _a _b = MkT _b _a + Or even: + f :: forall _a. _a -> _b + Here _a is an ordinary forall'd binder, but (With NamedWildCards) + _b is a named wildcard. (See the comments in #10982) + +* Named wildcards are bound by the HsWildCardBndrs construct, which wraps + types that are allowed to have wildcards. Unnamed wildcards however are left + unchanged until typechecking, where we give them fresh wild tyavrs and + determine whether or not to emit hole constraints on each wildcard + (we don't if it's a visible type/kind argument or a type family pattern). + See related notes Note [Wildcards in visible kind application] + and Note [Wildcards in visible type application] in TcHsType.hs + +* After type checking is done, we report what types the wildcards + got unified with. + +Note [Ordering of implicit variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Since the advent of -XTypeApplications, GHC makes promises about the ordering +of implicit variable quantification. Specifically, we offer that implicitly +quantified variables (such as those in const :: a -> b -> a, without a `forall`) +will occur in left-to-right order of first occurrence. Here are a few examples: + + const :: a -> b -> a -- forall a b. ... + f :: Eq a => b -> a -> a -- forall a b. ... contexts are included + + type a <-< b = b -> a + g :: a <-< b -- forall a b. ... type synonyms matter + + class Functor f where + fmap :: (a -> b) -> f a -> f b -- forall f a b. ... + -- The f is quantified by the class, so only a and b are considered in fmap + +This simple story is complicated by the possibility of dependency: all variables +must come after any variables mentioned in their kinds. + + typeRep :: Typeable a => TypeRep (a :: k) -- forall k a. ... + +The k comes first because a depends on k, even though the k appears later than +the a in the code. Thus, GHC does a *stable topological sort* on the variables. +By "stable", we mean that any two variables who do not depend on each other +preserve their existing left-to-right ordering. + +Implicitly bound variables are collected by the extract- family of functions +(extractHsTysRdrTyVars, extractHsTyVarBndrsKVs, etc.) in RnTypes. +These functions thus promise to keep left-to-right ordering. +Look for pointers to this note to see the places where the action happens. + +Note that we also maintain this ordering in kind signatures. Even though +there's no visible kind application (yet), having implicit variables be +quantified in left-to-right order in kind signatures is nice since: + +* It's consistent with the treatment for type signatures. +* It can affect how types are displayed with -fprint-explicit-kinds (see + #15568 for an example), which is a situation where knowing the order in + which implicit variables are quantified can be useful. +* In the event that visible kind application is implemented, the order in + which we would expect implicit variables to be ordered in kinds will have + already been established. +-} + +-- | Located Haskell Context +type LHsContext pass = Located (HsContext pass) + -- ^ 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnUnit' + -- For details on above see note [Api annotations] in ApiAnnotation + +noLHsContext :: LHsContext pass +-- Use this when there is no context in the original program +-- It would really be more kosher to use a Maybe, to distinguish +-- class () => C a where ... +-- from +-- class C a where ... +noLHsContext = noLoc [] + +-- | Haskell Context +type HsContext pass = [LHsType pass] + +-- | Located Haskell Type +type LHsType pass = Located (HsType pass) + -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' when + -- in a list + + -- For details on above see note [Api annotations] in ApiAnnotation + +-- | Haskell Kind +type HsKind pass = HsType pass + +-- | Located Haskell Kind +type LHsKind pass = Located (HsKind pass) + -- ^ 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon' + + -- For details on above see note [Api annotations] in ApiAnnotation + +-------------------------------------------------- +-- LHsQTyVars +-- The explicitly-quantified binders in a data/type declaration + +-- | Located Haskell Type Variable Binder +type LHsTyVarBndr pass = Located (HsTyVarBndr pass) + -- See Note [HsType binders] + +-- | Located Haskell Quantified Type Variables +data LHsQTyVars pass -- See Note [HsType binders] + = HsQTvs { hsq_ext :: XHsQTvs pass + + , hsq_explicit :: [LHsTyVarBndr pass] + -- Explicit variables, written by the user + -- See Note [HsForAllTy tyvar binders] + } + | XLHsQTyVars (XXLHsQTyVars pass) + +type HsQTvsRn = [Name] -- Implicit variables + -- For example, in data T (a :: k1 -> k2) = ... + -- the 'a' is explicit while 'k1', 'k2' are implicit + +type instance XHsQTvs GhcPs = NoExt +type instance XHsQTvs GhcRn = HsQTvsRn +type instance XHsQTvs GhcTc = HsQTvsRn + +type instance XXLHsQTyVars (GhcPass _) = NoExt + +mkHsQTvs :: [LHsTyVarBndr GhcPs] -> LHsQTyVars GhcPs +mkHsQTvs tvs = HsQTvs { hsq_ext = noExt, hsq_explicit = tvs } + +hsQTvExplicit :: LHsQTyVars pass -> [LHsTyVarBndr pass] +hsQTvExplicit = hsq_explicit + +emptyLHsQTvs :: LHsQTyVars GhcRn +emptyLHsQTvs = HsQTvs { hsq_ext = [], hsq_explicit = [] } + +isEmptyLHsQTvs :: LHsQTyVars GhcRn -> Bool +isEmptyLHsQTvs (HsQTvs { hsq_ext = imp, hsq_explicit = exp }) + = null imp && null exp +isEmptyLHsQTvs _ = False + +------------------------------------------------ +-- HsImplicitBndrs +-- Used to quantify the implicit binders of a type +-- * Implicit binders of a type signature (LHsSigType/LHsSigWcType) +-- * Patterns in a type/data family instance (HsTyPats) + +-- | Haskell Implicit Binders +data HsImplicitBndrs pass thing -- See Note [HsType binders] + = HsIB { hsib_ext :: XHsIB pass thing -- after renamer: [Name] + -- Implicitly-bound kind & type vars + -- Order is important; see + -- Note [Ordering of implicit variables] + -- in RnTypes + + , hsib_body :: thing -- Main payload (type or list of types) + } + | XHsImplicitBndrs (XXHsImplicitBndrs pass thing) + +type instance XHsIB GhcPs _ = NoExt +type instance XHsIB GhcRn _ = [Name] +type instance XHsIB GhcTc _ = [Name] + +type instance XXHsImplicitBndrs (GhcPass _) _ = NoExt + +-- | Haskell Wildcard Binders +data HsWildCardBndrs pass thing + -- See Note [HsType binders] + -- See Note [The wildcard story for types] + = HsWC { hswc_ext :: XHsWC pass thing + -- after the renamer + -- Wild cards, only named + -- See Note [Wildcards in visible kind application] + + , hswc_body :: thing + -- Main payload (type or list of types) + -- If there is an extra-constraints wildcard, + -- it's still there in the hsc_body. + } + | XHsWildCardBndrs (XXHsWildCardBndrs pass thing) + +type instance XHsWC GhcPs b = NoExt +type instance XHsWC GhcRn b = [Name] +type instance XHsWC GhcTc b = [Name] + +type instance XXHsWildCardBndrs (GhcPass _) b = NoExt + +-- | Located Haskell Signature Type +type LHsSigType pass = HsImplicitBndrs pass (LHsType pass) -- Implicit only + +-- | Located Haskell Wildcard Type +type LHsWcType pass = HsWildCardBndrs pass (LHsType pass) -- Wildcard only + +-- | Located Haskell Signature Wildcard Type +type LHsSigWcType pass = HsWildCardBndrs pass (LHsSigType pass) -- Both + +-- See Note [Representing type signatures] + +hsImplicitBody :: HsImplicitBndrs pass thing -> thing +hsImplicitBody (HsIB { hsib_body = body }) = body +hsImplicitBody (XHsImplicitBndrs _) = panic "hsImplicitBody" + +hsSigType :: LHsSigType pass -> LHsType pass +hsSigType = hsImplicitBody + +hsSigWcType :: LHsSigWcType pass -> LHsType pass +hsSigWcType sig_ty = hsib_body (hswc_body sig_ty) + +dropWildCards :: LHsSigWcType pass -> LHsSigType pass +-- Drop the wildcard part of a LHsSigWcType +dropWildCards sig_ty = hswc_body sig_ty + +{- Note [Representing type signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +HsSigType is used to represent an explicit user type signature +such as f :: a -> a + or g (x :: a -> a) = x + +A HsSigType is just a HsImplicitBndrs wrapping a LHsType. + * The HsImplicitBndrs binds the /implicitly/ quantified tyvars + * The LHsType binds the /explicitly/ quantified tyvars + +E.g. For a signature like + f :: forall (a::k). blah +we get + HsIB { hsib_vars = [k] + , hsib_body = HsForAllTy { hst_bndrs = [(a::*)] + , hst_body = blah } +The implicit kind variable 'k' is bound by the HsIB; +the explicitly forall'd tyvar 'a' is bound by the HsForAllTy +-} + +mkHsImplicitBndrs :: thing -> HsImplicitBndrs GhcPs thing +mkHsImplicitBndrs x = HsIB { hsib_ext = noExt + , hsib_body = x } + +mkHsWildCardBndrs :: thing -> HsWildCardBndrs GhcPs thing +mkHsWildCardBndrs x = HsWC { hswc_body = x + , hswc_ext = noExt } + +-- Add empty binders. This is a bit suspicious; what if +-- the wrapped thing had free type variables? +mkEmptyImplicitBndrs :: thing -> HsImplicitBndrs GhcRn thing +mkEmptyImplicitBndrs x = HsIB { hsib_ext = [] + , hsib_body = x } + +mkEmptyWildCardBndrs :: thing -> HsWildCardBndrs GhcRn thing +mkEmptyWildCardBndrs x = HsWC { hswc_body = x + , hswc_ext = [] } + + +-------------------------------------------------- +-- | These names are used early on to store the names of implicit +-- parameters. They completely disappear after type-checking. +newtype HsIPName = HsIPName FastString + deriving( Eq, Data ) + +hsIPNameFS :: HsIPName -> FastString +hsIPNameFS (HsIPName n) = n + +instance Outputable HsIPName where + ppr (HsIPName n) = char '?' <> ftext n -- Ordinary implicit parameters + +instance OutputableBndr HsIPName where + pprBndr _ n = ppr n -- Simple for now + pprInfixOcc n = ppr n + pprPrefixOcc n = ppr n + +-------------------------------------------------- + +-- | Haskell Type Variable Binder +data HsTyVarBndr pass + = UserTyVar -- no explicit kinding + (XUserTyVar pass) + (Located (IdP pass)) + -- See Note [Located RdrNames] in HsExpr + | KindedTyVar + (XKindedTyVar pass) + (Located (IdP pass)) + (LHsKind pass) -- The user-supplied kind signature + -- ^ + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', + -- 'ApiAnnotation.AnnDcolon', 'ApiAnnotation.AnnClose' + + -- For details on above see note [Api annotations] in ApiAnnotation + + | XTyVarBndr + (XXTyVarBndr pass) + +type instance XUserTyVar (GhcPass _) = NoExt +type instance XKindedTyVar (GhcPass _) = NoExt +type instance XXTyVarBndr (GhcPass _) = NoExt + +-- | Does this 'HsTyVarBndr' come with an explicit kind annotation? +isHsKindedTyVar :: HsTyVarBndr pass -> Bool +isHsKindedTyVar (UserTyVar {}) = False +isHsKindedTyVar (KindedTyVar {}) = True +isHsKindedTyVar (XTyVarBndr{}) = panic "isHsKindedTyVar" + +-- | Do all type variables in this 'LHsQTyVars' come with kind annotations? +hsTvbAllKinded :: LHsQTyVars pass -> Bool +hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvExplicit + +-- | Haskell Type +data HsType pass + = HsForAllTy -- See Note [HsType binders] + { hst_xforall :: XForAllTy pass + , hst_fvf :: ForallVisFlag -- Is this `forall a -> {...}` or + -- `forall a. {...}`? + , hst_bndrs :: [LHsTyVarBndr pass] + -- Explicit, user-supplied 'forall a b c' + , hst_body :: LHsType pass -- body type + } + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnForall', + -- 'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow' + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsQualTy -- See Note [HsType binders] + { hst_xqual :: XQualTy pass + , hst_ctxt :: LHsContext pass -- Context C => blah + , hst_body :: LHsType pass } + + | HsTyVar (XTyVar pass) + PromotionFlag -- Whether explicitly promoted, + -- for the pretty printer + (Located (IdP pass)) + -- Type variable, type constructor, or data constructor + -- see Note [Promotions (HsTyVar)] + -- See Note [Located RdrNames] in HsExpr + -- ^ - 'ApiAnnotation.AnnKeywordId' : None + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsAppTy (XAppTy pass) + (LHsType pass) + (LHsType pass) + -- ^ - 'ApiAnnotation.AnnKeywordId' : None + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsAppKindTy (XAppKindTy pass) -- type level type app + (LHsType pass) + (LHsKind pass) + + | HsFunTy (XFunTy pass) + (LHsType pass) -- function type + (LHsType pass) + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow', + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsListTy (XListTy pass) + (LHsType pass) -- Element type + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'['@, + -- 'ApiAnnotation.AnnClose' @']'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsTupleTy (XTupleTy pass) + HsTupleSort + [LHsType pass] -- Element types (length gives arity) + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(' or '(#'@, + -- 'ApiAnnotation.AnnClose' @')' or '#)'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsSumTy (XSumTy pass) + [LHsType pass] -- Element types (length gives arity) + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'(#'@, + -- 'ApiAnnotation.AnnClose' '#)'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsOpTy (XOpTy pass) + (LHsType pass) (Located (IdP pass)) (LHsType pass) + -- ^ - 'ApiAnnotation.AnnKeywordId' : None + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsParTy (XParTy pass) + (LHsType pass) -- See Note [Parens in HsSyn] in HsExpr + -- Parenthesis preserved for the precedence re-arrangement in RnTypes + -- It's important that a * (b + c) doesn't get rearranged to (a*b) + c! + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, + -- 'ApiAnnotation.AnnClose' @')'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsIParamTy (XIParamTy pass) + (Located HsIPName) -- (?x :: ty) + (LHsType pass) -- Implicit parameters as they occur in + -- contexts + -- ^ + -- > (?x :: ty) + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon' + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsStarTy (XStarTy pass) + Bool -- Is this the Unicode variant? + -- Note [HsStarTy] + -- ^ - 'ApiAnnotation.AnnKeywordId' : None + + | HsKindSig (XKindSig pass) + (LHsType pass) -- (ty :: kind) + (LHsKind pass) -- A type with a kind signature + -- ^ + -- > (ty :: kind) + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'('@, + -- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnClose' @')'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsSpliceTy (XSpliceTy pass) + (HsSplice pass) -- Includes quasi-quotes + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'$('@, + -- 'ApiAnnotation.AnnClose' @')'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsDocTy (XDocTy pass) + (LHsType pass) LHsDocString -- A documented type + -- ^ - 'ApiAnnotation.AnnKeywordId' : None + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsBangTy (XBangTy pass) + HsSrcBang (LHsType pass) -- Bang-style type annotations + -- ^ - 'ApiAnnotation.AnnKeywordId' : + -- 'ApiAnnotation.AnnOpen' @'{-\# UNPACK' or '{-\# NOUNPACK'@, + -- 'ApiAnnotation.AnnClose' @'#-}'@ + -- 'ApiAnnotation.AnnBang' @\'!\'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsRecTy (XRecTy pass) + [LConDeclField pass] -- Only in data type declarations + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{'@, + -- 'ApiAnnotation.AnnClose' @'}'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + + -- | HsCoreTy (XCoreTy pass) Type -- An escape hatch for tunnelling a *closed* + -- -- Core Type through HsSyn. + -- -- ^ - 'ApiAnnotation.AnnKeywordId' : None + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsExplicitListTy -- A promoted explicit list + (XExplicitListTy pass) + PromotionFlag -- whether explcitly promoted, for pretty printer + [LHsType pass] + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @"'["@, + -- 'ApiAnnotation.AnnClose' @']'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsExplicitTupleTy -- A promoted explicit tuple + (XExplicitTupleTy pass) + [LHsType pass] + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @"'("@, + -- 'ApiAnnotation.AnnClose' @')'@ + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsTyLit (XTyLit pass) HsTyLit -- A promoted numeric literal. + -- ^ - 'ApiAnnotation.AnnKeywordId' : None + + -- For details on above see note [Api annotations] in ApiAnnotation + + | HsWildCardTy (XWildCardTy pass) -- A type wildcard + -- See Note [The wildcard story for types] + -- ^ - 'ApiAnnotation.AnnKeywordId' : None + + -- For details on above see note [Api annotations] in ApiAnnotation + + -- For adding new constructors via Trees that Grow + | XHsType + (XXType pass) + +data NewHsTypeX + = NHsCoreTy Type -- An escape hatch for tunnelling a *closed* + -- Core Type through HsSyn. + deriving Data + -- ^ - 'ApiAnnotation.AnnKeywordId' : None + +instance Outputable NewHsTypeX where + ppr (NHsCoreTy ty) = ppr ty + +type instance XForAllTy (GhcPass _) = NoExt +type instance XQualTy (GhcPass _) = NoExt +type instance XTyVar (GhcPass _) = NoExt +type instance XAppTy (GhcPass _) = NoExt +type instance XFunTy (GhcPass _) = NoExt +type instance XListTy (GhcPass _) = NoExt +type instance XTupleTy (GhcPass _) = NoExt +type instance XSumTy (GhcPass _) = NoExt +type instance XOpTy (GhcPass _) = NoExt +type instance XParTy (GhcPass _) = NoExt +type instance XIParamTy (GhcPass _) = NoExt +type instance XStarTy (GhcPass _) = NoExt +type instance XKindSig (GhcPass _) = NoExt + +type instance XAppKindTy (GhcPass _) = SrcSpan -- Where the `@` lives + +type instance XSpliceTy GhcPs = NoExt +type instance XSpliceTy GhcRn = NoExt +type instance XSpliceTy GhcTc = Kind + +type instance XDocTy (GhcPass _) = NoExt +type instance XBangTy (GhcPass _) = NoExt +type instance XRecTy (GhcPass _) = NoExt + +type instance XExplicitListTy GhcPs = NoExt +type instance XExplicitListTy GhcRn = NoExt +type instance XExplicitListTy GhcTc = Kind + +type instance XExplicitTupleTy GhcPs = NoExt +type instance XExplicitTupleTy GhcRn = NoExt +type instance XExplicitTupleTy GhcTc = [Kind] + +type instance XTyLit (GhcPass _) = NoExt + +type instance XWildCardTy (GhcPass _) = NoExt + +type instance XXType (GhcPass _) = NewHsTypeX + + +-- Note [Literal source text] in BasicTypes for SourceText fields in +-- the following +-- | Haskell Type Literal +data HsTyLit + = HsNumTy SourceText Integer + | HsStrTy SourceText FastString + deriving Data + + +{- +Note [HsForAllTy tyvar binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +After parsing: + * Implicit => empty + Explicit => the variables the user wrote + +After renaming + * Implicit => the *type* variables free in the type + Explicit => the variables the user wrote (renamed) + +Qualified currently behaves exactly as Implicit, +but it is deprecated to use it for implicit quantification. +In this case, GHC 7.10 gives a warning; see +Note [Context quantification] in RnTypes, and #4426. +In GHC 8.0, Qualified will no longer bind variables +and this will become an error. + +The kind variables bound in the hsq_implicit field come both + a) from the kind signatures on the kind vars (eg k1) + b) from the scope of the forall (eg k2) +Example: f :: forall (a::k1) b. T a (b::k2) + + +Note [Unit tuples] +~~~~~~~~~~~~~~~~~~ +Consider the type + type instance F Int = () +We want to parse that "()" + as HsTupleTy HsBoxedOrConstraintTuple [], +NOT as HsTyVar unitTyCon + +Why? Because F might have kind (* -> Constraint), so we when parsing we +don't know if that tuple is going to be a constraint tuple or an ordinary +unit tuple. The HsTupleSort flag is specifically designed to deal with +that, but it has to work for unit tuples too. + +Note [Promotions (HsTyVar)] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +HsTyVar: A name in a type or kind. + Here are the allowed namespaces for the name. + In a type: + Var: not allowed + Data: promoted data constructor + Tv: type variable + TcCls before renamer: type constructor, class constructor, or promoted data constructor + TcCls after renamer: type constructor or class constructor + In a kind: + Var, Data: not allowed + Tv: kind variable + TcCls: kind constructor or promoted type constructor + + The 'Promoted' field in an HsTyVar captures whether the type was promoted in + the source code by prefixing an apostrophe. + +Note [HsStarTy] +~~~~~~~~~~~~~~~ +When the StarIsType extension is enabled, we want to treat '*' and its Unicode +variant identically to 'Data.Kind.Type'. Unfortunately, doing so in the parser +would mean that when we pretty-print it back, we don't know whether the user +wrote '*' or 'Type', and lose the parse/ppr roundtrip property. + +As a workaround, we parse '*' as HsStarTy (if it stands for 'Data.Kind.Type') +and then desugar it to 'Data.Kind.Type' in the typechecker (see tc_hs_type). +When '*' is a regular type operator (StarIsType is disabled), HsStarTy is not +involved. + + +Note [Promoted lists and tuples] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Notice the difference between + HsListTy HsExplicitListTy + HsTupleTy HsExplicitListTupleTy + +E.g. f :: [Int] HsListTy + + g3 :: T '[] All these use + g2 :: T '[True] HsExplicitListTy + g1 :: T '[True,False] + g1a :: T [True,False] (can omit ' where unambiguous) + + kind of T :: [Bool] -> * This kind uses HsListTy! + +E.g. h :: (Int,Bool) HsTupleTy; f is a pair + k :: S '(True,False) HsExplicitTypleTy; S is indexed by + a type-level pair of booleans + kind of S :: (Bool,Bool) -> * This kind uses HsExplicitTupleTy + +Note [Distinguishing tuple kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Apart from promotion, tuples can have one of three different kinds: + + x :: (Int, Bool) -- Regular boxed tuples + f :: Int# -> (# Int#, Int# #) -- Unboxed tuples + g :: (Eq a, Ord a) => a -- Constraint tuples + +For convenience, internally we use a single constructor for all of these, +namely HsTupleTy, but keep track of the tuple kind (in the first argument to +HsTupleTy, a HsTupleSort). We can tell if a tuple is unboxed while parsing, +because of the #. However, with -XConstraintKinds we can only distinguish +between constraint and boxed tuples during type checking, in general. Hence the +four constructors of HsTupleSort: + + HsUnboxedTuple -> Produced by the parser + HsBoxedTuple -> Certainly a boxed tuple + HsConstraintTuple -> Certainly a constraint tuple + HsBoxedOrConstraintTuple -> Could be a boxed or a constraint + tuple. Produced by the parser only, + disappears after type checking +-} + +-- | Haskell Tuple Sort +data HsTupleSort = HsUnboxedTuple + | HsBoxedTuple + | HsConstraintTuple + | HsBoxedOrConstraintTuple + deriving Data + +-- | Located Constructor Declaration Field +type LConDeclField pass = Located (ConDeclField pass) + -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' when + -- in a list + + -- For details on above see note [Api annotations] in ApiAnnotation + +-- | Constructor Declaration Field +data ConDeclField pass -- Record fields have Haddoc docs on them + = ConDeclField { cd_fld_ext :: XConDeclField pass, + cd_fld_names :: [LFieldOcc pass], + -- ^ See Note [ConDeclField passs] + cd_fld_type :: LBangType pass, + cd_fld_doc :: Maybe LHsDocString } + -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon' + + -- For details on above see note [Api annotations] in ApiAnnotation + | XConDeclField (XXConDeclField pass) + +type instance XConDeclField (GhcPass _) = NoExt +type instance XXConDeclField (GhcPass _) = NoExt + +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (ConDeclField p) where + ppr (ConDeclField _ fld_n fld_ty _) = ppr fld_n <+> dcolon <+> ppr fld_ty + ppr (XConDeclField x) = ppr x + +-- HsConDetails is used for patterns/expressions *and* for data type +-- declarations +-- | Haskell Constructor Details +data HsConDetails arg rec + = PrefixCon [arg] -- C p1 p2 p3 + | RecCon rec -- C { x = p1, y = p2 } + | InfixCon arg arg -- p1 `C` p2 + deriving Data + +instance (Outputable arg, Outputable rec) + => Outputable (HsConDetails arg rec) where + ppr (PrefixCon args) = text "PrefixCon" <+> ppr args + ppr (RecCon rec) = text "RecCon:" <+> ppr rec + ppr (InfixCon l r) = text "InfixCon:" <+> ppr [l, r] + +{- +Note [ConDeclField passs] +~~~~~~~~~~~~~~~~~~~~~~~~~ + +A ConDeclField contains a list of field occurrences: these always +include the field label as the user wrote it. After the renamer, it +will additionally contain the identity of the selector function in the +second component. + +Due to DuplicateRecordFields, the OccName of the selector function +may have been mangled, which is why we keep the original field label +separately. For example, when DuplicateRecordFields is enabled + + data T = MkT { x :: Int } + +gives + + ConDeclField { cd_fld_names = [L _ (FieldOcc "x" $sel:x:MkT)], ... }. +-} + +----------------------- +-- A valid type must have a for-all at the top of the type, or of the fn arg +-- types + +--------------------- +hsWcScopedTvs :: LHsSigWcType GhcRn -> [Name] +-- Get the lexically-scoped type variables of a HsSigType +-- - the explicitly-given forall'd type variables +-- - the implicitly-bound kind variables +-- - the named wildcars; see Note [Scoping of named wildcards] +-- because they scope in the same way +hsWcScopedTvs sig_ty + | HsWC { hswc_ext = nwcs, hswc_body = sig_ty1 } <- sig_ty + , HsIB { hsib_ext = vars + , hsib_body = sig_ty2 } <- sig_ty1 + = case sig_ty2 of + L _ (HsForAllTy { hst_bndrs = tvs }) -> vars ++ nwcs ++ + hsLTyVarNames tvs + -- include kind variables only if the type is headed by forall + -- (this is consistent with GHC 7 behaviour) + _ -> nwcs +hsWcScopedTvs (HsWC _ (XHsImplicitBndrs _)) = panic "hsWcScopedTvs" +hsWcScopedTvs (XHsWildCardBndrs _) = panic "hsWcScopedTvs" + +hsScopedTvs :: LHsSigType GhcRn -> [Name] +-- Same as hsWcScopedTvs, but for a LHsSigType +hsScopedTvs sig_ty + | HsIB { hsib_ext = vars + , hsib_body = sig_ty2 } <- sig_ty + , L _ (HsForAllTy { hst_bndrs = tvs }) <- sig_ty2 + = vars ++ hsLTyVarNames tvs + | otherwise + = [] + +{- Note [Scoping of named wildcards] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f :: _a -> _a + f x = let g :: _a -> _a + g = ... + in ... + +Currently, for better or worse, the "_a" variables are all the same. So +although there is no explicit forall, the "_a" scopes over the definition. +I don't know if this is a good idea, but there it is. +-} + +--------------------- +hsTyVarName :: HsTyVarBndr pass -> IdP pass +hsTyVarName (UserTyVar _ (L _ n)) = n +hsTyVarName (KindedTyVar _ (L _ n) _) = n +hsTyVarName (XTyVarBndr{}) = panic "hsTyVarName" + +hsLTyVarName :: LHsTyVarBndr pass -> IdP pass +hsLTyVarName = hsTyVarName . unLoc + +hsLTyVarNames :: [LHsTyVarBndr pass] -> [IdP pass] +hsLTyVarNames = map hsLTyVarName + +hsExplicitLTyVarNames :: LHsQTyVars pass -> [IdP pass] +-- Explicit variables only +hsExplicitLTyVarNames qtvs = map hsLTyVarName (hsQTvExplicit qtvs) + +hsAllLTyVarNames :: LHsQTyVars GhcRn -> [Name] +-- All variables +hsAllLTyVarNames (HsQTvs { hsq_ext = kvs + , hsq_explicit = tvs }) + = kvs ++ hsLTyVarNames tvs +hsAllLTyVarNames (XLHsQTyVars _) = panic "hsAllLTyVarNames" + +hsLTyVarLocName :: LHsTyVarBndr pass -> Located (IdP pass) +hsLTyVarLocName = onHasSrcSpan hsTyVarName + +hsLTyVarLocNames :: LHsQTyVars pass -> [Located (IdP pass)] +hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs) + +-- | Convert a LHsTyVarBndr to an equivalent LHsType. +hsLTyVarBndrToType :: LHsTyVarBndr (GhcPass p) -> LHsType (GhcPass p) +hsLTyVarBndrToType = onHasSrcSpan cvt + where cvt (UserTyVar _ n) = HsTyVar noExt NotPromoted n + cvt (KindedTyVar _ (L name_loc n) kind) + = HsKindSig noExt + (L name_loc (HsTyVar noExt NotPromoted (L name_loc n))) kind + cvt (XTyVarBndr{}) = panic "hsLTyVarBndrToType" + +-- | Convert a LHsTyVarBndrs to a list of types. +-- Works on *type* variable only, no kind vars. +hsLTyVarBndrsToTypes :: LHsQTyVars (GhcPass p) -> [LHsType (GhcPass p)] +hsLTyVarBndrsToTypes (HsQTvs { hsq_explicit = tvbs }) = map hsLTyVarBndrToType tvbs +hsLTyVarBndrsToTypes (XLHsQTyVars _) = panic "hsLTyVarBndrsToTypes" + +--------------------- +ignoreParens :: LHsType pass -> LHsType pass +ignoreParens (L _ (HsParTy _ ty)) = ignoreParens ty +ignoreParens ty = ty + +isLHsForAllTy :: LHsType p -> Bool +isLHsForAllTy (L _ (HsForAllTy {})) = True +isLHsForAllTy _ = False + +{- +************************************************************************ +* * + Building types +* * +************************************************************************ +-} + +mkAnonWildCardTy :: HsType GhcPs +mkAnonWildCardTy = HsWildCardTy noExt + +mkHsOpTy :: LHsType (GhcPass p) -> Located (IdP (GhcPass p)) + -> LHsType (GhcPass p) -> HsType (GhcPass p) +mkHsOpTy ty1 op ty2 = HsOpTy noExt ty1 op ty2 + +mkHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) +mkHsAppTy t1 t2 + = addCLoc t1 t2 (HsAppTy noExt t1 (parenthesizeHsType appPrec t2)) + +mkHsAppTys :: LHsType (GhcPass p) -> [LHsType (GhcPass p)] + -> LHsType (GhcPass p) +mkHsAppTys = foldl' mkHsAppTy + +mkHsAppKindTy :: XAppKindTy (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) + -> LHsType (GhcPass p) +mkHsAppKindTy ext ty k + = addCLoc ty k (HsAppKindTy ext ty k) + +{- +************************************************************************ +* * + Decomposing HsTypes +* * +************************************************************************ +-} + +--------------------------------- +-- splitHsFunType decomposes a type (t1 -> t2 ... -> tn) +-- Breaks up any parens in the result type: +-- splitHsFunType (a -> (b -> c)) = ([a,b], c) +-- Also deals with (->) t1 t2; that is why it only works on LHsType Name +-- (see #9096) +splitHsFunType :: LHsType GhcRn -> ([LHsType GhcRn], LHsType GhcRn) +splitHsFunType (L _ (HsParTy _ ty)) + = splitHsFunType ty + +splitHsFunType (L _ (HsFunTy _ x y)) + | (args, res) <- splitHsFunType y + = (x:args, res) +{- This is not so correct, because it won't work with visible kind app, in case + someone wants to write '(->) @k1 @k2 t1 t2'. Fixing this would require changing + ConDeclGADT abstract syntax -} +splitHsFunType orig_ty@(L _ (HsAppTy _ t1 t2)) + = go t1 [t2] + where -- Look for (->) t1 t2, possibly with parenthesisation + go (L _ (HsTyVar _ _ (L _ fn))) tys | fn == funTyConName + , [t1,t2] <- tys + , (args, res) <- splitHsFunType t2 + = (t1:args, res) + go (L _ (HsAppTy _ t1 t2)) tys = go t1 (t2:tys) + go (L _ (HsParTy _ ty)) tys = go ty tys + go _ _ = ([], orig_ty) -- Failure to match + +splitHsFunType other = ([], other) + +-- retrieve the name of the "head" of a nested type application +-- somewhat like splitHsAppTys, but a little more thorough +-- used to examine the result of a GADT-like datacon, so it doesn't handle +-- *all* cases (like lists, tuples, (~), etc.) +hsTyGetAppHead_maybe :: LHsType (GhcPass p) + -> Maybe (Located (IdP (GhcPass p))) +hsTyGetAppHead_maybe = go + where + go (L _ (HsTyVar _ _ ln)) = Just ln + go (L _ (HsAppTy _ l _)) = go l + go (L _ (HsAppKindTy _ t _)) = go t + go (L _ (HsOpTy _ _ (L loc n) _)) = Just (L loc n) + go (L _ (HsParTy _ t)) = go t + go (L _ (HsKindSig _ t _)) = go t + go _ = Nothing + +------------------------------------------------------------ +-- Arguments in an expression/type after splitting +data HsArg tm ty + = HsValArg tm -- Argument is an ordinary expression (f arg) + | HsTypeArg SrcSpan ty -- Argument is a visible type application (f @ty) + -- SrcSpan is location of the `@` + | HsArgPar SrcSpan -- See Note [HsArgPar] + +numVisibleArgs :: [HsArg tm ty] -> Arity +numVisibleArgs = count is_vis + where is_vis (HsValArg _) = True + is_vis _ = False + +-- type level equivalent +type LHsTypeArg p = HsArg (LHsType p) (LHsKind p) + +instance (Outputable tm, Outputable ty) => Outputable (HsArg tm ty) where + ppr (HsValArg tm) = ppr tm + ppr (HsTypeArg _ ty) = char '@' <> ppr ty + ppr (HsArgPar sp) = text "HsArgPar" <+> ppr sp +{- +Note [HsArgPar] +A HsArgPar indicates that everything to the left of this in the argument list is +enclosed in parentheses together with the function itself. It is necessary so +that we can recreate the parenthesis structure in the original source after +typechecking the arguments. + +The SrcSpan is the span of the original HsPar + +((f arg1) arg2 arg3) results in an input argument list of +[HsValArg arg1, HsArgPar span1, HsValArg arg2, HsValArg arg3, HsArgPar span2] + +-} + +-------------------------------- + +-- | Decompose a pattern synonym type signature into its constituent parts. +-- +-- Note that this function looks through parentheses, so it will work on types +-- such as @(forall a. <...>)@. The downside to this is that it is not +-- generally possible to take the returned types and reconstruct the original +-- type (parentheses and all) from them. +splitLHsPatSynTy :: LHsType pass + -> ( [LHsTyVarBndr pass] -- universals + , LHsContext pass -- required constraints + , [LHsTyVarBndr pass] -- existentials + , LHsContext pass -- provided constraints + , LHsType pass) -- body type +splitLHsPatSynTy ty = (univs, reqs, exis, provs, ty4) + where + (univs, ty1) = splitLHsForAllTyInvis ty + (reqs, ty2) = splitLHsQualTy ty1 + (exis, ty3) = splitLHsForAllTyInvis ty2 + (provs, ty4) = splitLHsQualTy ty3 + +-- | Decompose a sigma type (of the form @forall . context => body@) +-- into its constituent parts. +-- +-- Note that this function looks through parentheses, so it will work on types +-- such as @(forall a. <...>)@. The downside to this is that it is not +-- generally possible to take the returned types and reconstruct the original +-- type (parentheses and all) from them. +splitLHsSigmaTy :: LHsType pass + -> ([LHsTyVarBndr pass], LHsContext pass, LHsType pass) +splitLHsSigmaTy ty + | (tvs, ty1) <- splitLHsForAllTy ty + , (ctxt, ty2) <- splitLHsQualTy ty1 + = (tvs, ctxt, ty2) + +-- | Like 'splitLHsSigmaTy', but only splits type variable binders that were +-- quantified invisibly (e.g., @forall a.@, with a dot). +-- +-- This function is used to split apart certain types, such as instance +-- declaration types, which disallow visible @forall@s. For instance, if GHC +-- split apart the @forall@ in @instance forall a -> Show (Blah a)@, then that +-- declaration would mistakenly be accepted! +-- +-- Note that this function looks through parentheses, so it will work on types +-- such as @(forall a. <...>)@. The downside to this is that it is not +-- generally possible to take the returned types and reconstruct the original +-- type (parentheses and all) from them. +splitLHsSigmaTyInvis :: LHsType pass + -> ([LHsTyVarBndr pass], LHsContext pass, LHsType pass) +splitLHsSigmaTyInvis ty + | (tvs, ty1) <- splitLHsForAllTyInvis ty + , (ctxt, ty2) <- splitLHsQualTy ty1 + = (tvs, ctxt, ty2) + +-- | Decompose a type of the form @forall . body@) into its constituent +-- parts. +-- +-- Note that this function looks through parentheses, so it will work on types +-- such as @(forall a. <...>)@. The downside to this is that it is not +-- generally possible to take the returned types and reconstruct the original +-- type (parentheses and all) from them. +splitLHsForAllTy :: LHsType pass -> ([LHsTyVarBndr pass], LHsType pass) +splitLHsForAllTy (L _ (HsParTy _ ty)) = splitLHsForAllTy ty +splitLHsForAllTy (L _ (HsForAllTy { hst_bndrs = tvs, hst_body = body })) = (tvs, body) +splitLHsForAllTy body = ([], body) + +-- | Like 'splitLHsForAllTy', but only splits type variable binders that +-- were quantified invisibly (e.g., @forall a.@, with a dot). +-- +-- This function is used to split apart certain types, such as instance +-- declaration types, which disallow visible @forall@s. For instance, if GHC +-- split apart the @forall@ in @instance forall a -> Show (Blah a)@, then that +-- declaration would mistakenly be accepted! +-- +-- Note that this function looks through parentheses, so it will work on types +-- such as @(forall a. <...>)@. The downside to this is that it is not +-- generally possible to take the returned types and reconstruct the original +-- type (parentheses and all) from them. +splitLHsForAllTyInvis :: LHsType pass -> ([LHsTyVarBndr pass], LHsType pass) +splitLHsForAllTyInvis lty@(L _ ty) = + case ty of + HsParTy _ ty' -> splitLHsForAllTyInvis ty' + HsForAllTy { hst_fvf = fvf', hst_bndrs = tvs', hst_body = body' } + | fvf' == ForallInvis + -> (tvs', body') + _ -> ([], lty) + +-- | Decompose a type of the form @context => body@ into its constituent parts. +-- +-- Note that this function looks through parentheses, so it will work on types +-- such as @(context => <...>)@. The downside to this is that it is not +-- generally possible to take the returned types and reconstruct the original +-- type (parentheses and all) from them. +splitLHsQualTy :: LHsType pass -> (LHsContext pass, LHsType pass) +splitLHsQualTy (L _ (HsParTy _ ty)) = splitLHsQualTy ty +splitLHsQualTy (L _ (HsQualTy { hst_ctxt = ctxt, hst_body = body })) = (ctxt, body) +splitLHsQualTy body = (noLHsContext, body) + +-- | Decompose a type class instance type (of the form +-- @forall . context => instance_head@) into its constituent parts. +-- +-- Note that this function looks through parentheses, so it will work on types +-- such as @(forall . <...>)@. The downside to this is that it is not +-- generally possible to take the returned types and reconstruct the original +-- type (parentheses and all) from them. +splitLHsInstDeclTy :: LHsSigType GhcRn + -> ([Name], LHsContext GhcRn, LHsType GhcRn) +-- Split up an instance decl type, returning the pieces +splitLHsInstDeclTy (HsIB { hsib_ext = itkvs + , hsib_body = inst_ty }) + | (tvs, cxt, body_ty) <- splitLHsSigmaTyInvis inst_ty + = (itkvs ++ hsLTyVarNames tvs, cxt, body_ty) + -- Return implicitly bound type and kind vars + -- For an instance decl, all of them are in scope +splitLHsInstDeclTy (XHsImplicitBndrs _) = panic "splitLHsInstDeclTy" + +getLHsInstDeclHead :: LHsSigType pass -> LHsType pass +getLHsInstDeclHead inst_ty + | (_tvs, _cxt, body_ty) <- splitLHsSigmaTyInvis (hsSigType inst_ty) + = body_ty + +getLHsInstDeclClass_maybe :: LHsSigType (GhcPass p) + -> Maybe (Located (IdP (GhcPass p))) +-- Works on (HsSigType RdrName) +getLHsInstDeclClass_maybe inst_ty + = do { let head_ty = getLHsInstDeclHead inst_ty + ; cls <- hsTyGetAppHead_maybe head_ty + ; return cls } + +{- +************************************************************************ +* * + FieldOcc +* * +************************************************************************ +-} + +-- | Located Field Occurrence +type LFieldOcc pass = Located (FieldOcc pass) + +-- | Field Occurrence +-- +-- Represents an *occurrence* of an unambiguous field. We store +-- both the 'RdrName' the user originally wrote, and after the +-- renamer, the selector function. +data FieldOcc pass = FieldOcc { extFieldOcc :: XCFieldOcc pass + , rdrNameFieldOcc :: Located RdrName + -- ^ See Note [Located RdrNames] in HsExpr + } + + | XFieldOcc + (XXFieldOcc pass) +deriving instance (p ~ GhcPass pass, Eq (XCFieldOcc p)) => Eq (FieldOcc p) +deriving instance (p ~ GhcPass pass, Ord (XCFieldOcc p)) => Ord (FieldOcc p) + +type instance XCFieldOcc GhcPs = NoExt +type instance XCFieldOcc GhcRn = Name +type instance XCFieldOcc GhcTc = Id + +type instance XXFieldOcc (GhcPass _) = NoExt + +instance Outputable (FieldOcc pass) where + ppr = ppr . rdrNameFieldOcc + +mkFieldOcc :: Located RdrName -> FieldOcc GhcPs +mkFieldOcc rdr = FieldOcc noExt rdr + + +-- | Ambiguous Field Occurrence +-- +-- Represents an *occurrence* of a field that is potentially +-- ambiguous after the renamer, with the ambiguity resolved by the +-- typechecker. We always store the 'RdrName' that the user +-- originally wrote, and store the selector function after the renamer +-- (for unambiguous occurrences) or the typechecker (for ambiguous +-- occurrences). +-- +-- See Note [HsRecField and HsRecUpdField] in HsPat and +-- Note [Disambiguating record fields] in TcExpr. +-- See Note [Located RdrNames] in HsExpr +data AmbiguousFieldOcc pass + = Unambiguous (XUnambiguous pass) (Located RdrName) + | Ambiguous (XAmbiguous pass) (Located RdrName) + | XAmbiguousFieldOcc (XXAmbiguousFieldOcc pass) + +type instance XUnambiguous GhcPs = NoExt +type instance XUnambiguous GhcRn = Name +type instance XUnambiguous GhcTc = Id + +type instance XAmbiguous GhcPs = NoExt +type instance XAmbiguous GhcRn = NoExt +type instance XAmbiguous GhcTc = Id + +type instance XXAmbiguousFieldOcc (GhcPass _) = NoExt + +instance p ~ GhcPass pass => Outputable (AmbiguousFieldOcc p) where + ppr = ppr . rdrNameAmbiguousFieldOcc + +instance p ~ GhcPass pass => OutputableBndr (AmbiguousFieldOcc p) where + pprInfixOcc = pprInfixOcc . rdrNameAmbiguousFieldOcc + pprPrefixOcc = pprPrefixOcc . rdrNameAmbiguousFieldOcc + +mkAmbiguousFieldOcc :: Located RdrName -> AmbiguousFieldOcc GhcPs +mkAmbiguousFieldOcc rdr = Unambiguous noExt rdr + +rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc (GhcPass p) -> RdrName +rdrNameAmbiguousFieldOcc (Unambiguous _ (L _ rdr)) = rdr +rdrNameAmbiguousFieldOcc (Ambiguous _ (L _ rdr)) = rdr +rdrNameAmbiguousFieldOcc (XAmbiguousFieldOcc _) + = panic "rdrNameAmbiguousFieldOcc" + +selectorAmbiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> Id +selectorAmbiguousFieldOcc (Unambiguous sel _) = sel +selectorAmbiguousFieldOcc (Ambiguous sel _) = sel +selectorAmbiguousFieldOcc (XAmbiguousFieldOcc _) + = panic "selectorAmbiguousFieldOcc" + +unambiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> FieldOcc GhcTc +unambiguousFieldOcc (Unambiguous rdr sel) = FieldOcc rdr sel +unambiguousFieldOcc (Ambiguous rdr sel) = FieldOcc rdr sel +unambiguousFieldOcc (XAmbiguousFieldOcc _) = panic "unambiguousFieldOcc" + +ambiguousFieldOcc :: FieldOcc GhcTc -> AmbiguousFieldOcc GhcTc +ambiguousFieldOcc (FieldOcc sel rdr) = Unambiguous sel rdr +ambiguousFieldOcc (XFieldOcc _) = panic "ambiguousFieldOcc" + +{- +************************************************************************ +* * +\subsection{Pretty printing} +* * +************************************************************************ +-} + +instance (p ~ GhcPass pass, OutputableBndrId p) => Outputable (HsType p) where + ppr ty = pprHsType ty + +instance Outputable HsTyLit where + ppr = ppr_tylit + +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (LHsQTyVars p) where + ppr (HsQTvs { hsq_explicit = tvs }) = interppSP tvs + ppr (XLHsQTyVars x) = ppr x + +instance (p ~ GhcPass pass, OutputableBndrId p) + => Outputable (HsTyVarBndr p) where + ppr (UserTyVar _ n) = ppr n + ppr (KindedTyVar _ n k) = parens $ hsep [ppr n, dcolon, ppr k] + ppr (XTyVarBndr n) = ppr n + +instance (p ~ GhcPass pass,Outputable thing) + => Outputable (HsImplicitBndrs p thing) where + ppr (HsIB { hsib_body = ty }) = ppr ty + ppr (XHsImplicitBndrs x) = ppr x + +instance (p ~ GhcPass pass,Outputable thing) + => Outputable (HsWildCardBndrs p thing) where + ppr (HsWC { hswc_body = ty }) = ppr ty + ppr (XHsWildCardBndrs x) = ppr x + +pprAnonWildCard :: SDoc +pprAnonWildCard = char '_' + +-- | Prints a forall; When passed an empty list, prints @forall .@/@forall ->@ +-- only when @-dppr-debug@ is enabled. +pprHsForAll :: (OutputableBndrId (GhcPass p)) + => ForallVisFlag -> [LHsTyVarBndr (GhcPass p)] + -> LHsContext (GhcPass p) -> SDoc +pprHsForAll = pprHsForAllExtra Nothing + +-- | Version of 'pprHsForAll' that can also print an extra-constraints +-- wildcard, e.g. @_ => a -> Bool@ or @(Show a, _) => a -> String@. This +-- underscore will be printed when the 'Maybe SrcSpan' argument is a 'Just' +-- containing the location of the extra-constraints wildcard. A special +-- function for this is needed, as the extra-constraints wildcard is removed +-- from the actual context and type, and stored in a separate field, thus just +-- printing the type will not print the extra-constraints wildcard. +pprHsForAllExtra :: (OutputableBndrId (GhcPass p)) + => Maybe SrcSpan -> ForallVisFlag + -> [LHsTyVarBndr (GhcPass p)] + -> LHsContext (GhcPass p) -> SDoc +pprHsForAllExtra extra fvf qtvs cxt + = pp_forall <+> pprLHsContextExtra (isJust extra) cxt + where + pp_forall | null qtvs = whenPprDebug (forAllLit <> separator) + | otherwise = forAllLit <+> interppSP qtvs <> separator + + separator = ppr_forall_separator fvf + +-- | Version of 'pprHsForAll' or 'pprHsForAllExtra' that will always print +-- @forall.@ when passed @Just []@. Prints nothing if passed 'Nothing' +pprHsExplicitForAll :: (OutputableBndrId (GhcPass p)) + => ForallVisFlag + -> Maybe [LHsTyVarBndr (GhcPass p)] -> SDoc +pprHsExplicitForAll fvf (Just qtvs) = forAllLit <+> interppSP qtvs + <> ppr_forall_separator fvf +pprHsExplicitForAll _ Nothing = empty + +-- | Prints an arrow for visible @forall@s (e.g., @forall a ->@) and a dot for +-- invisible @forall@s (e.g., @forall a.@). +ppr_forall_separator :: ForallVisFlag -> SDoc +ppr_forall_separator ForallVis = space <> arrow +ppr_forall_separator ForallInvis = dot + +pprLHsContext :: (OutputableBndrId (GhcPass p)) + => LHsContext (GhcPass p) -> SDoc +pprLHsContext lctxt + | null (unLoc lctxt) = empty + | otherwise = pprLHsContextAlways lctxt + +-- For use in a HsQualTy, which always gets printed if it exists. +pprLHsContextAlways :: (OutputableBndrId (GhcPass p)) + => LHsContext (GhcPass p) -> SDoc +pprLHsContextAlways (L _ ctxt) + = case ctxt of + [] -> parens empty <+> darrow + [L _ ty] -> ppr_mono_ty ty <+> darrow + _ -> parens (interpp'SP ctxt) <+> darrow + +-- True <=> print an extra-constraints wildcard, e.g. @(Show a, _) =>@ +pprLHsContextExtra :: (OutputableBndrId (GhcPass p)) + => Bool -> LHsContext (GhcPass p) -> SDoc +pprLHsContextExtra show_extra lctxt@(L _ ctxt) + | not show_extra = pprLHsContext lctxt + | null ctxt = char '_' <+> darrow + | otherwise = parens (sep (punctuate comma ctxt')) <+> darrow + where + ctxt' = map ppr ctxt ++ [char '_'] + +pprConDeclFields :: (OutputableBndrId (GhcPass p)) + => [LConDeclField (GhcPass p)] -> SDoc +pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields))) + where + ppr_fld (L _ (ConDeclField { cd_fld_names = ns, cd_fld_type = ty, + cd_fld_doc = doc })) + = ppr_names ns <+> dcolon <+> ppr ty <+> ppr_mbDoc doc + ppr_fld (L _ (XConDeclField x)) = ppr x + ppr_names [n] = ppr n + ppr_names ns = sep (punctuate comma (map ppr ns)) + +{- +Note [Printing KindedTyVars] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +#3830 reminded me that we should really only print the kind +signature on a KindedTyVar if the kind signature was put there by the +programmer. During kind inference GHC now adds a PostTcKind to UserTyVars, +rather than converting to KindedTyVars as before. + +(As it happens, the message in #3830 comes out a different way now, +and the problem doesn't show up; but having the flag on a KindedTyVar +seems like the Right Thing anyway.) +-} + +-- Printing works more-or-less as for Types + +pprHsType :: (OutputableBndrId (GhcPass p)) => HsType (GhcPass p) -> SDoc +pprHsType ty = ppr_mono_ty ty + +ppr_mono_lty :: (OutputableBndrId (GhcPass p)) => LHsType (GhcPass p) -> SDoc +ppr_mono_lty ty = ppr_mono_ty (unLoc ty) + +ppr_mono_ty :: (OutputableBndrId (GhcPass p)) => HsType (GhcPass p) -> SDoc +ppr_mono_ty (HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs, hst_body = ty }) + = sep [pprHsForAll fvf tvs noLHsContext, ppr_mono_lty ty] + +ppr_mono_ty (HsQualTy { hst_ctxt = ctxt, hst_body = ty }) + = sep [pprLHsContextAlways ctxt, ppr_mono_lty ty] + +ppr_mono_ty (HsBangTy _ b ty) = ppr b <> ppr_mono_lty ty +ppr_mono_ty (HsRecTy _ flds) = pprConDeclFields flds +ppr_mono_ty (HsTyVar _ prom (L _ name)) + | isPromoted prom = quote (pprPrefixOcc name) + | otherwise = pprPrefixOcc name +ppr_mono_ty (HsFunTy _ ty1 ty2) = ppr_fun_ty ty1 ty2 +ppr_mono_ty (HsTupleTy _ con tys) = tupleParens std_con (pprWithCommas ppr tys) + where std_con = case con of + HsUnboxedTuple -> UnboxedTuple + _ -> BoxedTuple +ppr_mono_ty (HsSumTy _ tys) + = tupleParens UnboxedTuple (pprWithBars ppr tys) +ppr_mono_ty (HsKindSig _ ty kind) + = ppr_mono_lty ty <+> dcolon <+> ppr kind +ppr_mono_ty (HsListTy _ ty) = brackets (ppr_mono_lty ty) +ppr_mono_ty (HsIParamTy _ n ty) = (ppr n <+> dcolon <+> ppr_mono_lty ty) +ppr_mono_ty (HsSpliceTy _ s) = pprSplice s +ppr_mono_ty (HsExplicitListTy _ prom tys) + | isPromoted prom = quote $ brackets (maybeAddSpace tys $ interpp'SP tys) + | otherwise = brackets (interpp'SP tys) +ppr_mono_ty (HsExplicitTupleTy _ tys) + = quote $ parens (maybeAddSpace tys $ interpp'SP tys) +ppr_mono_ty (HsTyLit _ t) = ppr_tylit t +ppr_mono_ty (HsWildCardTy {}) = char '_' + +ppr_mono_ty (HsStarTy _ isUni) = char (if isUni then '★' else '*') + +ppr_mono_ty (HsAppTy _ fun_ty arg_ty) + = hsep [ppr_mono_lty fun_ty, ppr_mono_lty arg_ty] +ppr_mono_ty (HsAppKindTy _ ty k) + = ppr_mono_lty ty <+> char '@' <> ppr_mono_lty k +ppr_mono_ty (HsOpTy _ ty1 (L _ op) ty2) + = sep [ ppr_mono_lty ty1 + , sep [pprInfixOcc op, ppr_mono_lty ty2 ] ] + +ppr_mono_ty (HsParTy _ ty) + = parens (ppr_mono_lty ty) + -- Put the parens in where the user did + -- But we still use the precedence stuff to add parens because + -- toHsType doesn't put in any HsParTys, so we may still need them + +ppr_mono_ty (HsDocTy _ ty doc) + -- AZ: Should we add parens? Should we introduce "-- ^"? + = ppr_mono_lty ty <+> ppr (unLoc doc) + -- we pretty print Haddock comments on types as if they were + -- postfix operators + +ppr_mono_ty (XHsType t) = ppr t + +-------------------------- +ppr_fun_ty :: (OutputableBndrId (GhcPass p)) + => LHsType (GhcPass p) -> LHsType (GhcPass p) -> SDoc +ppr_fun_ty ty1 ty2 + = let p1 = ppr_mono_lty ty1 + p2 = ppr_mono_lty ty2 + in + sep [p1, arrow <+> p2] + +-------------------------- +ppr_tylit :: HsTyLit -> SDoc +ppr_tylit (HsNumTy _ i) = integer i +ppr_tylit (HsStrTy _ s) = text (show s) + + +-- | @'hsTypeNeedsParens' p t@ returns 'True' if the type @t@ needs parentheses +-- under precedence @p@. +hsTypeNeedsParens :: PprPrec -> HsType pass -> Bool +hsTypeNeedsParens p = go + where + go (HsForAllTy{}) = p >= funPrec + go (HsQualTy{}) = p >= funPrec + go (HsBangTy{}) = p > topPrec + go (HsRecTy{}) = False + go (HsTyVar{}) = False + go (HsFunTy{}) = p >= funPrec + go (HsTupleTy{}) = False + go (HsSumTy{}) = False + go (HsKindSig{}) = p >= sigPrec + go (HsListTy{}) = False + go (HsIParamTy{}) = p > topPrec + go (HsSpliceTy{}) = False + go (HsExplicitListTy{}) = False + go (HsExplicitTupleTy{}) = False + go (HsTyLit{}) = False + go (HsWildCardTy{}) = False + go (HsStarTy{}) = False + go (HsAppTy{}) = p >= appPrec + go (HsAppKindTy{}) = p >= appPrec + go (HsOpTy{}) = p >= opPrec + go (HsParTy{}) = False + go (HsDocTy _ (L _ t) _) = go t + go (XHsType{}) = False + +maybeAddSpace :: [LHsType pass] -> SDoc -> SDoc +-- See Note [Printing promoted type constructors] +-- in IfaceType. This code implements the same +-- logic for printing HsType +maybeAddSpace tys doc + | (ty : _) <- tys + , lhsTypeHasLeadingPromotionQuote ty = space <> doc + | otherwise = doc + +lhsTypeHasLeadingPromotionQuote :: LHsType pass -> Bool +lhsTypeHasLeadingPromotionQuote ty + = goL ty + where + goL (L _ ty) = go ty + + go (HsForAllTy{}) = False + go (HsQualTy{ hst_ctxt = ctxt, hst_body = body}) + | L _ (c:_) <- ctxt = goL c + | otherwise = goL body + go (HsBangTy{}) = False + go (HsRecTy{}) = False + go (HsTyVar _ p _) = isPromoted p + go (HsFunTy _ arg _) = goL arg + go (HsListTy{}) = False + go (HsTupleTy{}) = False + go (HsSumTy{}) = False + go (HsOpTy _ t1 _ _) = goL t1 + go (HsKindSig _ t _) = goL t + go (HsIParamTy{}) = False + go (HsSpliceTy{}) = False + go (HsExplicitListTy _ p _) = isPromoted p + go (HsExplicitTupleTy{}) = True + go (HsTyLit{}) = False + go (HsWildCardTy{}) = False + go (HsStarTy{}) = False + go (HsAppTy _ t _) = goL t + go (HsAppKindTy _ t _) = goL t + go (HsParTy{}) = False + go (HsDocTy _ t _) = goL t + go (XHsType{}) = False + +-- | @'parenthesizeHsType' p ty@ checks if @'hsTypeNeedsParens' p ty@ is +-- true, and if so, surrounds @ty@ with an 'HsParTy'. Otherwise, it simply +-- returns @ty@. +parenthesizeHsType :: PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p) +parenthesizeHsType p lty@(L loc ty) + | hsTypeNeedsParens p ty = L loc (HsParTy NoExt lty) + | otherwise = lty + +-- | @'parenthesizeHsContext' p ctxt@ checks if @ctxt@ is a single constraint +-- @c@ such that @'hsTypeNeedsParens' p c@ is true, and if so, surrounds @c@ +-- with an 'HsParTy' to form a parenthesized @ctxt@. Otherwise, it simply +-- returns @ctxt@ unchanged. +parenthesizeHsContext :: PprPrec + -> LHsContext (GhcPass p) -> LHsContext (GhcPass p) +parenthesizeHsContext p lctxt@(L loc ctxt) = + case ctxt of + [c] -> L loc [parenthesizeHsType p c] + _ -> lctxt -- Other contexts are already "parenthesized" by virtue of + -- being tuples. diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs new file mode 100644 --- /dev/null +++ b/compiler/hsSyn/HsUtils.hs @@ -0,0 +1,1418 @@ +{- +(c) The University of Glasgow, 1992-2006 + + +Here we collect a variety of helper functions that construct or +analyse HsSyn. All these functions deal with generic HsSyn; functions +which deal with the instantiated versions are located elsewhere: + + Parameterised by Module + ---------------- ------------- + GhcPs/RdrName parser/RdrHsSyn + GhcRn/Name rename/RnHsSyn + GhcTc/Id typecheck/TcHsSyn +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module HsUtils( + -- Terms + mkHsPar, mkHsApp, mkHsAppType, mkHsAppTypes, mkHsCaseAlt, + mkSimpleMatch, unguardedGRHSs, unguardedRHS, + mkMatchGroup, mkMatch, mkPrefixFunRhs, mkHsLam, mkHsIf, + mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo, + mkHsDictLet, mkHsLams, + mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo, + mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap, + mkHsCmdIf, + + nlHsTyApp, nlHsTyApps, nlHsVar, nlHsDataCon, + nlHsLit, nlHsApp, nlHsApps, nlHsSyntaxApps, + nlHsIntLit, nlHsVarApps, + nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList, + mkLHsTupleExpr, mkLHsVarTuple, missingTupArg, + typeToLHsType, + + -- * Constructing general big tuples + -- $big_tuples + mkChunkified, chunkify, + + -- Bindings + mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, mkTopFunBind, + mkPatSynBind, + isInfixFunBind, + + -- Literals + mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, mkHsStringPrimLit, + + -- Patterns + mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConVarPatName, nlConPat, + nlConPatName, nlInfixConPat, nlNullaryConPat, nlWildConPat, nlWildPat, + nlWildPatName, nlTuplePat, mkParPat, nlParPat, + mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup, + + -- Types + mkHsAppTy, mkHsAppKindTy, userHsTyVarBndrs, userHsLTyVarBndrs, + mkLHsSigType, mkLHsSigWcType, mkClassOpSigs, mkHsSigEnv, + nlHsAppTy, nlHsAppKindTy, nlHsTyVar, nlHsFunTy, nlHsParTy, nlHsTyConApp, + + -- Stmts + mkTransformStmt, mkTransformByStmt, mkBodyStmt, mkBindStmt, mkTcBindStmt, + mkLastStmt, + emptyTransStmt, mkGroupUsingStmt, mkGroupByUsingStmt, + emptyRecStmt, emptyRecStmtName, emptyRecStmtId, mkRecStmt, + unitRecStmtTc, + + -- Template Haskell + mkUntypedSplice, mkTypedSplice, + mkHsQuasiQuote, unqualQuasiQuote, + + -- Collecting binders + isUnliftedHsBind, isBangedHsBind, + + collectLocalBinders, collectHsValBinders, collectHsBindListBinders, + collectHsIdBinders, + collectHsBindsBinders, collectHsBindBinders, collectMethodBinders, + collectPatBinders, collectPatsBinders, + collectLStmtsBinders, collectStmtsBinders, + collectLStmtBinders, collectStmtBinders, + + hsLTyClDeclBinders, hsTyClForeignBinders, + hsPatSynSelectors, getPatSynBinds, + hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders, + + -- Collecting implicit binders + lStmtsImplicits, hsValBindsImplicits, lPatImplicits + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import HsDecls +import HsBinds +import HsExpr +import HsPat +import HsTypes +import HsLit +import PlaceHolder +import HsExtension + +import TcEvidence +import RdrName +import Var +import TyCoRep +import Type ( tyConArgFlags ) +import TysWiredIn ( unitTy ) +import TcType +import DataCon +import ConLike +import Id +import Name +import NameSet hiding ( unitFV ) +import NameEnv +import BasicTypes +import SrcLoc +import FastString +import Util +import Bag +import Outputable +import Constants + +import Data.Either +import Data.Function +import Data.List + +{- +************************************************************************ +* * + Some useful helpers for constructing syntax +* * +************************************************************************ + +These functions attempt to construct a not-completely-useless SrcSpan +from their components, compared with the nl* functions below which +just attach noSrcSpan to everything. +-} + +mkHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) +mkHsPar e = cL (getLoc e) (HsPar noExt e) + +mkSimpleMatch :: HsMatchContext (NameOrRdrName (IdP (GhcPass p))) + -> [LPat (GhcPass p)] -> Located (body (GhcPass p)) + -> LMatch (GhcPass p) (Located (body (GhcPass p))) +mkSimpleMatch ctxt pats rhs + = cL loc $ + Match { m_ext = noExt, m_ctxt = ctxt, m_pats = pats + , m_grhss = unguardedGRHSs rhs } + where + loc = case pats of + [] -> getLoc rhs + (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs) + +unguardedGRHSs :: Located (body (GhcPass p)) + -> GRHSs (GhcPass p) (Located (body (GhcPass p))) +unguardedGRHSs rhs@(dL->L loc _) + = GRHSs noExt (unguardedRHS loc rhs) (noLoc emptyLocalBinds) + +unguardedRHS :: SrcSpan -> Located (body (GhcPass p)) + -> [LGRHS (GhcPass p) (Located (body (GhcPass p)))] +unguardedRHS loc rhs = [cL loc (GRHS noExt [] rhs)] + +mkMatchGroup :: (XMG name (Located (body name)) ~ NoExt) + => Origin -> [LMatch name (Located (body name))] + -> MatchGroup name (Located (body name)) +mkMatchGroup origin matches = MG { mg_ext = noExt + , mg_alts = mkLocatedList matches + , mg_origin = origin } + +mkLocatedList :: [Located a] -> Located [Located a] +mkLocatedList [] = noLoc [] +mkLocatedList ms = cL (combineLocs (head ms) (last ms)) ms + +mkHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) +mkHsApp e1 e2 = addCLoc e1 e2 (HsApp noExt e1 e2) + +mkHsAppType :: (NoGhcTc (GhcPass id) ~ GhcRn) + => LHsExpr (GhcPass id) -> LHsWcType GhcRn -> LHsExpr (GhcPass id) +mkHsAppType e t = addCLoc e t_body (HsAppType noExt e paren_wct) + where + t_body = hswc_body t + paren_wct = t { hswc_body = parenthesizeHsType appPrec t_body } + +mkHsAppTypes :: LHsExpr GhcRn -> [LHsWcType GhcRn] -> LHsExpr GhcRn +mkHsAppTypes = foldl' mkHsAppType + +mkHsLam :: (XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExt) => + [LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) +mkHsLam pats body = mkHsPar (cL (getLoc body) (HsLam noExt matches)) + where + matches = mkMatchGroup Generated + [mkSimpleMatch LambdaExpr pats' body] + pats' = map (parenthesizePat appPrec) pats + +mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr GhcTc -> LHsExpr GhcTc +mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars + <.> mkWpLams dicts) expr + +-- |A simple case alternative with a single pattern, no binds, no guards; +-- pre-typechecking +mkHsCaseAlt :: LPat (GhcPass p) -> (Located (body (GhcPass p))) + -> LMatch (GhcPass p) (Located (body (GhcPass p))) +mkHsCaseAlt pat expr + = mkSimpleMatch CaseAlt [pat] expr + +nlHsTyApp :: IdP (GhcPass id) -> [Type] -> LHsExpr (GhcPass id) +nlHsTyApp fun_id tys + = noLoc (mkHsWrap (mkWpTyApps tys) (HsVar noExt (noLoc fun_id))) + +nlHsTyApps :: IdP (GhcPass id) -> [Type] -> [LHsExpr (GhcPass id)] + -> LHsExpr (GhcPass id) +nlHsTyApps fun_id tys xs = foldl' nlHsApp (nlHsTyApp fun_id tys) xs + +--------- Adding parens --------- +mkLHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) +-- Wrap in parens if (hsExprNeedsParens appPrec) says it needs them +-- So 'f x' becomes '(f x)', but '3' stays as '3' +mkLHsPar le@(dL->L loc e) + | hsExprNeedsParens appPrec e = cL loc (HsPar noExt le) + | otherwise = le + +mkParPat :: LPat (GhcPass name) -> LPat (GhcPass name) +mkParPat lp@(dL->L loc p) + | patNeedsParens appPrec p = cL loc (ParPat noExt lp) + | otherwise = lp + +nlParPat :: LPat (GhcPass name) -> LPat (GhcPass name) +nlParPat p = noLoc (ParPat noExt p) + +------------------------------- +-- These are the bits of syntax that contain rebindable names +-- See RnEnv.lookupSyntaxName + +mkHsIntegral :: IntegralLit -> HsOverLit GhcPs +mkHsFractional :: FractionalLit -> HsOverLit GhcPs +mkHsIsString :: SourceText -> FastString -> HsOverLit GhcPs +mkHsDo :: HsStmtContext Name -> [ExprLStmt GhcPs] -> HsExpr GhcPs +mkHsComp :: HsStmtContext Name -> [ExprLStmt GhcPs] -> LHsExpr GhcPs + -> HsExpr GhcPs + +mkNPat :: Located (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) + -> Pat GhcPs +mkNPlusKPat :: Located RdrName -> Located (HsOverLit GhcPs) -> Pat GhcPs + +mkLastStmt :: Located (bodyR (GhcPass idR)) + -> StmtLR (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR))) +mkBodyStmt :: Located (bodyR GhcPs) + -> StmtLR (GhcPass idL) GhcPs (Located (bodyR GhcPs)) +mkBindStmt :: (XBindStmt (GhcPass idL) (GhcPass idR) + (Located (bodyR (GhcPass idR))) ~ NoExt) + => LPat (GhcPass idL) -> Located (bodyR (GhcPass idR)) + -> StmtLR (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR))) +mkTcBindStmt :: LPat GhcTc -> Located (bodyR GhcTc) + -> StmtLR GhcTc GhcTc (Located (bodyR GhcTc)) + +emptyRecStmt :: StmtLR (GhcPass idL) GhcPs bodyR +emptyRecStmtName :: StmtLR GhcRn GhcRn bodyR +emptyRecStmtId :: StmtLR GhcTc GhcTc bodyR +mkRecStmt :: [LStmtLR (GhcPass idL) GhcPs bodyR] + -> StmtLR (GhcPass idL) GhcPs bodyR + + +mkHsIntegral i = OverLit noExt (HsIntegral i) noExpr +mkHsFractional f = OverLit noExt (HsFractional f) noExpr +mkHsIsString src s = OverLit noExt (HsIsString src s) noExpr + +mkHsDo ctxt stmts = HsDo noExt ctxt (mkLocatedList stmts) +mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt]) + where + last_stmt = cL (getLoc expr) $ mkLastStmt expr + +mkHsIf :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) + -> HsExpr (GhcPass p) +mkHsIf c a b = HsIf noExt (Just noSyntaxExpr) c a b + +mkHsCmdIf :: LHsExpr (GhcPass p) -> LHsCmd (GhcPass p) -> LHsCmd (GhcPass p) + -> HsCmd (GhcPass p) +mkHsCmdIf c a b = HsCmdIf noExt (Just noSyntaxExpr) c a b + +mkNPat lit neg = NPat noExt lit neg noSyntaxExpr +mkNPlusKPat id lit + = NPlusKPat noExt id lit (unLoc lit) noSyntaxExpr noSyntaxExpr + +mkTransformStmt :: [ExprLStmt GhcPs] -> LHsExpr GhcPs + -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) +mkTransformByStmt :: [ExprLStmt GhcPs] -> LHsExpr GhcPs + -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) +mkGroupUsingStmt :: [ExprLStmt GhcPs] -> LHsExpr GhcPs + -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) +mkGroupByUsingStmt :: [ExprLStmt GhcPs] -> LHsExpr GhcPs + -> LHsExpr GhcPs + -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) + +emptyTransStmt :: StmtLR GhcPs GhcPs (LHsExpr GhcPs) +emptyTransStmt = TransStmt { trS_ext = noExt + , trS_form = panic "emptyTransStmt: form" + , trS_stmts = [], trS_bndrs = [] + , trS_by = Nothing, trS_using = noLoc noExpr + , trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr + , trS_fmap = noExpr } +mkTransformStmt ss u = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u } +mkTransformByStmt ss u b = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u, trS_by = Just b } +mkGroupUsingStmt ss u = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u } +mkGroupByUsingStmt ss b u = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u, trS_by = Just b } + +mkLastStmt body = LastStmt noExt body False noSyntaxExpr +mkBodyStmt body + = BodyStmt noExt body noSyntaxExpr noSyntaxExpr +mkBindStmt pat body + = BindStmt noExt pat body noSyntaxExpr noSyntaxExpr +mkTcBindStmt pat body = BindStmt unitTy pat body noSyntaxExpr noSyntaxExpr + -- don't use placeHolderTypeTc above, because that panics during zonking + +emptyRecStmt' :: forall idL idR body. + XRecStmt (GhcPass idL) (GhcPass idR) body + -> StmtLR (GhcPass idL) (GhcPass idR) body +emptyRecStmt' tyVal = + RecStmt + { recS_stmts = [], recS_later_ids = [] + , recS_rec_ids = [] + , recS_ret_fn = noSyntaxExpr + , recS_mfix_fn = noSyntaxExpr + , recS_bind_fn = noSyntaxExpr + , recS_ext = tyVal } + +unitRecStmtTc :: RecStmtTc +unitRecStmtTc = RecStmtTc { recS_bind_ty = unitTy + , recS_later_rets = [] + , recS_rec_rets = [] + , recS_ret_ty = unitTy } + +emptyRecStmt = emptyRecStmt' noExt +emptyRecStmtName = emptyRecStmt' noExt +emptyRecStmtId = emptyRecStmt' unitRecStmtTc + -- a panic might trigger during zonking +mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts } + +------------------------------- +--- A useful function for building @OpApps@. The operator is always a +-- variable, and we don't know the fixity yet. +mkHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs +mkHsOpApp e1 op e2 = OpApp noExt e1 (noLoc (HsVar noExt (noLoc op))) e2 + +unqualSplice :: RdrName +unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice")) + +mkUntypedSplice :: SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs +mkUntypedSplice hasParen e = HsUntypedSplice noExt hasParen unqualSplice e + +mkTypedSplice :: SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs +mkTypedSplice hasParen e = HsTypedSplice noExt hasParen unqualSplice e + +mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsSplice GhcPs +mkHsQuasiQuote quoter span quote + = HsQuasiQuote noExt unqualSplice quoter span quote + +unqualQuasiQuote :: RdrName +unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote")) + -- A name (uniquified later) to + -- identify the quasi-quote + +mkHsString :: String -> HsLit (GhcPass p) +mkHsString s = HsString NoSourceText (mkFastString s) + +mkHsStringPrimLit :: FastString -> HsLit (GhcPass p) +mkHsStringPrimLit fs = HsStringPrim NoSourceText (bytesFS fs) + +------------- +userHsLTyVarBndrs :: SrcSpan -> [Located (IdP (GhcPass p))] + -> [LHsTyVarBndr (GhcPass p)] +-- Caller sets location +userHsLTyVarBndrs loc bndrs = [ cL loc (UserTyVar noExt v) | v <- bndrs ] + +userHsTyVarBndrs :: SrcSpan -> [IdP (GhcPass p)] -> [LHsTyVarBndr (GhcPass p)] +-- Caller sets location +userHsTyVarBndrs loc bndrs = [ cL loc (UserTyVar noExt (cL loc v)) + | v <- bndrs ] + + +{- +************************************************************************ +* * + Constructing syntax with no location info +* * +************************************************************************ +-} + +nlHsVar :: IdP (GhcPass id) -> LHsExpr (GhcPass id) +nlHsVar n = noLoc (HsVar noExt (noLoc n)) + +-- NB: Only for LHsExpr **Id** +nlHsDataCon :: DataCon -> LHsExpr GhcTc +nlHsDataCon con = noLoc (HsConLikeOut noExt (RealDataCon con)) + +nlHsLit :: HsLit (GhcPass p) -> LHsExpr (GhcPass p) +nlHsLit n = noLoc (HsLit noExt n) + +nlHsIntLit :: Integer -> LHsExpr (GhcPass p) +nlHsIntLit n = noLoc (HsLit noExt (HsInt noExt (mkIntegralLit n))) + +nlVarPat :: IdP (GhcPass id) -> LPat (GhcPass id) +nlVarPat n = noLoc (VarPat noExt (noLoc n)) + +nlLitPat :: HsLit GhcPs -> LPat GhcPs +nlLitPat l = noLoc (LitPat noExt l) + +nlHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) +nlHsApp f x = noLoc (HsApp noExt f (mkLHsPar x)) + +nlHsSyntaxApps :: SyntaxExpr (GhcPass id) -> [LHsExpr (GhcPass id)] + -> LHsExpr (GhcPass id) +nlHsSyntaxApps (SyntaxExpr { syn_expr = fun + , syn_arg_wraps = arg_wraps + , syn_res_wrap = res_wrap }) args + | [] <- arg_wraps -- in the noSyntaxExpr case + = ASSERT( isIdHsWrapper res_wrap ) + foldl' nlHsApp (noLoc fun) args + + | otherwise + = mkLHsWrap res_wrap (foldl' nlHsApp (noLoc fun) (zipWithEqual "nlHsSyntaxApps" + mkLHsWrap arg_wraps args)) + +nlHsApps :: IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id) +nlHsApps f xs = foldl' nlHsApp (nlHsVar f) xs + +nlHsVarApps :: IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id) +nlHsVarApps f xs = noLoc (foldl' mk (HsVar noExt (noLoc f)) + (map ((HsVar noExt) . noLoc) xs)) + where + mk f a = HsApp noExt (noLoc f) (noLoc a) + +nlConVarPat :: RdrName -> [RdrName] -> LPat GhcPs +nlConVarPat con vars = nlConPat con (map nlVarPat vars) + +nlConVarPatName :: Name -> [Name] -> LPat GhcRn +nlConVarPatName con vars = nlConPatName con (map nlVarPat vars) + +nlInfixConPat :: RdrName -> LPat GhcPs -> LPat GhcPs -> LPat GhcPs +nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) + (InfixCon (parenthesizePat opPrec l) + (parenthesizePat opPrec r))) + +nlConPat :: RdrName -> [LPat GhcPs] -> LPat GhcPs +nlConPat con pats = + noLoc (ConPatIn (noLoc con) (PrefixCon (map (parenthesizePat appPrec) pats))) + +nlConPatName :: Name -> [LPat GhcRn] -> LPat GhcRn +nlConPatName con pats = + noLoc (ConPatIn (noLoc con) (PrefixCon (map (parenthesizePat appPrec) pats))) + +nlNullaryConPat :: IdP (GhcPass p) -> LPat (GhcPass p) +nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon [])) + +nlWildConPat :: DataCon -> LPat GhcPs +nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con)) + (PrefixCon (replicate (dataConSourceArity con) + nlWildPat))) + +nlWildPat :: LPat GhcPs +nlWildPat = noLoc (WildPat noExt ) -- Pre-typechecking + +nlWildPatName :: LPat GhcRn +nlWildPatName = noLoc (WildPat noExt ) -- Pre-typechecking + +nlHsDo :: HsStmtContext Name -> [LStmt GhcPs (LHsExpr GhcPs)] + -> LHsExpr GhcPs +nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts) + +nlHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs +nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2) + +nlHsLam :: LMatch GhcPs (LHsExpr GhcPs) -> LHsExpr GhcPs +nlHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) +nlHsIf :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) + -> LHsExpr (GhcPass id) +nlHsCase :: LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] + -> LHsExpr GhcPs +nlList :: [LHsExpr GhcPs] -> LHsExpr GhcPs + +nlHsLam match = noLoc (HsLam noExt (mkMatchGroup Generated [match])) +nlHsPar e = noLoc (HsPar noExt e) + +-- Note [Rebindable nlHsIf] +-- nlHsIf should generate if-expressions which are NOT subject to +-- RebindableSyntax, so the first field of HsIf is Nothing. (#12080) +nlHsIf cond true false = noLoc (HsIf noExt Nothing cond true false) + +nlHsCase expr matches + = noLoc (HsCase noExt expr (mkMatchGroup Generated matches)) +nlList exprs = noLoc (ExplicitList noExt Nothing exprs) + +nlHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) +nlHsTyVar :: IdP (GhcPass p) -> LHsType (GhcPass p) +nlHsFunTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) +nlHsParTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) + +nlHsAppTy f t = noLoc (HsAppTy noExt f (parenthesizeHsType appPrec t)) +nlHsTyVar x = noLoc (HsTyVar noExt NotPromoted (noLoc x)) +nlHsFunTy a b = noLoc (HsFunTy noExt (parenthesizeHsType funPrec a) b) +nlHsParTy t = noLoc (HsParTy noExt t) + +nlHsTyConApp :: IdP (GhcPass p) -> [LHsType (GhcPass p)] -> LHsType (GhcPass p) +nlHsTyConApp tycon tys = foldl' nlHsAppTy (nlHsTyVar tycon) tys + +nlHsAppKindTy :: + LHsType (GhcPass p) -> LHsKind (GhcPass p) -> LHsType (GhcPass p) +nlHsAppKindTy f k + = noLoc (HsAppKindTy noSrcSpan f (parenthesizeHsType appPrec k)) + +{- +Tuples. All these functions are *pre-typechecker* because they lack +types on the tuple. +-} + +mkLHsTupleExpr :: [LHsExpr (GhcPass a)] -> LHsExpr (GhcPass a) +-- Makes a pre-typechecker boxed tuple, deals with 1 case +mkLHsTupleExpr [e] = e +mkLHsTupleExpr es + = noLoc $ ExplicitTuple noExt (map (noLoc . (Present noExt)) es) Boxed + +mkLHsVarTuple :: [IdP (GhcPass a)] -> LHsExpr (GhcPass a) +mkLHsVarTuple ids = mkLHsTupleExpr (map nlHsVar ids) + +nlTuplePat :: [LPat GhcPs] -> Boxity -> LPat GhcPs +nlTuplePat pats box = noLoc (TuplePat noExt pats box) + +missingTupArg :: HsTupArg GhcPs +missingTupArg = Missing noExt + +mkLHsPatTup :: [LPat GhcRn] -> LPat GhcRn +mkLHsPatTup [] = noLoc $ TuplePat noExt [] Boxed +mkLHsPatTup [lpat] = lpat +mkLHsPatTup lpats = cL (getLoc (head lpats)) $ TuplePat noExt lpats Boxed + +-- The Big equivalents for the source tuple expressions +mkBigLHsVarTup :: [IdP (GhcPass id)] -> LHsExpr (GhcPass id) +mkBigLHsVarTup ids = mkBigLHsTup (map nlHsVar ids) + +mkBigLHsTup :: [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id) +mkBigLHsTup = mkChunkified mkLHsTupleExpr + +-- The Big equivalents for the source tuple patterns +mkBigLHsVarPatTup :: [IdP GhcRn] -> LPat GhcRn +mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs) + +mkBigLHsPatTup :: [LPat GhcRn] -> LPat GhcRn +mkBigLHsPatTup = mkChunkified mkLHsPatTup + +-- $big_tuples +-- #big_tuples# +-- +-- GHCs built in tuples can only go up to 'mAX_TUPLE_SIZE' in arity, but +-- we might concievably want to build such a massive tuple as part of the +-- output of a desugaring stage (notably that for list comprehensions). +-- +-- We call tuples above this size \"big tuples\", and emulate them by +-- creating and pattern matching on >nested< tuples that are expressible +-- by GHC. +-- +-- Nesting policy: it's better to have a 2-tuple of 10-tuples (3 objects) +-- than a 10-tuple of 2-tuples (11 objects), so we want the leaves of any +-- construction to be big. +-- +-- If you just use the 'mkBigCoreTup', 'mkBigCoreVarTupTy', 'mkTupleSelector' +-- and 'mkTupleCase' functions to do all your work with tuples you should be +-- fine, and not have to worry about the arity limitation at all. + +-- | Lifts a \"small\" constructor into a \"big\" constructor by recursive decompositon +mkChunkified :: ([a] -> a) -- ^ \"Small\" constructor function, of maximum input arity 'mAX_TUPLE_SIZE' + -> [a] -- ^ Possible \"big\" list of things to construct from + -> a -- ^ Constructed thing made possible by recursive decomposition +mkChunkified small_tuple as = mk_big_tuple (chunkify as) + where + -- Each sub-list is short enough to fit in a tuple + mk_big_tuple [as] = small_tuple as + mk_big_tuple as_s = mk_big_tuple (chunkify (map small_tuple as_s)) + +chunkify :: [a] -> [[a]] +-- ^ Split a list into lists that are small enough to have a corresponding +-- tuple arity. The sub-lists of the result all have length <= 'mAX_TUPLE_SIZE' +-- But there may be more than 'mAX_TUPLE_SIZE' sub-lists +chunkify xs + | n_xs <= mAX_TUPLE_SIZE = [xs] + | otherwise = split xs + where + n_xs = length xs + split [] = [] + split xs = take mAX_TUPLE_SIZE xs : split (drop mAX_TUPLE_SIZE xs) + +{- +************************************************************************ +* * + LHsSigType and LHsSigWcType +* * +********************************************************************* -} + +mkLHsSigType :: LHsType GhcPs -> LHsSigType GhcPs +mkLHsSigType ty = mkHsImplicitBndrs ty + +mkLHsSigWcType :: LHsType GhcPs -> LHsSigWcType GhcPs +mkLHsSigWcType ty = mkHsWildCardBndrs (mkHsImplicitBndrs ty) + +mkHsSigEnv :: forall a. (LSig GhcRn -> Maybe ([Located Name], a)) + -> [LSig GhcRn] + -> NameEnv a +mkHsSigEnv get_info sigs + = mkNameEnv (mk_pairs ordinary_sigs) + `extendNameEnvList` (mk_pairs gen_dm_sigs) + -- The subtlety is this: in a class decl with a + -- default-method signature as well as a method signature + -- we want the latter to win (#12533) + -- class C x where + -- op :: forall a . x a -> x a + -- default op :: forall b . x b -> x b + -- op x = ...(e :: b -> b)... + -- The scoped type variables of the 'default op', namely 'b', + -- scope over the code for op. The 'forall a' does not! + -- This applies both in the renamer and typechecker, both + -- of which use this function + where + (gen_dm_sigs, ordinary_sigs) = partition is_gen_dm_sig sigs + is_gen_dm_sig (dL->L _ (ClassOpSig _ True _ _)) = True + is_gen_dm_sig _ = False + + mk_pairs :: [LSig GhcRn] -> [(Name, a)] + mk_pairs sigs = [ (n,a) | Just (ns,a) <- map get_info sigs + , (dL->L _ n) <- ns ] + +mkClassOpSigs :: [LSig GhcPs] -> [LSig GhcPs] +-- Convert TypeSig to ClassOpSig +-- The former is what is parsed, but the latter is +-- what we need in class/instance declarations +mkClassOpSigs sigs + = map fiddle sigs + where + fiddle (dL->L loc (TypeSig _ nms ty)) + = cL loc (ClassOpSig noExt False nms (dropWildCards ty)) + fiddle sig = sig + +typeToLHsType :: Type -> LHsType GhcPs +-- ^ Converting a Type to an HsType RdrName +-- This is needed to implement GeneralizedNewtypeDeriving. +-- +-- Note that we use 'getRdrName' extensively, which +-- generates Exact RdrNames rather than strings. +typeToLHsType ty + = go ty + where + go :: Type -> LHsType GhcPs + go ty@(FunTy { ft_af = af, ft_arg = arg, ft_res = res }) + = case af of + VisArg -> nlHsFunTy (go arg) (go res) + InvisArg | (theta, tau) <- tcSplitPhiTy ty + -> noLoc (HsQualTy { hst_ctxt = noLoc (map go theta) + , hst_xqual = noExt + , hst_body = go tau }) + + go ty@(ForAllTy (Bndr _ argf) _) + | (tvs, tau) <- tcSplitForAllTysSameVis argf ty + = noLoc (HsForAllTy { hst_fvf = argToForallVisFlag argf + , hst_bndrs = map go_tv tvs + , hst_xforall = noExt + , hst_body = go tau }) + go (TyVarTy tv) = nlHsTyVar (getRdrName tv) + go (AppTy t1 t2) = nlHsAppTy (go t1) (go t2) + go (LitTy (NumTyLit n)) + = noLoc $ HsTyLit NoExt (HsNumTy NoSourceText n) + go (LitTy (StrTyLit s)) + = noLoc $ HsTyLit NoExt (HsStrTy NoSourceText s) + go ty@(TyConApp tc args) + | tyConAppNeedsKindSig True tc (length args) + -- We must produce an explicit kind signature here to make certain + -- programs kind-check. See Note [Kind signatures in typeToLHsType]. + = nlHsParTy $ noLoc $ HsKindSig NoExt lhs_ty (go (tcTypeKind ty)) + | otherwise = lhs_ty + where + arg_flags :: [ArgFlag] + arg_flags = tyConArgFlags tc args + + lhs_ty :: LHsType GhcPs + lhs_ty = foldl' (\f (arg, flag) -> + let arg' = go arg in + case flag of + Inferred -> f + Specified -> f `nlHsAppKindTy` arg' + Required -> f `nlHsAppTy` arg') + (nlHsTyVar (getRdrName tc)) + (zip args arg_flags) + go (CastTy ty _) = go ty + go (CoercionTy co) = pprPanic "toLHsSigWcType" (ppr co) + + -- Source-language types have _invisible_ kind arguments, + -- so we must remove them here (#8563) + + go_tv :: TyVar -> LHsTyVarBndr GhcPs + go_tv tv = noLoc $ KindedTyVar noExt (noLoc (getRdrName tv)) + (go (tyVarKind tv)) + +{- +Note [Kind signatures in typeToLHsType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are types that typeToLHsType can produce which require explicit kind +signatures in order to kind-check. Here is an example from #14579: + + -- type P :: forall {k} {t :: k}. Proxy t + type P = 'Proxy + + -- type Wat :: forall a. Proxy a -> * + newtype Wat (x :: Proxy (a :: Type)) = MkWat (Maybe a) + deriving Eq + + -- type Wat2 :: forall {a}. Proxy a -> * + type Wat2 = Wat + + -- type Glurp :: * -> * + newtype Glurp a = MkGlurp (Wat2 (P :: Proxy a)) + deriving Eq + +The derived Eq instance for Glurp (without any kind signatures) would be: + + instance Eq a => Eq (Glurp a) where + (==) = coerce @(Wat2 P -> Wat2 P -> Bool) + @(Glurp a -> Glurp a -> Bool) + (==) :: Glurp a -> Glurp a -> Bool + +(Where the visible type applications use types produced by typeToLHsType.) + +The type P (in Wat2 P) has an underspecified kind, so we must ensure that +typeToLHsType ascribes it with its kind: Wat2 (P :: Proxy a). To accomplish +this, whenever we see an application of a tycon to some arguments, we use +the tyConAppNeedsKindSig function to determine if it requires an explicit kind +signature to resolve some ambiguity. (See Note +Note [When does a tycon application need an explicit kind signature?] for a +more detailed explanation of how this works.) + +Note that we pass True to tyConAppNeedsKindSig since we are generated code with +visible kind applications, so even specified arguments count towards injective +positions in the kind of the tycon. +-} + +{- ********************************************************************* +* * + --------- HsWrappers: type args, dict args, casts --------- +* * +********************************************************************* -} + +mkLHsWrap :: HsWrapper -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) +mkLHsWrap co_fn (dL->L loc e) = cL loc (mkHsWrap co_fn e) + +-- Avoid (HsWrap co (HsWrap co' _)). +-- See Note [Detecting forced eta expansion] in DsExpr +mkHsWrap :: HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id) +mkHsWrap co_fn e | isIdHsWrapper co_fn = e +mkHsWrap co_fn (HsWrap _ co_fn' e) = mkHsWrap (co_fn <.> co_fn') e +mkHsWrap co_fn e = HsWrap noExt co_fn e + +mkHsWrapCo :: TcCoercionN -- A Nominal coercion a ~N b + -> HsExpr (GhcPass id) -> HsExpr (GhcPass id) +mkHsWrapCo co e = mkHsWrap (mkWpCastN co) e + +mkHsWrapCoR :: TcCoercionR -- A Representational coercion a ~R b + -> HsExpr (GhcPass id) -> HsExpr (GhcPass id) +mkHsWrapCoR co e = mkHsWrap (mkWpCastR co) e + +mkLHsWrapCo :: TcCoercionN -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) +mkLHsWrapCo co (dL->L loc e) = cL loc (mkHsWrapCo co e) + +mkHsCmdWrap :: HsWrapper -> HsCmd (GhcPass p) -> HsCmd (GhcPass p) +mkHsCmdWrap w cmd | isIdHsWrapper w = cmd + | otherwise = HsCmdWrap noExt w cmd + +mkLHsCmdWrap :: HsWrapper -> LHsCmd (GhcPass p) -> LHsCmd (GhcPass p) +mkLHsCmdWrap w (dL->L loc c) = cL loc (mkHsCmdWrap w c) + +mkHsWrapPat :: HsWrapper -> Pat (GhcPass id) -> Type -> Pat (GhcPass id) +mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p + | otherwise = CoPat noExt co_fn p ty + +mkHsWrapPatCo :: TcCoercionN -> Pat (GhcPass id) -> Type -> Pat (GhcPass id) +mkHsWrapPatCo co pat ty | isTcReflCo co = pat + | otherwise = CoPat noExt (mkWpCastN co) pat ty + +mkHsDictLet :: TcEvBinds -> LHsExpr GhcTc -> LHsExpr GhcTc +mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr + +{- +l +************************************************************************ +* * + Bindings; with a location at the top +* * +************************************************************************ +-} + +mkFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] + -> HsBind GhcPs +-- Not infix, with place holders for coercion and free vars +mkFunBind fn ms = FunBind { fun_id = fn + , fun_matches = mkMatchGroup Generated ms + , fun_co_fn = idHsWrapper + , fun_ext = noExt + , fun_tick = [] } + +mkTopFunBind :: Origin -> Located Name -> [LMatch GhcRn (LHsExpr GhcRn)] + -> HsBind GhcRn +-- In Name-land, with empty bind_fvs +mkTopFunBind origin fn ms = FunBind { fun_id = fn + , fun_matches = mkMatchGroup origin ms + , fun_co_fn = idHsWrapper + , fun_ext = emptyNameSet -- NB: closed + -- binding + , fun_tick = [] } + +mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs +mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs + +mkVarBind :: IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p) +mkVarBind var rhs = cL (getLoc rhs) $ + VarBind { var_ext = noExt, + var_id = var, var_rhs = rhs, var_inline = False } + +mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName) + -> LPat GhcPs -> HsPatSynDir GhcPs -> HsBind GhcPs +mkPatSynBind name details lpat dir = PatSynBind noExt psb + where + psb = PSB{ psb_ext = noExt + , psb_id = name + , psb_args = details + , psb_def = lpat + , psb_dir = dir } + +-- |If any of the matches in the 'FunBind' are infix, the 'FunBind' is +-- considered infix. +isInfixFunBind :: HsBindLR id1 id2 -> Bool +isInfixFunBind (FunBind _ _ (MG _ matches _) _ _) + = any (isInfixMatch . unLoc) (unLoc matches) +isInfixFunBind _ = False + + +------------ +mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat GhcPs] + -> LHsExpr GhcPs -> LHsBind GhcPs +mk_easy_FunBind loc fun pats expr + = cL loc $ mkFunBind (cL loc fun) + [mkMatch (mkPrefixFunRhs (cL loc fun)) pats expr + (noLoc emptyLocalBinds)] + +-- | Make a prefix, non-strict function 'HsMatchContext' +mkPrefixFunRhs :: Located id -> HsMatchContext id +mkPrefixFunRhs n = FunRhs { mc_fun = n + , mc_fixity = Prefix + , mc_strictness = NoSrcStrict } + +------------ +mkMatch :: HsMatchContext (NameOrRdrName (IdP (GhcPass p))) + -> [LPat (GhcPass p)] -> LHsExpr (GhcPass p) + -> Located (HsLocalBinds (GhcPass p)) + -> LMatch (GhcPass p) (LHsExpr (GhcPass p)) +mkMatch ctxt pats expr lbinds + = noLoc (Match { m_ext = noExt + , m_ctxt = ctxt + , m_pats = map paren pats + , m_grhss = GRHSs noExt (unguardedRHS noSrcSpan expr) lbinds }) + where + paren lp@(dL->L l p) + | patNeedsParens appPrec p = cL l (ParPat noExt lp) + | otherwise = lp + +{- +************************************************************************ +* * + Collecting binders +* * +************************************************************************ + +Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg. + +... +where + (x, y) = ... + f i j = ... + [a, b] = ... + +it should return [x, y, f, a, b] (remember, order important). + +Note [Collect binders only after renaming] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +These functions should only be used on HsSyn *after* the renamer, +to return a [Name] or [Id]. Before renaming the record punning +and wild-card mechanism makes it hard to know what is bound. +So these functions should not be applied to (HsSyn RdrName) + +Note [Unlifted id check in isUnliftedHsBind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The function isUnliftedHsBind is used to complain if we make a top-level +binding for a variable of unlifted type. + +Such a binding is illegal if the top-level binding would be unlifted; +but also if the local letrec generated by desugaring AbsBinds would be. +E.g. + f :: Num a => (# a, a #) + g :: Num a => a -> a + f = ...g... + g = ...g... + +The top-level bindings for f,g are not unlifted (because of the Num a =>), +but the local, recursive, monomorphic bindings are: + + t = /\a \(d:Num a). + letrec fm :: (# a, a #) = ...g... + gm :: a -> a = ...f... + in (fm, gm) + +Here the binding for 'fm' is illegal. So generally we check the abe_mono types. + +BUT we have a special case when abs_sig is true; + see HsBinds Note [The abs_sig field of AbsBinds] +-} + +----------------- Bindings -------------------------- + +-- | Should we treat this as an unlifted bind? This will be true for any +-- bind that binds an unlifted variable, but we must be careful around +-- AbsBinds. See Note [Unlifted id check in isUnliftedHsBind]. For usage +-- information, see Note [Strict binds check] is DsBinds. +isUnliftedHsBind :: HsBind GhcTc -> Bool -- works only over typechecked binds +isUnliftedHsBind bind + | AbsBinds { abs_exports = exports, abs_sig = has_sig } <- bind + = if has_sig + then any (is_unlifted_id . abe_poly) exports + else any (is_unlifted_id . abe_mono) exports + -- If has_sig is True we wil never generate a binding for abe_mono, + -- so we don't need to worry about it being unlifted. The abe_poly + -- binding might not be: e.g. forall a. Num a => (# a, a #) + + | otherwise + = any is_unlifted_id (collectHsBindBinders bind) + where + is_unlifted_id id = isUnliftedType (idType id) + +-- | Is a binding a strict variable or pattern bind (e.g. @!x = ...@)? +isBangedHsBind :: HsBind GhcTc -> Bool +isBangedHsBind (AbsBinds { abs_binds = binds }) + = anyBag (isBangedHsBind . unLoc) binds +isBangedHsBind (FunBind {fun_matches = matches}) + | [dL->L _ match] <- unLoc $ mg_alts matches + , FunRhs{mc_strictness = SrcStrict} <- m_ctxt match + = True +isBangedHsBind (PatBind {pat_lhs = pat}) + = isBangedLPat pat +isBangedHsBind _ + = False + +collectLocalBinders :: HsLocalBindsLR (GhcPass idL) (GhcPass idR) + -> [IdP (GhcPass idL)] +collectLocalBinders (HsValBinds _ binds) = collectHsIdBinders binds + -- No pattern synonyms here +collectLocalBinders (HsIPBinds {}) = [] +collectLocalBinders (EmptyLocalBinds _) = [] +collectLocalBinders (XHsLocalBindsLR _) = [] + +collectHsIdBinders, collectHsValBinders + :: HsValBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)] +-- Collect Id binders only, or Ids + pattern synonyms, respectively +collectHsIdBinders = collect_hs_val_binders True +collectHsValBinders = collect_hs_val_binders False + +collectHsBindBinders :: (SrcSpanLess (LPat p) ~ Pat p, HasSrcSpan (LPat p))=> + HsBindLR p idR -> [IdP p] +-- Collect both Ids and pattern-synonym binders +collectHsBindBinders b = collect_bind False b [] + +collectHsBindsBinders :: LHsBindsLR (GhcPass p) idR -> [IdP (GhcPass p)] +collectHsBindsBinders binds = collect_binds False binds [] + +collectHsBindListBinders :: [LHsBindLR (GhcPass p) idR] -> [IdP (GhcPass p)] +-- Same as collectHsBindsBinders, but works over a list of bindings +collectHsBindListBinders = foldr (collect_bind False . unLoc) [] + +collect_hs_val_binders :: Bool -> HsValBindsLR (GhcPass idL) (GhcPass idR) + -> [IdP (GhcPass idL)] +collect_hs_val_binders ps (ValBinds _ binds _) = collect_binds ps binds [] +collect_hs_val_binders ps (XValBindsLR (NValBinds binds _)) + = collect_out_binds ps binds + +collect_out_binds :: Bool -> [(RecFlag, LHsBinds (GhcPass p))] -> + [IdP (GhcPass p)] +collect_out_binds ps = foldr (collect_binds ps . snd) [] + +collect_binds :: Bool -> LHsBindsLR (GhcPass p) idR -> + [IdP (GhcPass p)] -> [IdP (GhcPass p)] +-- Collect Ids, or Ids + pattern synonyms, depending on boolean flag +collect_binds ps binds acc = foldrBag (collect_bind ps . unLoc) acc binds + +collect_bind :: (SrcSpanLess (LPat p) ~ Pat p , HasSrcSpan (LPat p)) => + Bool -> HsBindLR p idR -> [IdP p] -> [IdP p] +collect_bind _ (PatBind { pat_lhs = p }) acc = collect_lpat p acc +collect_bind _ (FunBind { fun_id = (dL->L _ f) }) acc = f : acc +collect_bind _ (VarBind { var_id = f }) acc = f : acc +collect_bind _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++ acc + -- I don't think we want the binders from the abe_binds + + -- binding (hence see AbsBinds) is in zonking in TcHsSyn +collect_bind omitPatSyn (PatSynBind _ (PSB { psb_id = (dL->L _ ps) })) acc + | omitPatSyn = acc + | otherwise = ps : acc +collect_bind _ (PatSynBind _ (XPatSynBind _)) acc = acc +collect_bind _ (XHsBindsLR _) acc = acc + +collectMethodBinders :: LHsBindsLR idL idR -> [Located (IdP idL)] +-- Used exclusively for the bindings of an instance decl which are all FunBinds +collectMethodBinders binds = foldrBag (get . unLoc) [] binds + where + get (FunBind { fun_id = f }) fs = f : fs + get _ fs = fs + -- Someone else complains about non-FunBinds + +----------------- Statements -------------------------- +collectLStmtsBinders :: [LStmtLR (GhcPass idL) (GhcPass idR) body] + -> [IdP (GhcPass idL)] +collectLStmtsBinders = concatMap collectLStmtBinders + +collectStmtsBinders :: [StmtLR (GhcPass idL) (GhcPass idR) body] + -> [IdP (GhcPass idL)] +collectStmtsBinders = concatMap collectStmtBinders + +collectLStmtBinders :: LStmtLR (GhcPass idL) (GhcPass idR) body + -> [IdP (GhcPass idL)] +collectLStmtBinders = collectStmtBinders . unLoc + +collectStmtBinders :: StmtLR (GhcPass idL) (GhcPass idR) body + -> [IdP (GhcPass idL)] + -- Id Binders for a Stmt... [but what about pattern-sig type vars]? +collectStmtBinders (BindStmt _ pat _ _ _) = collectPatBinders pat +collectStmtBinders (LetStmt _ binds) = collectLocalBinders (unLoc binds) +collectStmtBinders (BodyStmt {}) = [] +collectStmtBinders (LastStmt {}) = [] +collectStmtBinders (ParStmt _ xs _ _) = collectLStmtsBinders + $ [s | ParStmtBlock _ ss _ _ <- xs, s <- ss] +collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts +collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss +collectStmtBinders (ApplicativeStmt _ args _) = concatMap collectArgBinders args + where + collectArgBinders (_, ApplicativeArgOne _ pat _ _) = collectPatBinders pat + collectArgBinders (_, ApplicativeArgMany _ _ _ pat) = collectPatBinders pat + collectArgBinders _ = [] +collectStmtBinders XStmtLR{} = panic "collectStmtBinders" + + +----------------- Patterns -------------------------- +collectPatBinders :: LPat (GhcPass p) -> [IdP (GhcPass p)] +collectPatBinders pat = collect_lpat pat [] + +collectPatsBinders :: [LPat (GhcPass p)] -> [IdP (GhcPass p)] +collectPatsBinders pats = foldr collect_lpat [] pats + +------------- +collect_lpat :: (SrcSpanLess (LPat p) ~ Pat p , HasSrcSpan (LPat p)) => + LPat p -> [IdP p] -> [IdP p] +collect_lpat p bndrs + = go (unLoc p) + where + go (VarPat _ var) = unLoc var : bndrs + go (WildPat _) = bndrs + go (LazyPat _ pat) = collect_lpat pat bndrs + go (BangPat _ pat) = collect_lpat pat bndrs + go (AsPat _ a pat) = unLoc a : collect_lpat pat bndrs + go (ViewPat _ _ pat) = collect_lpat pat bndrs + go (ParPat _ pat) = collect_lpat pat bndrs + + go (ListPat _ pats) = foldr collect_lpat bndrs pats + go (TuplePat _ pats _) = foldr collect_lpat bndrs pats + go (SumPat _ pat _ _) = collect_lpat pat bndrs + + go (ConPatIn _ ps) = foldr collect_lpat bndrs (hsConPatArgs ps) + go (ConPatOut {pat_args=ps}) = foldr collect_lpat bndrs (hsConPatArgs ps) + -- See Note [Dictionary binders in ConPatOut] + go (LitPat _ _) = bndrs + go (NPat {}) = bndrs + go (NPlusKPat _ n _ _ _ _) = unLoc n : bndrs + + go (SigPat _ pat _) = collect_lpat pat bndrs + + go (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat))) + = go pat + go (SplicePat _ _) = bndrs + go (CoPat _ _ pat _) = go pat + go (XPat {}) = bndrs + +{- +Note [Dictionary binders in ConPatOut] See also same Note in DsArrows +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Do *not* gather (a) dictionary and (b) dictionary bindings as binders +of a ConPatOut pattern. For most calls it doesn't matter, because +it's pre-typechecker and there are no ConPatOuts. But it does matter +more in the desugarer; for example, DsUtils.mkSelectorBinds uses +collectPatBinders. In a lazy pattern, for example f ~(C x y) = ..., +we want to generate bindings for x,y but not for dictionaries bound by +C. (The type checker ensures they would not be used.) + +Desugaring of arrow case expressions needs these bindings (see DsArrows +and arrowcase1), but SPJ (Jan 2007) says it's safer for it to use its +own pat-binder-collector: + +Here's the problem. Consider + +data T a where + C :: Num a => a -> Int -> T a + +f ~(C (n+1) m) = (n,m) + +Here, the pattern (C (n+1)) binds a hidden dictionary (d::Num a), +and *also* uses that dictionary to match the (n+1) pattern. Yet, the +variables bound by the lazy pattern are n,m, *not* the dictionary d. +So in mkSelectorBinds in DsUtils, we want just m,n as the variables bound. +-} + +hsGroupBinders :: HsGroup GhcRn -> [Name] +hsGroupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls, + hs_fords = foreign_decls }) + = collectHsValBinders val_decls + ++ hsTyClForeignBinders tycl_decls foreign_decls +hsGroupBinders (XHsGroup {}) = panic "hsGroupBinders" + +hsTyClForeignBinders :: [TyClGroup GhcRn] + -> [LForeignDecl GhcRn] + -> [Name] +-- We need to look at instance declarations too, +-- because their associated types may bind data constructors +hsTyClForeignBinders tycl_decls foreign_decls + = map unLoc (hsForeignDeclsBinders foreign_decls) + ++ getSelectorNames + (foldMap (foldMap hsLTyClDeclBinders . group_tyclds) tycl_decls + `mappend` + foldMap (foldMap hsLInstDeclBinders . group_instds) tycl_decls) + where + getSelectorNames :: ([Located Name], [LFieldOcc GhcRn]) -> [Name] + getSelectorNames (ns, fs) = map unLoc ns ++ map (extFieldOcc . unLoc) fs + +------------------- +hsLTyClDeclBinders :: Located (TyClDecl pass) + -> ([Located (IdP pass)], [LFieldOcc pass]) +-- ^ Returns all the /binding/ names of the decl. The first one is +-- guaranteed to be the name of the decl. The first component +-- represents all binding names except record fields; the second +-- represents field occurrences. For record fields mentioned in +-- multiple constructors, the SrcLoc will be from the first occurrence. +-- +-- Each returned (Located name) has a SrcSpan for the /whole/ declaration. +-- See Note [SrcSpan for binders] + +hsLTyClDeclBinders (dL->L loc (FamDecl { tcdFam = FamilyDecl + { fdLName = (dL->L _ name) } })) + = ([cL loc name], []) +hsLTyClDeclBinders (dL->L _ (FamDecl { tcdFam = XFamilyDecl _ })) + = panic "hsLTyClDeclBinders" +hsLTyClDeclBinders (dL->L loc (SynDecl + { tcdLName = (dL->L _ name) })) + = ([cL loc name], []) +hsLTyClDeclBinders (dL->L loc (ClassDecl + { tcdLName = (dL->L _ cls_name) + , tcdSigs = sigs + , tcdATs = ats })) + = (cL loc cls_name : + [ cL fam_loc fam_name | (dL->L fam_loc (FamilyDecl + { fdLName = L _ fam_name })) <- ats ] + ++ + [ cL mem_loc mem_name | (dL->L mem_loc (ClassOpSig _ False ns _)) <- sigs + , (dL->L _ mem_name) <- ns ] + , []) +hsLTyClDeclBinders (dL->L loc (DataDecl { tcdLName = (dL->L _ name) + , tcdDataDefn = defn })) + = (\ (xs, ys) -> (cL loc name : xs, ys)) $ hsDataDefnBinders defn +hsLTyClDeclBinders (dL->L _ (XTyClDecl _)) = panic "hsLTyClDeclBinders" +hsLTyClDeclBinders _ = panic "hsLTyClDeclBinders: Impossible Match" + -- due to #15884 + + +------------------- +hsForeignDeclsBinders :: [LForeignDecl pass] -> [Located (IdP pass)] +-- See Note [SrcSpan for binders] +hsForeignDeclsBinders foreign_decls + = [ cL decl_loc n + | (dL->L decl_loc (ForeignImport { fd_name = (dL->L _ n) })) + <- foreign_decls] + + +------------------- +hsPatSynSelectors :: HsValBinds (GhcPass p) -> [IdP (GhcPass p)] +-- Collects record pattern-synonym selectors only; the pattern synonym +-- names are collected by collectHsValBinders. +hsPatSynSelectors (ValBinds _ _ _) = panic "hsPatSynSelectors" +hsPatSynSelectors (XValBindsLR (NValBinds binds _)) + = foldrBag addPatSynSelector [] . unionManyBags $ map snd binds + +addPatSynSelector:: LHsBind p -> [IdP p] -> [IdP p] +addPatSynSelector bind sels + | PatSynBind _ (PSB { psb_args = RecCon as }) <- unLoc bind + = map (unLoc . recordPatSynSelectorId) as ++ sels + | otherwise = sels + +getPatSynBinds :: [(RecFlag, LHsBinds id)] -> [PatSynBind id id] +getPatSynBinds binds + = [ psb | (_, lbinds) <- binds + , (dL->L _ (PatSynBind _ psb)) <- bagToList lbinds ] + +------------------- +hsLInstDeclBinders :: LInstDecl (GhcPass p) + -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) +hsLInstDeclBinders (dL->L _ (ClsInstD + { cid_inst = ClsInstDecl + { cid_datafam_insts = dfis }})) + = foldMap (hsDataFamInstBinders . unLoc) dfis +hsLInstDeclBinders (dL->L _ (DataFamInstD { dfid_inst = fi })) + = hsDataFamInstBinders fi +hsLInstDeclBinders (dL->L _ (TyFamInstD {})) = mempty +hsLInstDeclBinders (dL->L _ (ClsInstD _ (XClsInstDecl {}))) + = panic "hsLInstDeclBinders" +hsLInstDeclBinders (dL->L _ (XInstDecl _)) + = panic "hsLInstDeclBinders" +hsLInstDeclBinders _ = panic "hsLInstDeclBinders: Impossible Match" + -- due to #15884 + +------------------- +-- the SrcLoc returned are for the whole declarations, not just the names +hsDataFamInstBinders :: DataFamInstDecl pass + -> ([Located (IdP pass)], [LFieldOcc pass]) +hsDataFamInstBinders (DataFamInstDecl { dfid_eqn = HsIB { hsib_body = + FamEqn { feqn_rhs = defn }}}) + = hsDataDefnBinders defn + -- There can't be repeated symbols because only data instances have binders +hsDataFamInstBinders (DataFamInstDecl + { dfid_eqn = HsIB { hsib_body = XFamEqn _}}) + = panic "hsDataFamInstBinders" +hsDataFamInstBinders (DataFamInstDecl (XHsImplicitBndrs _)) + = panic "hsDataFamInstBinders" + +------------------- +-- the SrcLoc returned are for the whole declarations, not just the names +hsDataDefnBinders :: HsDataDefn pass -> ([Located (IdP pass)], [LFieldOcc pass]) +hsDataDefnBinders (HsDataDefn { dd_cons = cons }) + = hsConDeclsBinders cons + -- See Note [Binders in family instances] +hsDataDefnBinders (XHsDataDefn _) = panic "hsDataDefnBinders" + +------------------- +type Seen pass = [LFieldOcc pass] -> [LFieldOcc pass] + -- Filters out ones that have already been seen + +hsConDeclsBinders :: [LConDecl pass] -> ([Located (IdP pass)], [LFieldOcc pass]) + -- See hsLTyClDeclBinders for what this does + -- The function is boringly complicated because of the records + -- And since we only have equality, we have to be a little careful +hsConDeclsBinders cons + = go id cons + where + go :: Seen pass -> [LConDecl pass] + -> ([Located (IdP pass)], [LFieldOcc pass]) + go _ [] = ([], []) + go remSeen (r:rs) + -- Don't re-mangle the location of field names, because we don't + -- have a record of the full location of the field declaration anyway + = let loc = getLoc r + in case unLoc r of + -- remove only the first occurrence of any seen field in order to + -- avoid circumventing detection of duplicate fields (#9156) + ConDeclGADT { con_names = names, con_args = args } + -> (map (cL loc . unLoc) names ++ ns, flds ++ fs) + where + (remSeen', flds) = get_flds remSeen args + (ns, fs) = go remSeen' rs + + ConDeclH98 { con_name = name, con_args = args } + -> ([cL loc (unLoc name)] ++ ns, flds ++ fs) + where + (remSeen', flds) = get_flds remSeen args + (ns, fs) = go remSeen' rs + + XConDecl _ -> panic "hsConDeclsBinders" + + get_flds :: Seen pass -> HsConDeclDetails pass + -> (Seen pass, [LFieldOcc pass]) + get_flds remSeen (RecCon flds) + = (remSeen', fld_names) + where + fld_names = remSeen (concatMap (cd_fld_names . unLoc) (unLoc flds)) + remSeen' = foldr (.) remSeen + [deleteBy ((==) `on` unLoc . rdrNameFieldOcc . unLoc) v + | v <- fld_names] + get_flds remSeen _ + = (remSeen, []) + +{- + +Note [SrcSpan for binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +When extracting the (Located RdrNme) for a binder, at least for the +main name (the TyCon of a type declaration etc), we want to give it +the @SrcSpan@ of the whole /declaration/, not just the name itself +(which is how it appears in the syntax tree). This SrcSpan (for the +entire declaration) is used as the SrcSpan for the Name that is +finally produced, and hence for error messages. (See #8607.) + +Note [Binders in family instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a type or data family instance declaration, the type +constructor is an *occurrence* not a binding site + type instance T Int = Int -> Int -- No binders + data instance S Bool = S1 | S2 -- Binders are S1,S2 + + +************************************************************************ +* * + Collecting binders the user did not write +* * +************************************************************************ + +The job of this family of functions is to run through binding sites and find the set of all Names +that were defined "implicitly", without being explicitly written by the user. + +The main purpose is to find names introduced by record wildcards so that we can avoid +warning the user when they don't use those names (#4404) + +Since the addition of -Wunused-record-wildcards, this function returns a pair +of [(SrcSpan, [Name])]. Each element of the list is one set of implicit +binders, the first component of the tuple is the document describes the possible +fix to the problem (by removing the ..). + +This means there is some unfortunate coupling between this function and where it +is used but it's only used for one specific purpose in one place so it seemed +easier. +-} + +lStmtsImplicits :: [LStmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR)))] + -> [(SrcSpan, [Name])] +lStmtsImplicits = hs_lstmts + where + hs_lstmts :: [LStmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR)))] + -> [(SrcSpan, [Name])] + hs_lstmts = concatMap (hs_stmt . unLoc) + + hs_stmt :: StmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR))) + -> [(SrcSpan, [Name])] + hs_stmt (BindStmt _ pat _ _ _) = lPatImplicits pat + hs_stmt (ApplicativeStmt _ args _) = concatMap do_arg args + where do_arg (_, ApplicativeArgOne _ pat _ _) = lPatImplicits pat + do_arg (_, ApplicativeArgMany _ stmts _ _) = hs_lstmts stmts + do_arg (_, XApplicativeArg _) = panic "lStmtsImplicits" + hs_stmt (LetStmt _ binds) = hs_local_binds (unLoc binds) + hs_stmt (BodyStmt {}) = [] + hs_stmt (LastStmt {}) = [] + hs_stmt (ParStmt _ xs _ _) = hs_lstmts [s | ParStmtBlock _ ss _ _ <- xs + , s <- ss] + hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts + hs_stmt (RecStmt { recS_stmts = ss }) = hs_lstmts ss + hs_stmt (XStmtLR {}) = panic "lStmtsImplicits" + + hs_local_binds (HsValBinds _ val_binds) = hsValBindsImplicits val_binds + hs_local_binds (HsIPBinds {}) = [] + hs_local_binds (EmptyLocalBinds _) = [] + hs_local_binds (XHsLocalBindsLR _) = [] + +hsValBindsImplicits :: HsValBindsLR GhcRn (GhcPass idR) -> [(SrcSpan, [Name])] +hsValBindsImplicits (XValBindsLR (NValBinds binds _)) + = concatMap (lhsBindsImplicits . snd) binds +hsValBindsImplicits (ValBinds _ binds _) + = lhsBindsImplicits binds + +lhsBindsImplicits :: LHsBindsLR GhcRn idR -> [(SrcSpan, [Name])] +lhsBindsImplicits = foldBag (++) (lhs_bind . unLoc) [] + where + lhs_bind (PatBind { pat_lhs = lpat }) = lPatImplicits lpat + lhs_bind _ = [] + +lPatImplicits :: LPat GhcRn -> [(SrcSpan, [Name])] +lPatImplicits = hs_lpat + where + hs_lpat lpat = hs_pat (unLoc lpat) + + hs_lpats = foldr (\pat rest -> hs_lpat pat ++ rest) [] + + hs_pat (LazyPat _ pat) = hs_lpat pat + hs_pat (BangPat _ pat) = hs_lpat pat + hs_pat (AsPat _ _ pat) = hs_lpat pat + hs_pat (ViewPat _ _ pat) = hs_lpat pat + hs_pat (ParPat _ pat) = hs_lpat pat + hs_pat (ListPat _ pats) = hs_lpats pats + hs_pat (TuplePat _ pats _) = hs_lpats pats + + hs_pat (SigPat _ pat _) = hs_lpat pat + hs_pat (CoPat _ _ pat _) = hs_pat pat + + hs_pat (ConPatIn n ps) = details n ps + hs_pat (ConPatOut {pat_con=con, pat_args=ps}) = details (fmap conLikeName con) ps + + hs_pat _ = [] + + details :: Located Name -> HsConPatDetails GhcRn -> [(SrcSpan, [Name])] + details _ (PrefixCon ps) = hs_lpats ps + details n (RecCon fs) = + [(err_loc, collectPatsBinders implicit_pats) | Just{} <- [rec_dotdot fs] ] + ++ hs_lpats explicit_pats + + where implicit_pats = map (hsRecFieldArg . unLoc) implicit + explicit_pats = map (hsRecFieldArg . unLoc) explicit + + + (explicit, implicit) = partitionEithers [if pat_explicit then Left fld else Right fld + | (i, fld) <- [0..] `zip` rec_flds fs + , let pat_explicit = + maybe True ((i<) . unLoc) + (rec_dotdot fs)] + err_loc = maybe (getLoc n) getLoc (rec_dotdot fs) + + details _ (InfixCon p1 p2) = hs_lpat p1 ++ hs_lpat p2 diff --git a/compiler/hsSyn/PlaceHolder.hs b/compiler/hsSyn/PlaceHolder.hs new file mode 100644 --- /dev/null +++ b/compiler/hsSyn/PlaceHolder.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE StandaloneDeriving #-} + +module PlaceHolder where + +import Name +import NameSet +import RdrName +import Var + + + +{- +%************************************************************************ +%* * +\subsection{Annotating the syntax} +%* * +%************************************************************************ +-} + +-- NB: These are intentionally open, allowing API consumers (like Haddock) +-- to declare new instances + +placeHolderNamesTc :: NameSet +placeHolderNamesTc = emptyNameSet + +{- +TODO:AZ: remove this, and check if we still need all the UndecidableInstances + +Note [Pass sensitive types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Since the same AST types are re-used through parsing,renaming and type +checking there are naturally some places in the AST that do not have +any meaningful value prior to the pass they are assigned a value. + +Historically these have been filled in with place holder values of the form + + panic "error message" + +This has meant the AST is difficult to traverse using standard generic +programming techniques. The problem is addressed by introducing +pass-specific data types, implemented as a pair of open type families, +one for PostTc and one for PostRn. These are then explicitly populated +with a PlaceHolder value when they do not yet have meaning. + +In terms of actual usage, we have the following + + PostTc id Kind + PostTc id Type + + PostRn id Fixity + PostRn id NameSet + +TcId and Var are synonyms for Id + +Unfortunately the type checker termination checking conditions fail for the +DataId constraint type based on this, so even though it is safe the +UndecidableInstances pragma is required where this is used. +-} + + +-- |Follow the @id@, but never beyond Name. This is used in a 'HsMatchContext', +-- for printing messages related to a 'Match' +type family NameOrRdrName id where + NameOrRdrName Id = Name + NameOrRdrName Name = Name + NameOrRdrName RdrName = RdrName diff --git a/compiler/iface/BinFingerprint.hs b/compiler/iface/BinFingerprint.hs new file mode 100644 --- /dev/null +++ b/compiler/iface/BinFingerprint.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE CPP #-} + +-- | Computing fingerprints of values serializeable with GHC's "Binary" module. +module BinFingerprint + ( -- * Computing fingerprints + fingerprintBinMem + , computeFingerprint + , putNameLiterally + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import Fingerprint +import Binary +import Name +import Panic +import Util + +fingerprintBinMem :: BinHandle -> IO Fingerprint +fingerprintBinMem bh = withBinBuffer bh f + where + f bs = + -- we need to take care that we force the result here + -- lest a reference to the ByteString may leak out of + -- withBinBuffer. + let fp = fingerprintByteString bs + in fp `seq` return fp + +computeFingerprint :: (Binary a) + => (BinHandle -> Name -> IO ()) + -> a + -> IO Fingerprint +computeFingerprint put_nonbinding_name a = do + bh <- fmap set_user_data $ openBinMem (3*1024) -- just less than a block + put_ bh a + fp <- fingerprintBinMem bh + return fp + where + set_user_data bh = + setUserData bh $ newWriteState put_nonbinding_name putNameLiterally putFS + +-- | Used when we want to fingerprint a structure without depending on the +-- fingerprints of external Names that it refers to. +putNameLiterally :: BinHandle -> Name -> IO () +putNameLiterally bh name = ASSERT( isExternalName name ) do + put_ bh $! nameModule name + put_ bh $! nameOccName name diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs new file mode 100644 --- /dev/null +++ b/compiler/iface/IfaceSyn.hs @@ -0,0 +1,2325 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 +-} + +{-# LANGUAGE CPP #-} + +module IfaceSyn ( + module IfaceType, + + IfaceDecl(..), IfaceFamTyConFlav(..), IfaceClassOp(..), IfaceAT(..), + IfaceConDecl(..), IfaceConDecls(..), IfaceEqSpec, + IfaceExpr(..), IfaceAlt, IfaceLetBndr(..), IfaceJoinInfo(..), + IfaceBinding(..), IfaceConAlt(..), + IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..), + IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget, + IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..), + IfaceClassBody(..), + IfaceBang(..), + IfaceSrcBang(..), SrcUnpackedness(..), SrcStrictness(..), + IfaceAxBranch(..), + IfaceTyConParent(..), + IfaceCompleteMatch(..), + + -- * Binding names + IfaceTopBndr, + putIfaceTopBndr, getIfaceTopBndr, + + -- Misc + ifaceDeclImplicitBndrs, visibleIfConDecls, + ifaceDeclFingerprints, + + -- Free Names + freeNamesIfDecl, freeNamesIfRule, freeNamesIfFamInst, + + -- Pretty printing + pprIfaceExpr, + pprIfaceDecl, + AltPpr(..), ShowSub(..), ShowHowMuch(..), showToIface, showToHeader + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import IfaceType +import BinFingerprint +import CoreSyn( IsOrphan, isOrphan ) +import PprCore() -- Printing DFunArgs +import Demand +import Class +import FieldLabel +import NameSet +import CoAxiom ( BranchIndex ) +import Name +import CostCentre +import Literal +import ForeignCall +import Annotations( AnnPayload, AnnTarget ) +import BasicTypes +import Outputable +import Module +import SrcLoc +import Fingerprint +import Binary +import BooleanFormula ( BooleanFormula, pprBooleanFormula, isTrue ) +import Var( VarBndr(..), binderVar ) +import TyCon ( Role (..), Injectivity(..), tyConBndrVisArgFlag ) +import Util( dropList, filterByList ) +import DataCon (SrcStrictness(..), SrcUnpackedness(..)) +import Lexeme (isLexSym) + +import Control.Monad +import System.IO.Unsafe + +infixl 3 &&& + +{- +************************************************************************ +* * + Declarations +* * +************************************************************************ +-} + +-- | A binding top-level 'Name' in an interface file (e.g. the name of an +-- 'IfaceDecl'). +type IfaceTopBndr = Name + -- It's convenient to have a Name in the IfaceSyn, although in each + -- case the namespace is implied by the context. However, having an + -- Name makes things like ifaceDeclImplicitBndrs and ifaceDeclFingerprints + -- very convenient. Moreover, having the key of the binder means that + -- we can encode known-key things cleverly in the symbol table. See Note + -- [Symbol table representation of Names] + -- + -- We don't serialise the namespace onto the disk though; rather we + -- drop it when serialising and add it back in when deserialising. + +getIfaceTopBndr :: BinHandle -> IO IfaceTopBndr +getIfaceTopBndr bh = get bh + +putIfaceTopBndr :: BinHandle -> IfaceTopBndr -> IO () +putIfaceTopBndr bh name = + case getUserData bh of + UserData{ ud_put_binding_name = put_binding_name } -> + --pprTrace "putIfaceTopBndr" (ppr name) $ + put_binding_name bh name + +data IfaceDecl + = IfaceId { ifName :: IfaceTopBndr, + ifType :: IfaceType, + ifIdDetails :: IfaceIdDetails, + ifIdInfo :: IfaceIdInfo } + + | IfaceData { ifName :: IfaceTopBndr, -- Type constructor + ifBinders :: [IfaceTyConBinder], + ifResKind :: IfaceType, -- Result kind of type constructor + ifCType :: Maybe CType, -- C type for CAPI FFI + ifRoles :: [Role], -- Roles + ifCtxt :: IfaceContext, -- The "stupid theta" + ifCons :: IfaceConDecls, -- Includes new/data/data family info + ifGadtSyntax :: Bool, -- True <=> declared using + -- GADT syntax + ifParent :: IfaceTyConParent -- The axiom, for a newtype, + -- or data/newtype family instance + } + + | IfaceSynonym { ifName :: IfaceTopBndr, -- Type constructor + ifRoles :: [Role], -- Roles + ifBinders :: [IfaceTyConBinder], + ifResKind :: IfaceKind, -- Kind of the *result* + ifSynRhs :: IfaceType } + + | IfaceFamily { ifName :: IfaceTopBndr, -- Type constructor + ifResVar :: Maybe IfLclName, -- Result variable name, used + -- only for pretty-printing + -- with --show-iface + ifBinders :: [IfaceTyConBinder], + ifResKind :: IfaceKind, -- Kind of the *tycon* + ifFamFlav :: IfaceFamTyConFlav, + ifFamInj :: Injectivity } -- injectivity information + + | IfaceClass { ifName :: IfaceTopBndr, -- Name of the class TyCon + ifRoles :: [Role], -- Roles + ifBinders :: [IfaceTyConBinder], + ifFDs :: [FunDep IfLclName], -- Functional dependencies + ifBody :: IfaceClassBody -- Methods, superclasses, ATs + } + + | IfaceAxiom { ifName :: IfaceTopBndr, -- Axiom name + ifTyCon :: IfaceTyCon, -- LHS TyCon + ifRole :: Role, -- Role of axiom + ifAxBranches :: [IfaceAxBranch] -- Branches + } + + | IfacePatSyn { ifName :: IfaceTopBndr, -- Name of the pattern synonym + ifPatIsInfix :: Bool, + ifPatMatcher :: (IfExtName, Bool), + ifPatBuilder :: Maybe (IfExtName, Bool), + -- Everything below is redundant, + -- but needed to implement pprIfaceDecl + ifPatUnivBndrs :: [IfaceForAllBndr], + ifPatExBndrs :: [IfaceForAllBndr], + ifPatProvCtxt :: IfaceContext, + ifPatReqCtxt :: IfaceContext, + ifPatArgs :: [IfaceType], + ifPatTy :: IfaceType, + ifFieldLabels :: [FieldLabel] } + +-- See also 'ClassBody' +data IfaceClassBody + -- Abstract classes don't specify their body; they only occur in @hs-boot@ and + -- @hsig@ files. + = IfAbstractClass + | IfConcreteClass { + ifClassCtxt :: IfaceContext, -- Super classes + ifATs :: [IfaceAT], -- Associated type families + ifSigs :: [IfaceClassOp], -- Method signatures + ifMinDef :: BooleanFormula IfLclName -- Minimal complete definition + } + +data IfaceTyConParent + = IfNoParent + | IfDataInstance + IfExtName -- Axiom name + IfaceTyCon -- Family TyCon (pretty-printing only, not used in TcIface) + -- see Note [Pretty printing via IfaceSyn] in PprTyThing + IfaceAppArgs -- Arguments of the family TyCon + +data IfaceFamTyConFlav + = IfaceDataFamilyTyCon -- Data family + | IfaceOpenSynFamilyTyCon + | IfaceClosedSynFamilyTyCon (Maybe (IfExtName, [IfaceAxBranch])) + -- ^ Name of associated axiom and branches for pretty printing purposes, + -- or 'Nothing' for an empty closed family without an axiom + -- See Note [Pretty printing via IfaceSyn] in PprTyThing + | IfaceAbstractClosedSynFamilyTyCon + | IfaceBuiltInSynFamTyCon -- for pretty printing purposes only + +data IfaceClassOp + = IfaceClassOp IfaceTopBndr + IfaceType -- Class op type + (Maybe (DefMethSpec IfaceType)) -- Default method + -- The types of both the class op itself, + -- and the default method, are *not* quantified + -- over the class variables + +data IfaceAT = IfaceAT -- See Class.ClassATItem + IfaceDecl -- The associated type declaration + (Maybe IfaceType) -- Default associated type instance, if any + + +-- This is just like CoAxBranch +data IfaceAxBranch = IfaceAxBranch { ifaxbTyVars :: [IfaceTvBndr] + , ifaxbEtaTyVars :: [IfaceTvBndr] + , ifaxbCoVars :: [IfaceIdBndr] + , ifaxbLHS :: IfaceAppArgs + , ifaxbRoles :: [Role] + , ifaxbRHS :: IfaceType + , ifaxbIncomps :: [BranchIndex] } + -- See Note [Storing compatibility] in CoAxiom + +data IfaceConDecls + = IfAbstractTyCon -- c.f TyCon.AbstractTyCon + | IfDataTyCon [IfaceConDecl] -- Data type decls + | IfNewTyCon IfaceConDecl -- Newtype decls + +-- For IfDataTyCon and IfNewTyCon we store: +-- * the data constructor(s); +-- The field labels are stored individually in the IfaceConDecl +-- (there is some redundancy here, because a field label may occur +-- in multiple IfaceConDecls and represent the same field label) + +data IfaceConDecl + = IfCon { + ifConName :: IfaceTopBndr, -- Constructor name + ifConWrapper :: Bool, -- True <=> has a wrapper + ifConInfix :: Bool, -- True <=> declared infix + + -- The universal type variables are precisely those + -- of the type constructor of this data constructor + -- This is *easy* to guarantee when creating the IfCon + -- but it's not so easy for the original TyCon/DataCon + -- So this guarantee holds for IfaceConDecl, but *not* for DataCon + + ifConExTCvs :: [IfaceBndr], -- Existential ty/covars + ifConUserTvBinders :: [IfaceForAllBndr], + -- The tyvars, in the order the user wrote them + -- INVARIANT: the set of tyvars in ifConUserTvBinders is exactly the + -- set of tyvars (*not* covars) of ifConExTCvs, unioned + -- with the set of ifBinders (from the parent IfaceDecl) + -- whose tyvars do not appear in ifConEqSpec + -- See Note [DataCon user type variable binders] in DataCon + ifConEqSpec :: IfaceEqSpec, -- Equality constraints + ifConCtxt :: IfaceContext, -- Non-stupid context + ifConArgTys :: [IfaceType], -- Arg types + ifConFields :: [FieldLabel], -- ...ditto... (field labels) + ifConStricts :: [IfaceBang], + -- Empty (meaning all lazy), + -- or 1-1 corresp with arg tys + -- See Note [Bangs on imported data constructors] in MkId + ifConSrcStricts :: [IfaceSrcBang] } -- empty meaning no src stricts + +type IfaceEqSpec = [(IfLclName,IfaceType)] + +-- | This corresponds to an HsImplBang; that is, the final +-- implementation decision about the data constructor arg +data IfaceBang + = IfNoBang | IfStrict | IfUnpack | IfUnpackCo IfaceCoercion + +-- | This corresponds to HsSrcBang +data IfaceSrcBang + = IfSrcBang SrcUnpackedness SrcStrictness + +data IfaceClsInst + = IfaceClsInst { ifInstCls :: IfExtName, -- See comments with + ifInstTys :: [Maybe IfaceTyCon], -- the defn of ClsInst + ifDFun :: IfExtName, -- The dfun + ifOFlag :: OverlapFlag, -- Overlap flag + ifInstOrph :: IsOrphan } -- See Note [Orphans] in InstEnv + -- There's always a separate IfaceDecl for the DFun, which gives + -- its IdInfo with its full type and version number. + -- The instance declarations taken together have a version number, + -- and we don't want that to wobble gratuitously + -- If this instance decl is *used*, we'll record a usage on the dfun; + -- and if the head does not change it won't be used if it wasn't before + +-- The ifFamInstTys field of IfaceFamInst contains a list of the rough +-- match types +data IfaceFamInst + = IfaceFamInst { ifFamInstFam :: IfExtName -- Family name + , ifFamInstTys :: [Maybe IfaceTyCon] -- See above + , ifFamInstAxiom :: IfExtName -- The axiom + , ifFamInstOrph :: IsOrphan -- Just like IfaceClsInst + } + +data IfaceRule + = IfaceRule { + ifRuleName :: RuleName, + ifActivation :: Activation, + ifRuleBndrs :: [IfaceBndr], -- Tyvars and term vars + ifRuleHead :: IfExtName, -- Head of lhs + ifRuleArgs :: [IfaceExpr], -- Args of LHS + ifRuleRhs :: IfaceExpr, + ifRuleAuto :: Bool, + ifRuleOrph :: IsOrphan -- Just like IfaceClsInst + } + +data IfaceAnnotation + = IfaceAnnotation { + ifAnnotatedTarget :: IfaceAnnTarget, + ifAnnotatedValue :: AnnPayload + } + +type IfaceAnnTarget = AnnTarget OccName + +data IfaceCompleteMatch = IfaceCompleteMatch [IfExtName] IfExtName + +instance Outputable IfaceCompleteMatch where + ppr (IfaceCompleteMatch cls ty) = text "COMPLETE" <> colon <+> ppr cls + <+> dcolon <+> ppr ty + + + + +-- Here's a tricky case: +-- * Compile with -O module A, and B which imports A.f +-- * Change function f in A, and recompile without -O +-- * When we read in old A.hi we read in its IdInfo (as a thunk) +-- (In earlier GHCs we used to drop IdInfo immediately on reading, +-- but we do not do that now. Instead it's discarded when the +-- ModIface is read into the various decl pools.) +-- * The version comparison sees that new (=NoInfo) differs from old (=HasInfo *) +-- and so gives a new version. + +data IfaceIdInfo + = NoInfo -- When writing interface file without -O + | HasInfo [IfaceInfoItem] -- Has info, and here it is + +data IfaceInfoItem + = HsArity Arity + | HsStrictness StrictSig + | HsInline InlinePragma + | HsUnfold Bool -- True <=> isStrongLoopBreaker is true + IfaceUnfolding -- See Note [Expose recursive functions] + | HsNoCafRefs + | HsLevity -- Present <=> never levity polymorphic + +-- NB: Specialisations and rules come in separately and are +-- only later attached to the Id. Partial reason: some are orphans. + +data IfaceUnfolding + = IfCoreUnfold Bool IfaceExpr -- True <=> INLINABLE, False <=> regular unfolding + -- Possibly could eliminate the Bool here, the information + -- is also in the InlinePragma. + + | IfCompulsory IfaceExpr -- Only used for default methods, in fact + + | IfInlineRule Arity -- INLINE pragmas + Bool -- OK to inline even if *un*-saturated + Bool -- OK to inline even if context is boring + IfaceExpr + + | IfDFunUnfold [IfaceBndr] [IfaceExpr] + + +-- We only serialise the IdDetails of top-level Ids, and even then +-- we only need a very limited selection. Notably, none of the +-- implicit ones are needed here, because they are not put it +-- interface files + +data IfaceIdDetails + = IfVanillaId + | IfRecSelId (Either IfaceTyCon IfaceDecl) Bool + | IfDFunId + +{- +Note [Versioning of instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See [https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance#instances] + + +************************************************************************ +* * + Functions over declarations +* * +************************************************************************ +-} + +visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl] +visibleIfConDecls IfAbstractTyCon = [] +visibleIfConDecls (IfDataTyCon cs) = cs +visibleIfConDecls (IfNewTyCon c) = [c] + +ifaceDeclImplicitBndrs :: IfaceDecl -> [OccName] +-- *Excludes* the 'main' name, but *includes* the implicitly-bound names +-- Deeply revolting, because it has to predict what gets bound, +-- especially the question of whether there's a wrapper for a datacon +-- See Note [Implicit TyThings] in HscTypes + +-- N.B. the set of names returned here *must* match the set of +-- TyThings returned by HscTypes.implicitTyThings, in the sense that +-- TyThing.getOccName should define a bijection between the two lists. +-- This invariant is used in LoadIface.loadDecl (see note [Tricky iface loop]) +-- The order of the list does not matter. + +ifaceDeclImplicitBndrs (IfaceData {ifName = tc_name, ifCons = cons }) + = case cons of + IfAbstractTyCon -> [] + IfNewTyCon cd -> mkNewTyCoOcc (occName tc_name) : ifaceConDeclImplicitBndrs cd + IfDataTyCon cds -> concatMap ifaceConDeclImplicitBndrs cds + +ifaceDeclImplicitBndrs (IfaceClass { ifBody = IfAbstractClass }) + = [] + +ifaceDeclImplicitBndrs (IfaceClass { ifName = cls_tc_name + , ifBody = IfConcreteClass { + ifClassCtxt = sc_ctxt, + ifSigs = sigs, + ifATs = ats + }}) + = -- (possibly) newtype coercion + co_occs ++ + -- data constructor (DataCon namespace) + -- data worker (Id namespace) + -- no wrapper (class dictionaries never have a wrapper) + [dc_occ, dcww_occ] ++ + -- associated types + [occName (ifName at) | IfaceAT at _ <- ats ] ++ + -- superclass selectors + [mkSuperDictSelOcc n cls_tc_occ | n <- [1..n_ctxt]] ++ + -- operation selectors + [occName op | IfaceClassOp op _ _ <- sigs] + where + cls_tc_occ = occName cls_tc_name + n_ctxt = length sc_ctxt + n_sigs = length sigs + co_occs | is_newtype = [mkNewTyCoOcc cls_tc_occ] + | otherwise = [] + dcww_occ = mkDataConWorkerOcc dc_occ + dc_occ = mkClassDataConOcc cls_tc_occ + is_newtype = n_sigs + n_ctxt == 1 -- Sigh (keep this synced with buildClass) + +ifaceDeclImplicitBndrs _ = [] + +ifaceConDeclImplicitBndrs :: IfaceConDecl -> [OccName] +ifaceConDeclImplicitBndrs (IfCon { + ifConWrapper = has_wrapper, ifConName = con_name }) + = [occName con_name, work_occ] ++ wrap_occs + where + con_occ = occName con_name + work_occ = mkDataConWorkerOcc con_occ -- Id namespace + wrap_occs | has_wrapper = [mkDataConWrapperOcc con_occ] -- Id namespace + | otherwise = [] + +-- ----------------------------------------------------------------------------- +-- The fingerprints of an IfaceDecl + + -- We better give each name bound by the declaration a + -- different fingerprint! So we calculate the fingerprint of + -- each binder by combining the fingerprint of the whole + -- declaration with the name of the binder. (#5614, #7215) +ifaceDeclFingerprints :: Fingerprint -> IfaceDecl -> [(OccName,Fingerprint)] +ifaceDeclFingerprints hash decl + = (getOccName decl, hash) : + [ (occ, computeFingerprint' (hash,occ)) + | occ <- ifaceDeclImplicitBndrs decl ] + where + computeFingerprint' = + unsafeDupablePerformIO + . computeFingerprint (panic "ifaceDeclFingerprints") + +{- +************************************************************************ +* * + Expressions +* * +************************************************************************ +-} + +data IfaceExpr + = IfaceLcl IfLclName + | IfaceExt IfExtName + | IfaceType IfaceType + | IfaceCo IfaceCoercion + | IfaceTuple TupleSort [IfaceExpr] -- Saturated; type arguments omitted + | IfaceLam IfaceLamBndr IfaceExpr + | IfaceApp IfaceExpr IfaceExpr + | IfaceCase IfaceExpr IfLclName [IfaceAlt] + | IfaceECase IfaceExpr IfaceType -- See Note [Empty case alternatives] + | IfaceLet IfaceBinding IfaceExpr + | IfaceCast IfaceExpr IfaceCoercion + | IfaceLit Literal + | IfaceFCall ForeignCall IfaceType + | IfaceTick IfaceTickish IfaceExpr -- from Tick tickish E + +data IfaceTickish + = IfaceHpcTick Module Int -- from HpcTick x + | IfaceSCC CostCentre Bool Bool -- from ProfNote + | IfaceSource RealSrcSpan String -- from SourceNote + -- no breakpoints: we never export these into interface files + +type IfaceAlt = (IfaceConAlt, [IfLclName], IfaceExpr) + -- Note: IfLclName, not IfaceBndr (and same with the case binder) + -- We reconstruct the kind/type of the thing from the context + -- thus saving bulk in interface files + +data IfaceConAlt = IfaceDefault + | IfaceDataAlt IfExtName + | IfaceLitAlt Literal + +data IfaceBinding + = IfaceNonRec IfaceLetBndr IfaceExpr + | IfaceRec [(IfaceLetBndr, IfaceExpr)] + +-- IfaceLetBndr is like IfaceIdBndr, but has IdInfo too +-- It's used for *non-top-level* let/rec binders +-- See Note [IdInfo on nested let-bindings] +data IfaceLetBndr = IfLetBndr IfLclName IfaceType IfaceIdInfo IfaceJoinInfo + +data IfaceJoinInfo = IfaceNotJoinPoint + | IfaceJoinPoint JoinArity + +{- +Note [Empty case alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In IfaceSyn an IfaceCase does not record the types of the alternatives, +unlike CorSyn Case. But we need this type if the alternatives are empty. +Hence IfaceECase. See Note [Empty case alternatives] in CoreSyn. + +Note [Expose recursive functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For supercompilation we want to put *all* unfoldings in the interface +file, even for functions that are recursive (or big). So we need to +know when an unfolding belongs to a loop-breaker so that we can refrain +from inlining it (except during supercompilation). + +Note [IdInfo on nested let-bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Occasionally we want to preserve IdInfo on nested let bindings. The one +that came up was a NOINLINE pragma on a let-binding inside an INLINE +function. The user (Duncan Coutts) really wanted the NOINLINE control +to cross the separate compilation boundary. + +In general we retain all info that is left by CoreTidy.tidyLetBndr, since +that is what is seen by importing module with --make + + +************************************************************************ +* * + Printing IfaceDecl +* * +************************************************************************ +-} + +pprAxBranch :: SDoc -> IfaceAxBranch -> SDoc +-- The TyCon might be local (just an OccName), or this might +-- be a branch for an imported TyCon, so it would be an ExtName +-- So it's easier to take an SDoc here +-- +-- This function is used +-- to print interface files, +-- in debug messages +-- in :info F for GHCi, which goes via toConToIfaceDecl on the family tycon +-- For user error messages we use Coercion.pprCoAxiom and friends +pprAxBranch pp_tc (IfaceAxBranch { ifaxbTyVars = tvs + , ifaxbCoVars = _cvs + , ifaxbLHS = pat_tys + , ifaxbRHS = rhs + , ifaxbIncomps = incomps }) + = WARN( not (null _cvs), pp_tc $$ ppr _cvs ) + hang ppr_binders 2 (hang pp_lhs 2 (equals <+> ppr rhs)) + $+$ + nest 2 maybe_incomps + where + -- See Note [Printing foralls in type family instances] in IfaceType + ppr_binders = pprUserIfaceForAll $ map (mkIfaceForAllTvBndr Specified) tvs + pp_lhs = hang pp_tc 2 (pprParendIfaceAppArgs pat_tys) + maybe_incomps = ppUnless (null incomps) $ parens $ + text "incompatible indices:" <+> ppr incomps + +instance Outputable IfaceAnnotation where + ppr (IfaceAnnotation target value) = ppr target <+> colon <+> ppr value + +instance NamedThing IfaceClassOp where + getName (IfaceClassOp n _ _) = n + +instance HasOccName IfaceClassOp where + occName = getOccName + +instance NamedThing IfaceConDecl where + getName = ifConName + +instance HasOccName IfaceConDecl where + occName = getOccName + +instance NamedThing IfaceDecl where + getName = ifName + +instance HasOccName IfaceDecl where + occName = getOccName + +instance Outputable IfaceDecl where + ppr = pprIfaceDecl showToIface + +{- +Note [Minimal complete definition] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The minimal complete definition should only be included if a complete +class definition is shown. Since the minimal complete definition is +anonymous we can't reuse the same mechanism that is used for the +filtering of method signatures. Instead we just check if anything at all is +filtered and hide it in that case. +-} + +data ShowSub + = ShowSub + { ss_how_much :: ShowHowMuch + , ss_forall :: ShowForAllFlag } + +-- See Note [Printing IfaceDecl binders] +-- The alternative pretty printer referred to in the note. +newtype AltPpr = AltPpr (Maybe (OccName -> SDoc)) + +data ShowHowMuch + = ShowHeader AltPpr -- ^Header information only, not rhs + | ShowSome [OccName] AltPpr + -- ^ Show only some sub-components. Specifically, + -- + -- [@[]@] Print all sub-components. + -- [@(n:ns)@] Print sub-component @n@ with @ShowSub = ns@; + -- elide other sub-components to @...@ + -- May 14: the list is max 1 element long at the moment + | ShowIface + -- ^Everything including GHC-internal information (used in --show-iface) + +{- +Note [Printing IfaceDecl binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The binders in an IfaceDecl are just OccNames, so we don't know what module they +come from. But when we pretty-print a TyThing by converting to an IfaceDecl +(see PprTyThing), the TyThing may come from some other module so we really need +the module qualifier. We solve this by passing in a pretty-printer for the +binders. + +When printing an interface file (--show-iface), we want to print +everything unqualified, so we can just print the OccName directly. +-} + +instance Outputable ShowHowMuch where + ppr (ShowHeader _) = text "ShowHeader" + ppr ShowIface = text "ShowIface" + ppr (ShowSome occs _) = text "ShowSome" <+> ppr occs + +showToHeader :: ShowSub +showToHeader = ShowSub { ss_how_much = ShowHeader $ AltPpr Nothing + , ss_forall = ShowForAllWhen } + +showToIface :: ShowSub +showToIface = ShowSub { ss_how_much = ShowIface + , ss_forall = ShowForAllWhen } + +ppShowIface :: ShowSub -> SDoc -> SDoc +ppShowIface (ShowSub { ss_how_much = ShowIface }) doc = doc +ppShowIface _ _ = Outputable.empty + +-- show if all sub-components or the complete interface is shown +ppShowAllSubs :: ShowSub -> SDoc -> SDoc -- Note [Minimal complete definition] +ppShowAllSubs (ShowSub { ss_how_much = ShowSome [] _ }) doc = doc +ppShowAllSubs (ShowSub { ss_how_much = ShowIface }) doc = doc +ppShowAllSubs _ _ = Outputable.empty + +ppShowRhs :: ShowSub -> SDoc -> SDoc +ppShowRhs (ShowSub { ss_how_much = ShowHeader _ }) _ = Outputable.empty +ppShowRhs _ doc = doc + +showSub :: HasOccName n => ShowSub -> n -> Bool +showSub (ShowSub { ss_how_much = ShowHeader _ }) _ = False +showSub (ShowSub { ss_how_much = ShowSome (n:_) _ }) thing = n == occName thing +showSub (ShowSub { ss_how_much = _ }) _ = True + +ppr_trim :: [Maybe SDoc] -> [SDoc] +-- Collapse a group of Nothings to a single "..." +ppr_trim xs + = snd (foldr go (False, []) xs) + where + go (Just doc) (_, so_far) = (False, doc : so_far) + go Nothing (True, so_far) = (True, so_far) + go Nothing (False, so_far) = (True, text "..." : so_far) + +isIfaceDataInstance :: IfaceTyConParent -> Bool +isIfaceDataInstance IfNoParent = False +isIfaceDataInstance _ = True + +pprClassRoles :: ShowSub -> IfaceTopBndr -> [IfaceTyConBinder] -> [Role] -> SDoc +pprClassRoles ss clas binders roles = + pprRoles (== Nominal) + (pprPrefixIfDeclBndr (ss_how_much ss) (occName clas)) + binders + roles + +pprIfaceDecl :: ShowSub -> IfaceDecl -> SDoc +-- NB: pprIfaceDecl is also used for pretty-printing TyThings in GHCi +-- See Note [Pretty-printing TyThings] in PprTyThing +pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype, + ifCtxt = context, ifResKind = kind, + ifRoles = roles, ifCons = condecls, + ifParent = parent, + ifGadtSyntax = gadt, + ifBinders = binders }) + + | gadt = vcat [ pp_roles + , pp_nd <+> pp_lhs <+> pp_kind <+> pp_where + , nest 2 (vcat pp_cons) + , nest 2 $ ppShowIface ss pp_extra ] + | otherwise = vcat [ pp_roles + , hang (pp_nd <+> pp_lhs) 2 (add_bars pp_cons) + , nest 2 $ ppShowIface ss pp_extra ] + where + is_data_instance = isIfaceDataInstance parent + -- See Note [Printing foralls in type family instances] in IfaceType + pp_data_inst_forall :: SDoc + pp_data_inst_forall = pprUserIfaceForAll forall_bndrs + + forall_bndrs :: [IfaceForAllBndr] + forall_bndrs = [Bndr (binderVar tc_bndr) Specified | tc_bndr <- binders] + + cons = visibleIfConDecls condecls + pp_where = ppWhen (gadt && not (null cons)) $ text "where" + pp_cons = ppr_trim (map show_con cons) :: [SDoc] + pp_kind + | isIfaceLiftedTypeKind kind = empty + | otherwise = dcolon <+> ppr kind + + pp_lhs = case parent of + IfNoParent -> pprIfaceDeclHead context ss tycon binders Nothing + IfDataInstance{} + -> text "instance" <+> pp_data_inst_forall + <+> pprIfaceTyConParent parent + + pp_roles + | is_data_instance = empty + | otherwise = pprRoles (== Representational) + (pprPrefixIfDeclBndr + (ss_how_much ss) + (occName tycon)) + binders roles + -- Don't display roles for data family instances (yet) + -- See discussion on #8672. + + add_bars [] = Outputable.empty + add_bars (c:cs) = sep ((equals <+> c) : map (vbar <+>) cs) + + ok_con dc = showSub ss dc || any (showSub ss . flSelector) (ifConFields dc) + + show_con dc + | ok_con dc = Just $ pprIfaceConDecl ss gadt tycon binders parent dc + | otherwise = Nothing + + pp_nd = case condecls of + IfAbstractTyCon{} -> text "data" + IfDataTyCon{} -> text "data" + IfNewTyCon{} -> text "newtype" + + pp_extra = vcat [pprCType ctype] + +pprIfaceDecl ss (IfaceClass { ifName = clas + , ifRoles = roles + , ifFDs = fds + , ifBinders = binders + , ifBody = IfAbstractClass }) + = vcat [ pprClassRoles ss clas binders roles + , text "class" <+> pprIfaceDeclHead [] ss clas binders Nothing + <+> pprFundeps fds ] + +pprIfaceDecl ss (IfaceClass { ifName = clas + , ifRoles = roles + , ifFDs = fds + , ifBinders = binders + , ifBody = IfConcreteClass { + ifATs = ats, + ifSigs = sigs, + ifClassCtxt = context, + ifMinDef = minDef + }}) + = vcat [ pprClassRoles ss clas binders roles + , text "class" <+> pprIfaceDeclHead context ss clas binders Nothing + <+> pprFundeps fds <+> pp_where + , nest 2 (vcat [ vcat asocs, vcat dsigs + , ppShowAllSubs ss (pprMinDef minDef)])] + where + pp_where = ppShowRhs ss $ ppUnless (null sigs && null ats) (text "where") + + asocs = ppr_trim $ map maybeShowAssoc ats + dsigs = ppr_trim $ map maybeShowSig sigs + + maybeShowAssoc :: IfaceAT -> Maybe SDoc + maybeShowAssoc asc@(IfaceAT d _) + | showSub ss d = Just $ pprIfaceAT ss asc + | otherwise = Nothing + + maybeShowSig :: IfaceClassOp -> Maybe SDoc + maybeShowSig sg + | showSub ss sg = Just $ pprIfaceClassOp ss sg + | otherwise = Nothing + + pprMinDef :: BooleanFormula IfLclName -> SDoc + pprMinDef minDef = ppUnless (isTrue minDef) $ -- hide empty definitions + text "{-# MINIMAL" <+> + pprBooleanFormula + (\_ def -> cparen (isLexSym def) (ppr def)) 0 minDef <+> + text "#-}" + +pprIfaceDecl ss (IfaceSynonym { ifName = tc + , ifBinders = binders + , ifSynRhs = mono_ty + , ifResKind = res_kind}) + = hang (text "type" <+> pprIfaceDeclHead [] ss tc binders Nothing <+> equals) + 2 (sep [ pprIfaceForAll tvs, pprIfaceContextArr theta, ppr tau + , ppUnless (isIfaceLiftedTypeKind res_kind) (dcolon <+> ppr res_kind) ]) + where + (tvs, theta, tau) = splitIfaceSigmaTy mono_ty + +pprIfaceDecl ss (IfaceFamily { ifName = tycon + , ifFamFlav = rhs, ifBinders = binders + , ifResKind = res_kind + , ifResVar = res_var, ifFamInj = inj }) + | IfaceDataFamilyTyCon <- rhs + = text "data family" <+> pprIfaceDeclHead [] ss tycon binders Nothing + + | otherwise + = hang (text "type family" + <+> pprIfaceDeclHead [] ss tycon binders (Just res_kind) + <+> ppShowRhs ss (pp_where rhs)) + 2 (pp_inj res_var inj <+> ppShowRhs ss (pp_rhs rhs)) + $$ + nest 2 (ppShowRhs ss (pp_branches rhs)) + where + pp_where (IfaceClosedSynFamilyTyCon {}) = text "where" + pp_where _ = empty + + pp_inj Nothing _ = empty + pp_inj (Just res) inj + | Injective injectivity <- inj = hsep [ equals, ppr res + , pp_inj_cond res injectivity] + | otherwise = hsep [ equals, ppr res ] + + pp_inj_cond res inj = case filterByList inj binders of + [] -> empty + tvs -> hsep [vbar, ppr res, text "->", interppSP (map ifTyConBinderName tvs)] + + pp_rhs IfaceDataFamilyTyCon + = ppShowIface ss (text "data") + pp_rhs IfaceOpenSynFamilyTyCon + = ppShowIface ss (text "open") + pp_rhs IfaceAbstractClosedSynFamilyTyCon + = ppShowIface ss (text "closed, abstract") + pp_rhs (IfaceClosedSynFamilyTyCon {}) + = empty -- see pp_branches + pp_rhs IfaceBuiltInSynFamTyCon + = ppShowIface ss (text "built-in") + + pp_branches (IfaceClosedSynFamilyTyCon (Just (ax, brs))) + = vcat (map (pprAxBranch + (pprPrefixIfDeclBndr + (ss_how_much ss) + (occName tycon)) + ) brs) + $$ ppShowIface ss (text "axiom" <+> ppr ax) + pp_branches _ = Outputable.empty + +pprIfaceDecl _ (IfacePatSyn { ifName = name, + ifPatUnivBndrs = univ_bndrs, ifPatExBndrs = ex_bndrs, + ifPatProvCtxt = prov_ctxt, ifPatReqCtxt = req_ctxt, + ifPatArgs = arg_tys, + ifPatTy = pat_ty} ) + = sdocWithDynFlags mk_msg + where + mk_msg dflags + = hang (text "pattern" <+> pprPrefixOcc name) + 2 (dcolon <+> sep [univ_msg + , pprIfaceContextArr req_ctxt + , ppWhen insert_empty_ctxt $ parens empty <+> darrow + , ex_msg + , pprIfaceContextArr prov_ctxt + , pprIfaceType $ foldr (IfaceFunTy VisArg) pat_ty arg_tys ]) + where + univ_msg = pprUserIfaceForAll univ_bndrs + ex_msg = pprUserIfaceForAll ex_bndrs + + insert_empty_ctxt = null req_ctxt + && not (null prov_ctxt && isEmpty dflags ex_msg) + +pprIfaceDecl ss (IfaceId { ifName = var, ifType = ty, + ifIdDetails = details, ifIdInfo = info }) + = vcat [ hang (pprPrefixIfDeclBndr (ss_how_much ss) (occName var) <+> dcolon) + 2 (pprIfaceSigmaType (ss_forall ss) ty) + , ppShowIface ss (ppr details) + , ppShowIface ss (ppr info) ] + +pprIfaceDecl _ (IfaceAxiom { ifName = name, ifTyCon = tycon + , ifAxBranches = branches }) + = hang (text "axiom" <+> ppr name <+> dcolon) + 2 (vcat $ map (pprAxBranch (ppr tycon)) branches) + +pprCType :: Maybe CType -> SDoc +pprCType Nothing = Outputable.empty +pprCType (Just cType) = text "C type:" <+> ppr cType + +-- if, for each role, suppress_if role is True, then suppress the role +-- output +pprRoles :: (Role -> Bool) -> SDoc -> [IfaceTyConBinder] + -> [Role] -> SDoc +pprRoles suppress_if tyCon bndrs roles + = sdocWithDynFlags $ \dflags -> + let froles = suppressIfaceInvisibles dflags bndrs roles + in ppUnless (all suppress_if froles || null froles) $ + text "type role" <+> tyCon <+> hsep (map ppr froles) + +pprInfixIfDeclBndr :: ShowHowMuch -> OccName -> SDoc +pprInfixIfDeclBndr (ShowSome _ (AltPpr (Just ppr_bndr))) name + = pprInfixVar (isSymOcc name) (ppr_bndr name) +pprInfixIfDeclBndr _ name + = pprInfixVar (isSymOcc name) (ppr name) + +pprPrefixIfDeclBndr :: ShowHowMuch -> OccName -> SDoc +pprPrefixIfDeclBndr (ShowHeader (AltPpr (Just ppr_bndr))) name + = parenSymOcc name (ppr_bndr name) +pprPrefixIfDeclBndr (ShowSome _ (AltPpr (Just ppr_bndr))) name + = parenSymOcc name (ppr_bndr name) +pprPrefixIfDeclBndr _ name + = parenSymOcc name (ppr name) + +instance Outputable IfaceClassOp where + ppr = pprIfaceClassOp showToIface + +pprIfaceClassOp :: ShowSub -> IfaceClassOp -> SDoc +pprIfaceClassOp ss (IfaceClassOp n ty dm) + = pp_sig n ty $$ generic_dm + where + generic_dm | Just (GenericDM dm_ty) <- dm + = text "default" <+> pp_sig n dm_ty + | otherwise + = empty + pp_sig n ty + = pprPrefixIfDeclBndr (ss_how_much ss) (occName n) + <+> dcolon + <+> pprIfaceSigmaType ShowForAllWhen ty + +instance Outputable IfaceAT where + ppr = pprIfaceAT showToIface + +pprIfaceAT :: ShowSub -> IfaceAT -> SDoc +pprIfaceAT ss (IfaceAT d mb_def) + = vcat [ pprIfaceDecl ss d + , case mb_def of + Nothing -> Outputable.empty + Just rhs -> nest 2 $ + text "Default:" <+> ppr rhs ] + +instance Outputable IfaceTyConParent where + ppr p = pprIfaceTyConParent p + +pprIfaceTyConParent :: IfaceTyConParent -> SDoc +pprIfaceTyConParent IfNoParent + = Outputable.empty +pprIfaceTyConParent (IfDataInstance _ tc tys) + = pprIfaceTypeApp topPrec tc tys + +pprIfaceDeclHead :: IfaceContext -> ShowSub -> Name + -> [IfaceTyConBinder] -- of the tycon, for invisible-suppression + -> Maybe IfaceKind + -> SDoc +pprIfaceDeclHead context ss tc_occ bndrs m_res_kind + = sdocWithDynFlags $ \ dflags -> + sep [ pprIfaceContextArr context + , pprPrefixIfDeclBndr (ss_how_much ss) (occName tc_occ) + <+> pprIfaceTyConBinders (suppressIfaceInvisibles dflags bndrs bndrs) + , maybe empty (\res_kind -> dcolon <+> pprIfaceType res_kind) m_res_kind ] + +pprIfaceConDecl :: ShowSub -> Bool + -> IfaceTopBndr + -> [IfaceTyConBinder] + -> IfaceTyConParent + -> IfaceConDecl -> SDoc +pprIfaceConDecl ss gadt_style tycon tc_binders parent + (IfCon { ifConName = name, ifConInfix = is_infix, + ifConUserTvBinders = user_tvbs, + ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys, + ifConStricts = stricts, ifConFields = fields }) + | gadt_style = pp_prefix_con <+> dcolon <+> ppr_gadt_ty + | otherwise = ppr_ex_quant pp_h98_con + where + pp_h98_con + | not (null fields) = pp_prefix_con <+> pp_field_args + | is_infix + , [ty1, ty2] <- pp_args + = sep [ ty1 + , pprInfixIfDeclBndr how_much (occName name) + , ty2] + | otherwise = pp_prefix_con <+> sep pp_args + + how_much = ss_how_much ss + tys_w_strs :: [(IfaceBang, IfaceType)] + tys_w_strs = zip stricts arg_tys + pp_prefix_con = pprPrefixIfDeclBndr how_much (occName name) + + -- If we're pretty-printing a H98-style declaration with existential + -- quantification, then user_tvbs will always consist of the universal + -- tyvar binders followed by the existential tyvar binders. So to recover + -- the visibilities of the existential tyvar binders, we can simply drop + -- the universal tyvar binders from user_tvbs. + ex_tvbs = dropList tc_binders user_tvbs + ppr_ex_quant = pprIfaceForAllPartMust ex_tvbs ctxt + pp_gadt_res_ty = mk_user_con_res_ty eq_spec + ppr_gadt_ty = pprIfaceForAllPart user_tvbs ctxt pp_tau + + -- A bit gruesome this, but we can't form the full con_tau, and ppr it, + -- because we don't have a Name for the tycon, only an OccName + pp_tau | null fields + = case pp_args ++ [pp_gadt_res_ty] of + (t:ts) -> fsep (t : map (arrow <+>) ts) + [] -> panic "pp_con_taus" + | otherwise + = sep [pp_field_args, arrow <+> pp_gadt_res_ty] + + ppr_bang IfNoBang = whenPprDebug $ char '_' + ppr_bang IfStrict = char '!' + ppr_bang IfUnpack = text "{-# UNPACK #-}" + ppr_bang (IfUnpackCo co) = text "! {-# UNPACK #-}" <> + pprParendIfaceCoercion co + + pprFieldArgTy, pprArgTy :: (IfaceBang, IfaceType) -> SDoc + -- If using record syntax, the only reason one would need to parenthesize + -- a compound field type is if it's preceded by a bang pattern. + pprFieldArgTy (bang, ty) = ppr_arg_ty (bang_prec bang) bang ty + -- If not using record syntax, a compound field type might need to be + -- parenthesize if one of the following holds: + -- + -- 1. We're using Haskell98 syntax. + -- 2. The field type is preceded with a bang pattern. + pprArgTy (bang, ty) = ppr_arg_ty (max gadt_prec (bang_prec bang)) bang ty + + ppr_arg_ty :: PprPrec -> IfaceBang -> IfaceType -> SDoc + ppr_arg_ty prec bang ty = ppr_bang bang <> pprPrecIfaceType prec ty + + -- If we're displaying the fields GADT-style, e.g., + -- + -- data Foo a where + -- MkFoo :: Maybe a -> Foo + -- + -- Then there is no inherent need to parenthesize compound fields like + -- `Maybe a` (bang patterns notwithstanding). If we're displaying the + -- fields Haskell98-style, e.g., + -- + -- data Foo a = MkFoo (Maybe a) + -- + -- Then we *must* parenthesize compound fields like (Maybe a). + gadt_prec :: PprPrec + gadt_prec + | gadt_style = topPrec + | otherwise = appPrec + + -- The presence of bang patterns or UNPACK annotations requires + -- surrounding the type with parentheses, if needed (#13699) + bang_prec :: IfaceBang -> PprPrec + bang_prec IfNoBang = topPrec + bang_prec IfStrict = appPrec + bang_prec IfUnpack = appPrec + bang_prec IfUnpackCo{} = appPrec + + pp_args :: [SDoc] -- No records, e.g., ` Maybe a -> Int -> ...` or + -- `!(Maybe a) -> !Int -> ...` + pp_args = map pprArgTy tys_w_strs + + pp_field_args :: SDoc -- Records, e.g., { x :: Maybe a, y :: Int } or + -- { x :: !(Maybe a), y :: !Int } + pp_field_args = braces $ sep $ punctuate comma $ ppr_trim $ + zipWith maybe_show_label fields tys_w_strs + + maybe_show_label :: FieldLabel -> (IfaceBang, IfaceType) -> Maybe SDoc + maybe_show_label lbl bty + | showSub ss sel = Just (pprPrefixIfDeclBndr how_much occ + <+> dcolon <+> pprFieldArgTy bty) + | otherwise = Nothing + where + sel = flSelector lbl + occ = mkVarOccFS (flLabel lbl) + + mk_user_con_res_ty :: IfaceEqSpec -> SDoc + -- See Note [Result type of a data family GADT] + mk_user_con_res_ty eq_spec + | IfDataInstance _ tc tys <- parent + = pprIfaceType (IfaceTyConApp tc (substIfaceAppArgs gadt_subst tys)) + | otherwise + = ppr_tc_app gadt_subst + where + gadt_subst = mkIfaceTySubst eq_spec + + -- When pretty-printing a GADT return type, we: + -- + -- 1. Take the data tycon binders, extract their variable names and + -- visibilities, and construct suitable arguments from them. (This is + -- the role of mk_tc_app_args.) + -- 2. Apply the GADT substitution constructed from the eq_spec. + -- (See Note [Result type of a data family GADT].) + -- 3. Pretty-print the data type constructor applied to its arguments. + -- This process will omit any invisible arguments, such as coercion + -- variables, if necessary. (See Note + -- [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep.) + ppr_tc_app gadt_subst = + pprPrefixIfDeclBndr how_much (occName tycon) + <+> pprIfaceAppArgs + (substIfaceAppArgs gadt_subst (mk_tc_app_args tc_binders)) + + mk_tc_app_args :: [IfaceTyConBinder] -> IfaceAppArgs + mk_tc_app_args [] = IA_Nil + mk_tc_app_args (Bndr bndr vis:tc_bndrs) = + IA_Arg (IfaceTyVar (ifaceBndrName bndr)) (tyConBndrVisArgFlag vis) + (mk_tc_app_args tc_bndrs) + +instance Outputable IfaceRule where + ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs, + ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs, + ifRuleOrph = orph }) + = sep [ hsep [ pprRuleName name + , if isOrphan orph then text "[orphan]" else Outputable.empty + , ppr act + , pp_foralls ] + , nest 2 (sep [ppr fn <+> sep (map pprParendIfaceExpr args), + text "=" <+> ppr rhs]) ] + where + pp_foralls = ppUnless (null bndrs) $ forAllLit <+> pprIfaceBndrs bndrs <> dot + +instance Outputable IfaceClsInst where + ppr (IfaceClsInst { ifDFun = dfun_id, ifOFlag = flag + , ifInstCls = cls, ifInstTys = mb_tcs + , ifInstOrph = orph }) + = hang (text "instance" <+> ppr flag + <+> (if isOrphan orph then text "[orphan]" else Outputable.empty) + <+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs)) + 2 (equals <+> ppr dfun_id) + +instance Outputable IfaceFamInst where + ppr (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs + , ifFamInstAxiom = tycon_ax, ifFamInstOrph = orph }) + = hang (text "family instance" + <+> (if isOrphan orph then text "[orphan]" else Outputable.empty) + <+> ppr fam <+> pprWithCommas (brackets . ppr_rough) mb_tcs) + 2 (equals <+> ppr tycon_ax) + +ppr_rough :: Maybe IfaceTyCon -> SDoc +ppr_rough Nothing = dot +ppr_rough (Just tc) = ppr tc + +{- +Note [Result type of a data family GADT] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data family T a + data instance T (p,q) where + T1 :: T (Int, Maybe c) + T2 :: T (Bool, q) + +The IfaceDecl actually looks like + + data TPr p q where + T1 :: forall p q. forall c. (p~Int,q~Maybe c) => TPr p q + T2 :: forall p q. (p~Bool) => TPr p q + +To reconstruct the result types for T1 and T2 that we +want to pretty print, we substitute the eq-spec +[p->Int, q->Maybe c] in the arg pattern (p,q) to give + T (Int, Maybe c) +Remember that in IfaceSyn, the TyCon and DataCon share the same +universal type variables. + +----------------------------- Printing IfaceExpr ------------------------------------ +-} + +instance Outputable IfaceExpr where + ppr e = pprIfaceExpr noParens e + +noParens :: SDoc -> SDoc +noParens pp = pp + +pprParendIfaceExpr :: IfaceExpr -> SDoc +pprParendIfaceExpr = pprIfaceExpr parens + +-- | Pretty Print an IfaceExpre +-- +-- The first argument should be a function that adds parens in context that need +-- an atomic value (e.g. function args) +pprIfaceExpr :: (SDoc -> SDoc) -> IfaceExpr -> SDoc + +pprIfaceExpr _ (IfaceLcl v) = ppr v +pprIfaceExpr _ (IfaceExt v) = ppr v +pprIfaceExpr _ (IfaceLit l) = ppr l +pprIfaceExpr _ (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty) +pprIfaceExpr _ (IfaceType ty) = char '@' <+> pprParendIfaceType ty +pprIfaceExpr _ (IfaceCo co) = text "@~" <+> pprParendIfaceCoercion co + +pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app []) +pprIfaceExpr _ (IfaceTuple c as) = tupleParens c (pprWithCommas ppr as) + +pprIfaceExpr add_par i@(IfaceLam _ _) + = add_par (sep [char '\\' <+> sep (map pprIfaceLamBndr bndrs) <+> arrow, + pprIfaceExpr noParens body]) + where + (bndrs,body) = collect [] i + collect bs (IfaceLam b e) = collect (b:bs) e + collect bs e = (reverse bs, e) + +pprIfaceExpr add_par (IfaceECase scrut ty) + = add_par (sep [ text "case" <+> pprIfaceExpr noParens scrut + , text "ret_ty" <+> pprParendIfaceType ty + , text "of {}" ]) + +pprIfaceExpr add_par (IfaceCase scrut bndr [(con, bs, rhs)]) + = add_par (sep [text "case" + <+> pprIfaceExpr noParens scrut <+> text "of" + <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow, + pprIfaceExpr noParens rhs <+> char '}']) + +pprIfaceExpr add_par (IfaceCase scrut bndr alts) + = add_par (sep [text "case" + <+> pprIfaceExpr noParens scrut <+> text "of" + <+> ppr bndr <+> char '{', + nest 2 (sep (map ppr_alt alts)) <+> char '}']) + +pprIfaceExpr _ (IfaceCast expr co) + = sep [pprParendIfaceExpr expr, + nest 2 (text "`cast`"), + pprParendIfaceCoercion co] + +pprIfaceExpr add_par (IfaceLet (IfaceNonRec b rhs) body) + = add_par (sep [text "let {", + nest 2 (ppr_bind (b, rhs)), + text "} in", + pprIfaceExpr noParens body]) + +pprIfaceExpr add_par (IfaceLet (IfaceRec pairs) body) + = add_par (sep [text "letrec {", + nest 2 (sep (map ppr_bind pairs)), + text "} in", + pprIfaceExpr noParens body]) + +pprIfaceExpr add_par (IfaceTick tickish e) + = add_par (pprIfaceTickish tickish <+> pprIfaceExpr noParens e) + +ppr_alt :: (IfaceConAlt, [IfLclName], IfaceExpr) -> SDoc +ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs, + arrow <+> pprIfaceExpr noParens rhs] + +ppr_con_bs :: IfaceConAlt -> [IfLclName] -> SDoc +ppr_con_bs con bs = ppr con <+> hsep (map ppr bs) + +ppr_bind :: (IfaceLetBndr, IfaceExpr) -> SDoc +ppr_bind (IfLetBndr b ty info ji, rhs) + = sep [hang (ppr b <+> dcolon <+> ppr ty) 2 (ppr ji <+> ppr info), + equals <+> pprIfaceExpr noParens rhs] + +------------------ +pprIfaceTickish :: IfaceTickish -> SDoc +pprIfaceTickish (IfaceHpcTick m ix) + = braces (text "tick" <+> ppr m <+> ppr ix) +pprIfaceTickish (IfaceSCC cc tick scope) + = braces (pprCostCentreCore cc <+> ppr tick <+> ppr scope) +pprIfaceTickish (IfaceSource src _names) + = braces (pprUserRealSpan True src) + +------------------ +pprIfaceApp :: IfaceExpr -> [SDoc] -> SDoc +pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun $ + nest 2 (pprParendIfaceExpr arg) : args +pprIfaceApp fun args = sep (pprParendIfaceExpr fun : args) + +------------------ +instance Outputable IfaceConAlt where + ppr IfaceDefault = text "DEFAULT" + ppr (IfaceLitAlt l) = ppr l + ppr (IfaceDataAlt d) = ppr d + +------------------ +instance Outputable IfaceIdDetails where + ppr IfVanillaId = Outputable.empty + ppr (IfRecSelId tc b) = text "RecSel" <+> ppr tc + <+> if b + then text "" + else Outputable.empty + ppr IfDFunId = text "DFunId" + +instance Outputable IfaceIdInfo where + ppr NoInfo = Outputable.empty + ppr (HasInfo is) = text "{-" <+> pprWithCommas ppr is + <+> text "-}" + +instance Outputable IfaceInfoItem where + ppr (HsUnfold lb unf) = text "Unfolding" + <> ppWhen lb (text "(loop-breaker)") + <> colon <+> ppr unf + ppr (HsInline prag) = text "Inline:" <+> ppr prag + ppr (HsArity arity) = text "Arity:" <+> int arity + ppr (HsStrictness str) = text "Strictness:" <+> pprIfaceStrictSig str + ppr HsNoCafRefs = text "HasNoCafRefs" + ppr HsLevity = text "Never levity-polymorphic" + +instance Outputable IfaceJoinInfo where + ppr IfaceNotJoinPoint = empty + ppr (IfaceJoinPoint ar) = angleBrackets (text "join" <+> ppr ar) + +instance Outputable IfaceUnfolding where + ppr (IfCompulsory e) = text "" <+> parens (ppr e) + ppr (IfCoreUnfold s e) = (if s + then text "" + else Outputable.empty) + <+> parens (ppr e) + ppr (IfInlineRule a uok bok e) = sep [text "InlineRule" + <+> ppr (a,uok,bok), + pprParendIfaceExpr e] + ppr (IfDFunUnfold bs es) = hang (text "DFun:" <+> sep (map ppr bs) <> dot) + 2 (sep (map pprParendIfaceExpr es)) + +{- +************************************************************************ +* * + Finding the Names in IfaceSyn +* * +************************************************************************ + +This is used for dependency analysis in MkIface, so that we +fingerprint a declaration before the things that depend on it. It +is specific to interface-file fingerprinting in the sense that we +don't collect *all* Names: for example, the DFun of an instance is +recorded textually rather than by its fingerprint when +fingerprinting the instance, so DFuns are not dependencies. +-} + +freeNamesIfDecl :: IfaceDecl -> NameSet +freeNamesIfDecl (IfaceId { ifType = t, ifIdDetails = d, ifIdInfo = i}) + = freeNamesIfType t &&& + freeNamesIfIdInfo i &&& + freeNamesIfIdDetails d + +freeNamesIfDecl (IfaceData { ifBinders = bndrs, ifResKind = res_k + , ifParent = p, ifCtxt = ctxt, ifCons = cons }) + = freeNamesIfVarBndrs bndrs &&& + freeNamesIfType res_k &&& + freeNamesIfaceTyConParent p &&& + freeNamesIfContext ctxt &&& + freeNamesIfConDecls cons + +freeNamesIfDecl (IfaceSynonym { ifBinders = bndrs, ifResKind = res_k + , ifSynRhs = rhs }) + = freeNamesIfVarBndrs bndrs &&& + freeNamesIfKind res_k &&& + freeNamesIfType rhs + +freeNamesIfDecl (IfaceFamily { ifBinders = bndrs, ifResKind = res_k + , ifFamFlav = flav }) + = freeNamesIfVarBndrs bndrs &&& + freeNamesIfKind res_k &&& + freeNamesIfFamFlav flav + +freeNamesIfDecl (IfaceClass{ ifBinders = bndrs, ifBody = cls_body }) + = freeNamesIfVarBndrs bndrs &&& + freeNamesIfClassBody cls_body + +freeNamesIfDecl (IfaceAxiom { ifTyCon = tc, ifAxBranches = branches }) + = freeNamesIfTc tc &&& + fnList freeNamesIfAxBranch branches + +freeNamesIfDecl (IfacePatSyn { ifPatMatcher = (matcher, _) + , ifPatBuilder = mb_builder + , ifPatUnivBndrs = univ_bndrs + , ifPatExBndrs = ex_bndrs + , ifPatProvCtxt = prov_ctxt + , ifPatReqCtxt = req_ctxt + , ifPatArgs = args + , ifPatTy = pat_ty + , ifFieldLabels = lbls }) + = unitNameSet matcher &&& + maybe emptyNameSet (unitNameSet . fst) mb_builder &&& + freeNamesIfVarBndrs univ_bndrs &&& + freeNamesIfVarBndrs ex_bndrs &&& + freeNamesIfContext prov_ctxt &&& + freeNamesIfContext req_ctxt &&& + fnList freeNamesIfType args &&& + freeNamesIfType pat_ty &&& + mkNameSet (map flSelector lbls) + +freeNamesIfClassBody :: IfaceClassBody -> NameSet +freeNamesIfClassBody IfAbstractClass + = emptyNameSet +freeNamesIfClassBody (IfConcreteClass{ ifClassCtxt = ctxt, ifATs = ats, ifSigs = sigs }) + = freeNamesIfContext ctxt &&& + fnList freeNamesIfAT ats &&& + fnList freeNamesIfClsSig sigs + +freeNamesIfAxBranch :: IfaceAxBranch -> NameSet +freeNamesIfAxBranch (IfaceAxBranch { ifaxbTyVars = tyvars + , ifaxbCoVars = covars + , ifaxbLHS = lhs + , ifaxbRHS = rhs }) + = fnList freeNamesIfTvBndr tyvars &&& + fnList freeNamesIfIdBndr covars &&& + freeNamesIfAppArgs lhs &&& + freeNamesIfType rhs + +freeNamesIfIdDetails :: IfaceIdDetails -> NameSet +freeNamesIfIdDetails (IfRecSelId tc _) = + either freeNamesIfTc freeNamesIfDecl tc +freeNamesIfIdDetails _ = emptyNameSet + +-- All other changes are handled via the version info on the tycon +freeNamesIfFamFlav :: IfaceFamTyConFlav -> NameSet +freeNamesIfFamFlav IfaceOpenSynFamilyTyCon = emptyNameSet +freeNamesIfFamFlav IfaceDataFamilyTyCon = emptyNameSet +freeNamesIfFamFlav (IfaceClosedSynFamilyTyCon (Just (ax, br))) + = unitNameSet ax &&& fnList freeNamesIfAxBranch br +freeNamesIfFamFlav (IfaceClosedSynFamilyTyCon Nothing) = emptyNameSet +freeNamesIfFamFlav IfaceAbstractClosedSynFamilyTyCon = emptyNameSet +freeNamesIfFamFlav IfaceBuiltInSynFamTyCon = emptyNameSet + +freeNamesIfContext :: IfaceContext -> NameSet +freeNamesIfContext = fnList freeNamesIfType + +freeNamesIfAT :: IfaceAT -> NameSet +freeNamesIfAT (IfaceAT decl mb_def) + = freeNamesIfDecl decl &&& + case mb_def of + Nothing -> emptyNameSet + Just rhs -> freeNamesIfType rhs + +freeNamesIfClsSig :: IfaceClassOp -> NameSet +freeNamesIfClsSig (IfaceClassOp _n ty dm) = freeNamesIfType ty &&& freeNamesDM dm + +freeNamesDM :: Maybe (DefMethSpec IfaceType) -> NameSet +freeNamesDM (Just (GenericDM ty)) = freeNamesIfType ty +freeNamesDM _ = emptyNameSet + +freeNamesIfConDecls :: IfaceConDecls -> NameSet +freeNamesIfConDecls (IfDataTyCon c) = fnList freeNamesIfConDecl c +freeNamesIfConDecls (IfNewTyCon c) = freeNamesIfConDecl c +freeNamesIfConDecls _ = emptyNameSet + +freeNamesIfConDecl :: IfaceConDecl -> NameSet +freeNamesIfConDecl (IfCon { ifConExTCvs = ex_tvs, ifConCtxt = ctxt + , ifConArgTys = arg_tys + , ifConFields = flds + , ifConEqSpec = eq_spec + , ifConStricts = bangs }) + = fnList freeNamesIfBndr ex_tvs &&& + freeNamesIfContext ctxt &&& + fnList freeNamesIfType arg_tys &&& + mkNameSet (map flSelector flds) &&& + fnList freeNamesIfType (map snd eq_spec) &&& -- equality constraints + fnList freeNamesIfBang bangs + +freeNamesIfBang :: IfaceBang -> NameSet +freeNamesIfBang (IfUnpackCo co) = freeNamesIfCoercion co +freeNamesIfBang _ = emptyNameSet + +freeNamesIfKind :: IfaceType -> NameSet +freeNamesIfKind = freeNamesIfType + +freeNamesIfAppArgs :: IfaceAppArgs -> NameSet +freeNamesIfAppArgs (IA_Arg t _ ts) = freeNamesIfType t &&& freeNamesIfAppArgs ts +freeNamesIfAppArgs IA_Nil = emptyNameSet + +freeNamesIfType :: IfaceType -> NameSet +freeNamesIfType (IfaceFreeTyVar _) = emptyNameSet +freeNamesIfType (IfaceTyVar _) = emptyNameSet +freeNamesIfType (IfaceAppTy s t) = freeNamesIfType s &&& freeNamesIfAppArgs t +freeNamesIfType (IfaceTyConApp tc ts) = freeNamesIfTc tc &&& freeNamesIfAppArgs ts +freeNamesIfType (IfaceTupleTy _ _ ts) = freeNamesIfAppArgs ts +freeNamesIfType (IfaceLitTy _) = emptyNameSet +freeNamesIfType (IfaceForAllTy tv t) = freeNamesIfVarBndr tv &&& freeNamesIfType t +freeNamesIfType (IfaceFunTy _ s t) = freeNamesIfType s &&& freeNamesIfType t +freeNamesIfType (IfaceCastTy t c) = freeNamesIfType t &&& freeNamesIfCoercion c +freeNamesIfType (IfaceCoercionTy c) = freeNamesIfCoercion c + +freeNamesIfMCoercion :: IfaceMCoercion -> NameSet +freeNamesIfMCoercion IfaceMRefl = emptyNameSet +freeNamesIfMCoercion (IfaceMCo co) = freeNamesIfCoercion co + +freeNamesIfCoercion :: IfaceCoercion -> NameSet +freeNamesIfCoercion (IfaceReflCo t) = freeNamesIfType t +freeNamesIfCoercion (IfaceGReflCo _ t mco) + = freeNamesIfType t &&& freeNamesIfMCoercion mco +freeNamesIfCoercion (IfaceFunCo _ c1 c2) + = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2 +freeNamesIfCoercion (IfaceTyConAppCo _ tc cos) + = freeNamesIfTc tc &&& fnList freeNamesIfCoercion cos +freeNamesIfCoercion (IfaceAppCo c1 c2) + = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2 +freeNamesIfCoercion (IfaceForAllCo _ kind_co co) + = freeNamesIfCoercion kind_co &&& freeNamesIfCoercion co +freeNamesIfCoercion (IfaceFreeCoVar _) = emptyNameSet +freeNamesIfCoercion (IfaceCoVarCo _) = emptyNameSet +freeNamesIfCoercion (IfaceHoleCo _) = emptyNameSet +freeNamesIfCoercion (IfaceAxiomInstCo ax _ cos) + = unitNameSet ax &&& fnList freeNamesIfCoercion cos +freeNamesIfCoercion (IfaceUnivCo p _ t1 t2) + = freeNamesIfProv p &&& freeNamesIfType t1 &&& freeNamesIfType t2 +freeNamesIfCoercion (IfaceSymCo c) + = freeNamesIfCoercion c +freeNamesIfCoercion (IfaceTransCo c1 c2) + = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2 +freeNamesIfCoercion (IfaceNthCo _ co) + = freeNamesIfCoercion co +freeNamesIfCoercion (IfaceLRCo _ co) + = freeNamesIfCoercion co +freeNamesIfCoercion (IfaceInstCo co co2) + = freeNamesIfCoercion co &&& freeNamesIfCoercion co2 +freeNamesIfCoercion (IfaceKindCo c) + = freeNamesIfCoercion c +freeNamesIfCoercion (IfaceSubCo co) + = freeNamesIfCoercion co +freeNamesIfCoercion (IfaceAxiomRuleCo _ax cos) + -- the axiom is just a string, so we don't count it as a name. + = fnList freeNamesIfCoercion cos + +freeNamesIfProv :: IfaceUnivCoProv -> NameSet +freeNamesIfProv IfaceUnsafeCoerceProv = emptyNameSet +freeNamesIfProv (IfacePhantomProv co) = freeNamesIfCoercion co +freeNamesIfProv (IfaceProofIrrelProv co) = freeNamesIfCoercion co +freeNamesIfProv (IfacePluginProv _) = emptyNameSet + +freeNamesIfVarBndr :: VarBndr IfaceBndr vis -> NameSet +freeNamesIfVarBndr (Bndr bndr _) = freeNamesIfBndr bndr + +freeNamesIfVarBndrs :: [VarBndr IfaceBndr vis] -> NameSet +freeNamesIfVarBndrs = fnList freeNamesIfVarBndr + +freeNamesIfBndr :: IfaceBndr -> NameSet +freeNamesIfBndr (IfaceIdBndr b) = freeNamesIfIdBndr b +freeNamesIfBndr (IfaceTvBndr b) = freeNamesIfTvBndr b + +freeNamesIfBndrs :: [IfaceBndr] -> NameSet +freeNamesIfBndrs = fnList freeNamesIfBndr + +freeNamesIfLetBndr :: IfaceLetBndr -> NameSet +-- Remember IfaceLetBndr is used only for *nested* bindings +-- The IdInfo can contain an unfolding (in the case of +-- local INLINE pragmas), so look there too +freeNamesIfLetBndr (IfLetBndr _name ty info _ji) = freeNamesIfType ty + &&& freeNamesIfIdInfo info + +freeNamesIfTvBndr :: IfaceTvBndr -> NameSet +freeNamesIfTvBndr (_fs,k) = freeNamesIfKind k + -- kinds can have Names inside, because of promotion + +freeNamesIfIdBndr :: IfaceIdBndr -> NameSet +freeNamesIfIdBndr (_fs,k) = freeNamesIfKind k + +freeNamesIfIdInfo :: IfaceIdInfo -> NameSet +freeNamesIfIdInfo NoInfo = emptyNameSet +freeNamesIfIdInfo (HasInfo i) = fnList freeNamesItem i + +freeNamesItem :: IfaceInfoItem -> NameSet +freeNamesItem (HsUnfold _ u) = freeNamesIfUnfold u +freeNamesItem _ = emptyNameSet + +freeNamesIfUnfold :: IfaceUnfolding -> NameSet +freeNamesIfUnfold (IfCoreUnfold _ e) = freeNamesIfExpr e +freeNamesIfUnfold (IfCompulsory e) = freeNamesIfExpr e +freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e +freeNamesIfUnfold (IfDFunUnfold bs es) = freeNamesIfBndrs bs &&& fnList freeNamesIfExpr es + +freeNamesIfExpr :: IfaceExpr -> NameSet +freeNamesIfExpr (IfaceExt v) = unitNameSet v +freeNamesIfExpr (IfaceFCall _ ty) = freeNamesIfType ty +freeNamesIfExpr (IfaceType ty) = freeNamesIfType ty +freeNamesIfExpr (IfaceCo co) = freeNamesIfCoercion co +freeNamesIfExpr (IfaceTuple _ as) = fnList freeNamesIfExpr as +freeNamesIfExpr (IfaceLam (b,_) body) = freeNamesIfBndr b &&& freeNamesIfExpr body +freeNamesIfExpr (IfaceApp f a) = freeNamesIfExpr f &&& freeNamesIfExpr a +freeNamesIfExpr (IfaceCast e co) = freeNamesIfExpr e &&& freeNamesIfCoercion co +freeNamesIfExpr (IfaceTick _ e) = freeNamesIfExpr e +freeNamesIfExpr (IfaceECase e ty) = freeNamesIfExpr e &&& freeNamesIfType ty +freeNamesIfExpr (IfaceCase s _ alts) + = freeNamesIfExpr s &&& fnList fn_alt alts &&& fn_cons alts + where + fn_alt (_con,_bs,r) = freeNamesIfExpr r + + -- Depend on the data constructors. Just one will do! + -- Note [Tracking data constructors] + fn_cons [] = emptyNameSet + fn_cons ((IfaceDefault ,_,_) : xs) = fn_cons xs + fn_cons ((IfaceDataAlt con,_,_) : _ ) = unitNameSet con + fn_cons (_ : _ ) = emptyNameSet + +freeNamesIfExpr (IfaceLet (IfaceNonRec bndr rhs) body) + = freeNamesIfLetBndr bndr &&& freeNamesIfExpr rhs &&& freeNamesIfExpr body + +freeNamesIfExpr (IfaceLet (IfaceRec as) x) + = fnList fn_pair as &&& freeNamesIfExpr x + where + fn_pair (bndr, rhs) = freeNamesIfLetBndr bndr &&& freeNamesIfExpr rhs + +freeNamesIfExpr _ = emptyNameSet + +freeNamesIfTc :: IfaceTyCon -> NameSet +freeNamesIfTc tc = unitNameSet (ifaceTyConName tc) +-- ToDo: shouldn't we include IfaceIntTc & co.? + +freeNamesIfRule :: IfaceRule -> NameSet +freeNamesIfRule (IfaceRule { ifRuleBndrs = bs, ifRuleHead = f + , ifRuleArgs = es, ifRuleRhs = rhs }) + = unitNameSet f &&& + fnList freeNamesIfBndr bs &&& + fnList freeNamesIfExpr es &&& + freeNamesIfExpr rhs + +freeNamesIfFamInst :: IfaceFamInst -> NameSet +freeNamesIfFamInst (IfaceFamInst { ifFamInstFam = famName + , ifFamInstAxiom = axName }) + = unitNameSet famName &&& + unitNameSet axName + +freeNamesIfaceTyConParent :: IfaceTyConParent -> NameSet +freeNamesIfaceTyConParent IfNoParent = emptyNameSet +freeNamesIfaceTyConParent (IfDataInstance ax tc tys) + = unitNameSet ax &&& freeNamesIfTc tc &&& freeNamesIfAppArgs tys + +-- helpers +(&&&) :: NameSet -> NameSet -> NameSet +(&&&) = unionNameSet + +fnList :: (a -> NameSet) -> [a] -> NameSet +fnList f = foldr (&&&) emptyNameSet . map f + +{- +Note [Tracking data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a case expression + case e of { C a -> ...; ... } +You might think that we don't need to include the datacon C +in the free names, because its type will probably show up in +the free names of 'e'. But in rare circumstances this may +not happen. Here's the one that bit me: + + module DynFlags where + import {-# SOURCE #-} Packages( PackageState ) + data DynFlags = DF ... PackageState ... + + module Packages where + import DynFlags + data PackageState = PS ... + lookupModule (df :: DynFlags) + = case df of + DF ...p... -> case p of + PS ... -> ... + +Now, lookupModule depends on DynFlags, but the transitive dependency +on the *locally-defined* type PackageState is not visible. We need +to take account of the use of the data constructor PS in the pattern match. + + +************************************************************************ +* * + Binary instances +* * +************************************************************************ + +Note that there is a bit of subtlety here when we encode names. While +IfaceTopBndrs is really just a synonym for Name, we need to take care to +encode them with {get,put}IfaceTopBndr. The difference becomes important when +we go to fingerprint an IfaceDecl. See Note [Fingerprinting IfaceDecls] for +details. + +-} + +instance Binary IfaceDecl where + put_ bh (IfaceId name ty details idinfo) = do + putByte bh 0 + putIfaceTopBndr bh name + lazyPut bh (ty, details, idinfo) + -- See Note [Lazy deserialization of IfaceId] + + put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8 a9) = do + putByte bh 2 + putIfaceTopBndr bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + put_ bh a8 + put_ bh a9 + + put_ bh (IfaceSynonym a1 a2 a3 a4 a5) = do + putByte bh 3 + putIfaceTopBndr bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + + put_ bh (IfaceFamily a1 a2 a3 a4 a5 a6) = do + putByte bh 4 + putIfaceTopBndr bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + + -- NB: Written in a funny way to avoid an interface change + put_ bh (IfaceClass { + ifName = a2, + ifRoles = a3, + ifBinders = a4, + ifFDs = a5, + ifBody = IfConcreteClass { + ifClassCtxt = a1, + ifATs = a6, + ifSigs = a7, + ifMinDef = a8 + }}) = do + putByte bh 5 + put_ bh a1 + putIfaceTopBndr bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + put_ bh a8 + + put_ bh (IfaceAxiom a1 a2 a3 a4) = do + putByte bh 6 + putIfaceTopBndr bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + + put_ bh (IfacePatSyn a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) = do + putByte bh 7 + putIfaceTopBndr bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + put_ bh a8 + put_ bh a9 + put_ bh a10 + put_ bh a11 + + put_ bh (IfaceClass { + ifName = a1, + ifRoles = a2, + ifBinders = a3, + ifFDs = a4, + ifBody = IfAbstractClass }) = do + putByte bh 8 + putIfaceTopBndr bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + + get bh = do + h <- getByte bh + case h of + 0 -> do name <- get bh + ~(ty, details, idinfo) <- lazyGet bh + -- See Note [Lazy deserialization of IfaceId] + return (IfaceId name ty details idinfo) + 1 -> error "Binary.get(TyClDecl): ForeignType" + 2 -> do a1 <- getIfaceTopBndr bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + a7 <- get bh + a8 <- get bh + a9 <- get bh + return (IfaceData a1 a2 a3 a4 a5 a6 a7 a8 a9) + 3 -> do a1 <- getIfaceTopBndr bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + return (IfaceSynonym a1 a2 a3 a4 a5) + 4 -> do a1 <- getIfaceTopBndr bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + return (IfaceFamily a1 a2 a3 a4 a5 a6) + 5 -> do a1 <- get bh + a2 <- getIfaceTopBndr bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + a7 <- get bh + a8 <- get bh + return (IfaceClass { + ifName = a2, + ifRoles = a3, + ifBinders = a4, + ifFDs = a5, + ifBody = IfConcreteClass { + ifClassCtxt = a1, + ifATs = a6, + ifSigs = a7, + ifMinDef = a8 + }}) + 6 -> do a1 <- getIfaceTopBndr bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + return (IfaceAxiom a1 a2 a3 a4) + 7 -> do a1 <- getIfaceTopBndr bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + a7 <- get bh + a8 <- get bh + a9 <- get bh + a10 <- get bh + a11 <- get bh + return (IfacePatSyn a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) + 8 -> do a1 <- getIfaceTopBndr bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + return (IfaceClass { + ifName = a1, + ifRoles = a2, + ifBinders = a3, + ifFDs = a4, + ifBody = IfAbstractClass }) + _ -> panic (unwords ["Unknown IfaceDecl tag:", show h]) + +{- Note [Lazy deserialization of IfaceId] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The use of lazyPut and lazyGet in the IfaceId Binary instance is +purely for performance reasons, to avoid deserializing details about +identifiers that will never be used. It's not involved in tying the +knot in the type checker. It saved ~1% of the total build time of GHC. + +When we read an interface file, we extend the PTE, a mapping of Names +to TyThings, with the declarations we have read. The extension of the +PTE is strict in the Names, but not in the TyThings themselves. +LoadIface.loadDecl calculates the list of (Name, TyThing) bindings to +add to the PTE. For an IfaceId, there's just one binding to add; and +the ty, details, and idinfo fields of an IfaceId are used only in the +TyThing. So by reading those fields lazily we may be able to save the +work of ever having to deserialize them (into IfaceType, etc.). + +For IfaceData and IfaceClass, loadDecl creates extra implicit bindings +(the constructors and field selectors of the data declaration, or the +methods of the class), whose Names depend on more than just the Name +of the type constructor or class itself. So deserializing them lazily +would be more involved. Similar comments apply to the other +constructors of IfaceDecl with the additional point that they probably +represent a small proportion of all declarations. +-} + +instance Binary IfaceFamTyConFlav where + put_ bh IfaceDataFamilyTyCon = putByte bh 0 + put_ bh IfaceOpenSynFamilyTyCon = putByte bh 1 + put_ bh (IfaceClosedSynFamilyTyCon mb) = putByte bh 2 >> put_ bh mb + put_ bh IfaceAbstractClosedSynFamilyTyCon = putByte bh 3 + put_ _ IfaceBuiltInSynFamTyCon + = pprPanic "Cannot serialize IfaceBuiltInSynFamTyCon, used for pretty-printing only" Outputable.empty + + get bh = do { h <- getByte bh + ; case h of + 0 -> return IfaceDataFamilyTyCon + 1 -> return IfaceOpenSynFamilyTyCon + 2 -> do { mb <- get bh + ; return (IfaceClosedSynFamilyTyCon mb) } + 3 -> return IfaceAbstractClosedSynFamilyTyCon + _ -> pprPanic "Binary.get(IfaceFamTyConFlav): Invalid tag" + (ppr (fromIntegral h :: Int)) } + +instance Binary IfaceClassOp where + put_ bh (IfaceClassOp n ty def) = do + putIfaceTopBndr bh n + put_ bh ty + put_ bh def + get bh = do + n <- getIfaceTopBndr bh + ty <- get bh + def <- get bh + return (IfaceClassOp n ty def) + +instance Binary IfaceAT where + put_ bh (IfaceAT dec defs) = do + put_ bh dec + put_ bh defs + get bh = do + dec <- get bh + defs <- get bh + return (IfaceAT dec defs) + +instance Binary IfaceAxBranch where + put_ bh (IfaceAxBranch a1 a2 a3 a4 a5 a6 a7) = do + put_ bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + get bh = do + a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + a7 <- get bh + return (IfaceAxBranch a1 a2 a3 a4 a5 a6 a7) + +instance Binary IfaceConDecls where + put_ bh IfAbstractTyCon = putByte bh 0 + put_ bh (IfDataTyCon cs) = putByte bh 1 >> put_ bh cs + put_ bh (IfNewTyCon c) = putByte bh 2 >> put_ bh c + get bh = do + h <- getByte bh + case h of + 0 -> return IfAbstractTyCon + 1 -> liftM IfDataTyCon (get bh) + 2 -> liftM IfNewTyCon (get bh) + _ -> error "Binary(IfaceConDecls).get: Invalid IfaceConDecls" + +instance Binary IfaceConDecl where + put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) = do + putIfaceTopBndr bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + put_ bh a8 + put_ bh (length a9) + mapM_ (put_ bh) a9 + put_ bh a10 + put_ bh a11 + get bh = do + a1 <- getIfaceTopBndr bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + a7 <- get bh + a8 <- get bh + n_fields <- get bh + a9 <- replicateM n_fields (get bh) + a10 <- get bh + a11 <- get bh + return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) + +instance Binary IfaceBang where + put_ bh IfNoBang = putByte bh 0 + put_ bh IfStrict = putByte bh 1 + put_ bh IfUnpack = putByte bh 2 + put_ bh (IfUnpackCo co) = putByte bh 3 >> put_ bh co + + get bh = do + h <- getByte bh + case h of + 0 -> do return IfNoBang + 1 -> do return IfStrict + 2 -> do return IfUnpack + _ -> do { a <- get bh; return (IfUnpackCo a) } + +instance Binary IfaceSrcBang where + put_ bh (IfSrcBang a1 a2) = + do put_ bh a1 + put_ bh a2 + + get bh = + do a1 <- get bh + a2 <- get bh + return (IfSrcBang a1 a2) + +instance Binary IfaceClsInst where + put_ bh (IfaceClsInst cls tys dfun flag orph) = do + put_ bh cls + put_ bh tys + put_ bh dfun + put_ bh flag + put_ bh orph + get bh = do + cls <- get bh + tys <- get bh + dfun <- get bh + flag <- get bh + orph <- get bh + return (IfaceClsInst cls tys dfun flag orph) + +instance Binary IfaceFamInst where + put_ bh (IfaceFamInst fam tys name orph) = do + put_ bh fam + put_ bh tys + put_ bh name + put_ bh orph + get bh = do + fam <- get bh + tys <- get bh + name <- get bh + orph <- get bh + return (IfaceFamInst fam tys name orph) + +instance Binary IfaceRule where + put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) = do + put_ bh a1 + put_ bh a2 + put_ bh a3 + put_ bh a4 + put_ bh a5 + put_ bh a6 + put_ bh a7 + put_ bh a8 + get bh = do + a1 <- get bh + a2 <- get bh + a3 <- get bh + a4 <- get bh + a5 <- get bh + a6 <- get bh + a7 <- get bh + a8 <- get bh + return (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) + +instance Binary IfaceAnnotation where + put_ bh (IfaceAnnotation a1 a2) = do + put_ bh a1 + put_ bh a2 + get bh = do + a1 <- get bh + a2 <- get bh + return (IfaceAnnotation a1 a2) + +instance Binary IfaceIdDetails where + put_ bh IfVanillaId = putByte bh 0 + put_ bh (IfRecSelId a b) = putByte bh 1 >> put_ bh a >> put_ bh b + put_ bh IfDFunId = putByte bh 2 + get bh = do + h <- getByte bh + case h of + 0 -> return IfVanillaId + 1 -> do { a <- get bh; b <- get bh; return (IfRecSelId a b) } + _ -> return IfDFunId + +instance Binary IfaceIdInfo where + put_ bh NoInfo = putByte bh 0 + put_ bh (HasInfo i) = putByte bh 1 >> lazyPut bh i -- NB lazyPut + + get bh = do + h <- getByte bh + case h of + 0 -> return NoInfo + _ -> liftM HasInfo $ lazyGet bh -- NB lazyGet + +instance Binary IfaceInfoItem where + put_ bh (HsArity aa) = putByte bh 0 >> put_ bh aa + put_ bh (HsStrictness ab) = putByte bh 1 >> put_ bh ab + put_ bh (HsUnfold lb ad) = putByte bh 2 >> put_ bh lb >> put_ bh ad + put_ bh (HsInline ad) = putByte bh 3 >> put_ bh ad + put_ bh HsNoCafRefs = putByte bh 4 + put_ bh HsLevity = putByte bh 5 + get bh = do + h <- getByte bh + case h of + 0 -> liftM HsArity $ get bh + 1 -> liftM HsStrictness $ get bh + 2 -> do lb <- get bh + ad <- get bh + return (HsUnfold lb ad) + 3 -> liftM HsInline $ get bh + 4 -> return HsNoCafRefs + _ -> return HsLevity + +instance Binary IfaceUnfolding where + put_ bh (IfCoreUnfold s e) = do + putByte bh 0 + put_ bh s + put_ bh e + put_ bh (IfInlineRule a b c d) = do + putByte bh 1 + put_ bh a + put_ bh b + put_ bh c + put_ bh d + put_ bh (IfDFunUnfold as bs) = do + putByte bh 2 + put_ bh as + put_ bh bs + put_ bh (IfCompulsory e) = do + putByte bh 3 + put_ bh e + get bh = do + h <- getByte bh + case h of + 0 -> do s <- get bh + e <- get bh + return (IfCoreUnfold s e) + 1 -> do a <- get bh + b <- get bh + c <- get bh + d <- get bh + return (IfInlineRule a b c d) + 2 -> do as <- get bh + bs <- get bh + return (IfDFunUnfold as bs) + _ -> do e <- get bh + return (IfCompulsory e) + + +instance Binary IfaceExpr where + put_ bh (IfaceLcl aa) = do + putByte bh 0 + put_ bh aa + put_ bh (IfaceType ab) = do + putByte bh 1 + put_ bh ab + put_ bh (IfaceCo ab) = do + putByte bh 2 + put_ bh ab + put_ bh (IfaceTuple ac ad) = do + putByte bh 3 + put_ bh ac + put_ bh ad + put_ bh (IfaceLam (ae, os) af) = do + putByte bh 4 + put_ bh ae + put_ bh os + put_ bh af + put_ bh (IfaceApp ag ah) = do + putByte bh 5 + put_ bh ag + put_ bh ah + put_ bh (IfaceCase ai aj ak) = do + putByte bh 6 + put_ bh ai + put_ bh aj + put_ bh ak + put_ bh (IfaceLet al am) = do + putByte bh 7 + put_ bh al + put_ bh am + put_ bh (IfaceTick an ao) = do + putByte bh 8 + put_ bh an + put_ bh ao + put_ bh (IfaceLit ap) = do + putByte bh 9 + put_ bh ap + put_ bh (IfaceFCall as at) = do + putByte bh 10 + put_ bh as + put_ bh at + put_ bh (IfaceExt aa) = do + putByte bh 11 + put_ bh aa + put_ bh (IfaceCast ie ico) = do + putByte bh 12 + put_ bh ie + put_ bh ico + put_ bh (IfaceECase a b) = do + putByte bh 13 + put_ bh a + put_ bh b + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + return (IfaceLcl aa) + 1 -> do ab <- get bh + return (IfaceType ab) + 2 -> do ab <- get bh + return (IfaceCo ab) + 3 -> do ac <- get bh + ad <- get bh + return (IfaceTuple ac ad) + 4 -> do ae <- get bh + os <- get bh + af <- get bh + return (IfaceLam (ae, os) af) + 5 -> do ag <- get bh + ah <- get bh + return (IfaceApp ag ah) + 6 -> do ai <- get bh + aj <- get bh + ak <- get bh + return (IfaceCase ai aj ak) + 7 -> do al <- get bh + am <- get bh + return (IfaceLet al am) + 8 -> do an <- get bh + ao <- get bh + return (IfaceTick an ao) + 9 -> do ap <- get bh + return (IfaceLit ap) + 10 -> do as <- get bh + at <- get bh + return (IfaceFCall as at) + 11 -> do aa <- get bh + return (IfaceExt aa) + 12 -> do ie <- get bh + ico <- get bh + return (IfaceCast ie ico) + 13 -> do a <- get bh + b <- get bh + return (IfaceECase a b) + _ -> panic ("get IfaceExpr " ++ show h) + +instance Binary IfaceTickish where + put_ bh (IfaceHpcTick m ix) = do + putByte bh 0 + put_ bh m + put_ bh ix + put_ bh (IfaceSCC cc tick push) = do + putByte bh 1 + put_ bh cc + put_ bh tick + put_ bh push + put_ bh (IfaceSource src name) = do + putByte bh 2 + put_ bh (srcSpanFile src) + put_ bh (srcSpanStartLine src) + put_ bh (srcSpanStartCol src) + put_ bh (srcSpanEndLine src) + put_ bh (srcSpanEndCol src) + put_ bh name + + get bh = do + h <- getByte bh + case h of + 0 -> do m <- get bh + ix <- get bh + return (IfaceHpcTick m ix) + 1 -> do cc <- get bh + tick <- get bh + push <- get bh + return (IfaceSCC cc tick push) + 2 -> do file <- get bh + sl <- get bh + sc <- get bh + el <- get bh + ec <- get bh + let start = mkRealSrcLoc file sl sc + end = mkRealSrcLoc file el ec + name <- get bh + return (IfaceSource (mkRealSrcSpan start end) name) + _ -> panic ("get IfaceTickish " ++ show h) + +instance Binary IfaceConAlt where + put_ bh IfaceDefault = putByte bh 0 + put_ bh (IfaceDataAlt aa) = putByte bh 1 >> put_ bh aa + put_ bh (IfaceLitAlt ac) = putByte bh 2 >> put_ bh ac + get bh = do + h <- getByte bh + case h of + 0 -> return IfaceDefault + 1 -> liftM IfaceDataAlt $ get bh + _ -> liftM IfaceLitAlt $ get bh + +instance Binary IfaceBinding where + put_ bh (IfaceNonRec aa ab) = putByte bh 0 >> put_ bh aa >> put_ bh ab + put_ bh (IfaceRec ac) = putByte bh 1 >> put_ bh ac + get bh = do + h <- getByte bh + case h of + 0 -> do { aa <- get bh; ab <- get bh; return (IfaceNonRec aa ab) } + _ -> do { ac <- get bh; return (IfaceRec ac) } + +instance Binary IfaceLetBndr where + put_ bh (IfLetBndr a b c d) = do + put_ bh a + put_ bh b + put_ bh c + put_ bh d + get bh = do a <- get bh + b <- get bh + c <- get bh + d <- get bh + return (IfLetBndr a b c d) + +instance Binary IfaceJoinInfo where + put_ bh IfaceNotJoinPoint = putByte bh 0 + put_ bh (IfaceJoinPoint ar) = do + putByte bh 1 + put_ bh ar + get bh = do + h <- getByte bh + case h of + 0 -> return IfaceNotJoinPoint + _ -> liftM IfaceJoinPoint $ get bh + +instance Binary IfaceTyConParent where + put_ bh IfNoParent = putByte bh 0 + put_ bh (IfDataInstance ax pr ty) = do + putByte bh 1 + put_ bh ax + put_ bh pr + put_ bh ty + get bh = do + h <- getByte bh + case h of + 0 -> return IfNoParent + _ -> do + ax <- get bh + pr <- get bh + ty <- get bh + return $ IfDataInstance ax pr ty + +instance Binary IfaceCompleteMatch where + put_ bh (IfaceCompleteMatch cs ts) = put_ bh cs >> put_ bh ts + get bh = IfaceCompleteMatch <$> get bh <*> get bh diff --git a/compiler/iface/IfaceType.hs b/compiler/iface/IfaceType.hs new file mode 100644 --- /dev/null +++ b/compiler/iface/IfaceType.hs @@ -0,0 +1,1902 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1993-1998 + + +This module defines interface types and binders +-} + +{-# LANGUAGE CPP, FlexibleInstances, BangPatterns #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TupleSections #-} + -- FlexibleInstances for Binary (DefMethSpec IfaceType) + +module IfaceType ( + IfExtName, IfLclName, + + IfaceType(..), IfacePredType, IfaceKind, IfaceCoercion(..), + IfaceMCoercion(..), + IfaceUnivCoProv(..), + IfaceTyCon(..), IfaceTyConInfo(..), IfaceTyConSort(..), + IfaceTyLit(..), IfaceAppArgs(..), + IfaceContext, IfaceBndr(..), IfaceOneShot(..), IfaceLamBndr, + IfaceTvBndr, IfaceIdBndr, IfaceTyConBinder, + IfaceForAllBndr, ArgFlag(..), AnonArgFlag(..), + ForallVisFlag(..), ShowForAllFlag(..), + mkIfaceForAllTvBndr, + + ifForAllBndrVar, ifForAllBndrName, ifaceBndrName, + ifTyConBinderVar, ifTyConBinderName, + + -- Equality testing + isIfaceLiftedTypeKind, + + -- Conversion from IfaceAppArgs to IfaceTypes/ArgFlags + appArgsIfaceTypes, appArgsIfaceTypesArgFlags, + + -- Printing + pprIfaceType, pprParendIfaceType, pprPrecIfaceType, + pprIfaceContext, pprIfaceContextArr, + pprIfaceIdBndr, pprIfaceLamBndr, pprIfaceTvBndr, pprIfaceTyConBinders, + pprIfaceBndrs, pprIfaceAppArgs, pprParendIfaceAppArgs, + pprIfaceForAllPart, pprIfaceForAllPartMust, pprIfaceForAll, + pprIfaceSigmaType, pprIfaceTyLit, + pprIfaceCoercion, pprParendIfaceCoercion, + splitIfaceSigmaTy, pprIfaceTypeApp, pprUserIfaceForAll, + pprIfaceCoTcApp, pprTyTcApp, pprIfacePrefixApp, + + suppressIfaceInvisibles, + stripIfaceInvisVars, + stripInvisArgs, + + mkIfaceTySubst, substIfaceTyVar, substIfaceAppArgs, inDomIfaceTySubst + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import {-# SOURCE #-} TysWiredIn ( coercibleTyCon, heqTyCon + , liftedRepDataConTyCon ) +import {-# SOURCE #-} TyCoRep ( isRuntimeRepTy ) + +import DynFlags +import TyCon hiding ( pprPromotionQuote ) +import CoAxiom +import Var +import PrelNames +import Name +import BasicTypes +import Binary +import Outputable +import FastString +import FastStringEnv +import Util + +import Data.Maybe( isJust ) +import qualified Data.Semigroup as Semi + +{- +************************************************************************ +* * + Local (nested) binders +* * +************************************************************************ +-} + +type IfLclName = FastString -- A local name in iface syntax + +type IfExtName = Name -- An External or WiredIn Name can appear in IfaceSyn + -- (However Internal or System Names never should) + +data IfaceBndr -- Local (non-top-level) binders + = IfaceIdBndr {-# UNPACK #-} !IfaceIdBndr + | IfaceTvBndr {-# UNPACK #-} !IfaceTvBndr + +type IfaceIdBndr = (IfLclName, IfaceType) +type IfaceTvBndr = (IfLclName, IfaceKind) + +ifaceTvBndrName :: IfaceTvBndr -> IfLclName +ifaceTvBndrName (n,_) = n + +ifaceIdBndrName :: IfaceIdBndr -> IfLclName +ifaceIdBndrName (n,_) = n + +ifaceBndrName :: IfaceBndr -> IfLclName +ifaceBndrName (IfaceTvBndr bndr) = ifaceTvBndrName bndr +ifaceBndrName (IfaceIdBndr bndr) = ifaceIdBndrName bndr + +type IfaceLamBndr = (IfaceBndr, IfaceOneShot) + +data IfaceOneShot -- See Note [Preserve OneShotInfo] in CoreTicy + = IfaceNoOneShot -- and Note [The oneShot function] in MkId + | IfaceOneShot + + +{- +%************************************************************************ +%* * + IfaceType +%* * +%************************************************************************ +-} + +------------------------------- +type IfaceKind = IfaceType + +-- | A kind of universal type, used for types and kinds. +-- +-- Any time a 'Type' is pretty-printed, it is first converted to an 'IfaceType' +-- before being printed. See Note [Pretty printing via IfaceSyn] in PprTyThing +data IfaceType + = IfaceFreeTyVar TyVar -- See Note [Free tyvars in IfaceType] + | IfaceTyVar IfLclName -- Type/coercion variable only, not tycon + | IfaceLitTy IfaceTyLit + | IfaceAppTy IfaceType IfaceAppArgs + -- See Note [Suppressing invisible arguments] for + -- an explanation of why the second field isn't + -- IfaceType, analogous to AppTy. + | IfaceFunTy AnonArgFlag IfaceType IfaceType + | IfaceForAllTy IfaceForAllBndr IfaceType + | IfaceTyConApp IfaceTyCon IfaceAppArgs -- Not necessarily saturated + -- Includes newtypes, synonyms, tuples + | IfaceCastTy IfaceType IfaceCoercion + | IfaceCoercionTy IfaceCoercion + + | IfaceTupleTy -- Saturated tuples (unsaturated ones use IfaceTyConApp) + TupleSort -- What sort of tuple? + PromotionFlag -- A bit like IfaceTyCon + IfaceAppArgs -- arity = length args + -- For promoted data cons, the kind args are omitted + +type IfacePredType = IfaceType +type IfaceContext = [IfacePredType] + +data IfaceTyLit + = IfaceNumTyLit Integer + | IfaceStrTyLit FastString + deriving (Eq) + +type IfaceTyConBinder = VarBndr IfaceBndr TyConBndrVis +type IfaceForAllBndr = VarBndr IfaceBndr ArgFlag + +-- | Make an 'IfaceForAllBndr' from an 'IfaceTvBndr'. +mkIfaceForAllTvBndr :: ArgFlag -> IfaceTvBndr -> IfaceForAllBndr +mkIfaceForAllTvBndr vis var = Bndr (IfaceTvBndr var) vis + +-- | Stores the arguments in a type application as a list. +-- See @Note [Suppressing invisible arguments]@. +data IfaceAppArgs + = IA_Nil + | IA_Arg IfaceType -- The type argument + + ArgFlag -- The argument's visibility. We store this here so + -- that we can: + -- + -- 1. Avoid pretty-printing invisible (i.e., specified + -- or inferred) arguments when + -- -fprint-explicit-kinds isn't enabled, or + -- 2. When -fprint-explicit-kinds *is*, enabled, print + -- specified arguments in @(...) and inferred + -- arguments in @{...}. + + IfaceAppArgs -- The rest of the arguments + +instance Semi.Semigroup IfaceAppArgs where + IA_Nil <> xs = xs + IA_Arg ty argf rest <> xs = IA_Arg ty argf (rest Semi.<> xs) + +instance Monoid IfaceAppArgs where + mempty = IA_Nil + mappend = (Semi.<>) + +-- Encodes type constructors, kind constructors, +-- coercion constructors, the lot. +-- We have to tag them in order to pretty print them +-- properly. +data IfaceTyCon = IfaceTyCon { ifaceTyConName :: IfExtName + , ifaceTyConInfo :: IfaceTyConInfo } + deriving (Eq) + +-- | The various types of TyCons which have special, built-in syntax. +data IfaceTyConSort = IfaceNormalTyCon -- ^ a regular tycon + + | IfaceTupleTyCon !Arity !TupleSort + -- ^ e.g. @(a, b, c)@ or @(#a, b, c#)@. + -- The arity is the tuple width, not the tycon arity + -- (which is twice the width in the case of unboxed + -- tuples). + + | IfaceSumTyCon !Arity + -- ^ e.g. @(a | b | c)@ + + | IfaceEqualityTyCon + -- ^ A heterogeneous equality TyCon + -- (i.e. eqPrimTyCon, eqReprPrimTyCon, heqTyCon) + -- that is actually being applied to two types + -- of the same kind. This affects pretty-printing + -- only: see Note [Equality predicates in IfaceType] + deriving (Eq) + +{- Note [Free tyvars in IfaceType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Nowadays (since Nov 16, 2016) we pretty-print a Type by converting to +an IfaceType and pretty printing that. This eliminates a lot of +pretty-print duplication, and it matches what we do with pretty- +printing TyThings. See Note [Pretty printing via IfaceSyn] in PprTyThing. + +It works fine for closed types, but when printing debug traces (e.g. +when using -ddump-tc-trace) we print a lot of /open/ types. These +types are full of TcTyVars, and it's absolutely crucial to print them +in their full glory, with their unique, TcTyVarDetails etc. + +So we simply embed a TyVar in IfaceType with the IfaceFreeTyVar constructor. +Note that: + +* We never expect to serialise an IfaceFreeTyVar into an interface file, nor + to deserialise one. IfaceFreeTyVar is used only in the "convert to IfaceType + and then pretty-print" pipeline. + +We do the same for covars, naturally. + +Note [Equality predicates in IfaceType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC has several varieties of type equality (see Note [The equality types story] +in TysPrim for details). In an effort to avoid confusing users, we suppress +the differences during pretty printing unless certain flags are enabled. +Here is how each equality predicate* is printed in homogeneous and +heterogeneous contexts, depending on which combination of the +-fprint-explicit-kinds and -fprint-equality-relations flags is used: + +-------------------------------------------------------------------------------------------- +| Predicate | Neither flag | -fprint-explicit-kinds | +|-------------------------------|----------------------------|-----------------------------| +| a ~ b (homogeneous) | a ~ b | (a :: Type) ~ (b :: Type) | +| a ~~ b, homogeneously | a ~ b | (a :: Type) ~ (b :: Type) | +| a ~~ b, heterogeneously | a ~~ c | (a :: Type) ~~ (c :: k) | +| a ~# b, homogeneously | a ~ b | (a :: Type) ~ (b :: Type) | +| a ~# b, heterogeneously | a ~~ c | (a :: Type) ~~ (c :: k) | +| Coercible a b (homogeneous) | Coercible a b | Coercible @Type a b | +| a ~R# b, homogeneously | Coercible a b | Coercible @Type a b | +| a ~R# b, heterogeneously | a ~R# b | (a :: Type) ~R# (c :: k) | +|-------------------------------|----------------------------|-----------------------------| +| Predicate | -fprint-equality-relations | Both flags | +|-------------------------------|----------------------------|-----------------------------| +| a ~ b (homogeneous) | a ~ b | (a :: Type) ~ (b :: Type) | +| a ~~ b, homogeneously | a ~~ b | (a :: Type) ~~ (b :: Type) | +| a ~~ b, heterogeneously | a ~~ c | (a :: Type) ~~ (c :: k) | +| a ~# b, homogeneously | a ~# b | (a :: Type) ~# (b :: Type) | +| a ~# b, heterogeneously | a ~# c | (a :: Type) ~# (c :: k) | +| Coercible a b (homogeneous) | Coercible a b | Coercible @Type a b | +| a ~R# b, homogeneously | a ~R# b | (a :: Type) ~R# (b :: Type) | +| a ~R# b, heterogeneously | a ~R# b | (a :: Type) ~R# (c :: k) | +-------------------------------------------------------------------------------------------- + +(* There is no heterogeneous, representational, lifted equality counterpart +to (~~). There could be, but there seems to be no use for it.) + +This table adheres to the following rules: + +A. With -fprint-equality-relations, print the true equality relation. +B. Without -fprint-equality-relations: + i. If the equality is representational and homogeneous, use Coercible. + ii. Otherwise, if the equality is representational, use ~R#. + iii. If the equality is nominal and homogeneous, use ~. + iv. Otherwise, if the equality is nominal, use ~~. +C. With -fprint-explicit-kinds, print kinds on both sides of an infix operator, + as above; or print the kind with Coercible. +D. Without -fprint-explicit-kinds, don't print kinds. + +A hetero-kinded equality is used homogeneously when it is applied to two +identical kinds. Unfortunately, determining this from an IfaceType isn't +possible since we can't see through type synonyms. Consequently, we need to +record whether this particular application is homogeneous in IfaceTyConSort +for the purposes of pretty-printing. + +See Note [The equality types story] in TysPrim. +-} + +data IfaceTyConInfo -- Used to guide pretty-printing + -- and to disambiguate D from 'D (they share a name) + = IfaceTyConInfo { ifaceTyConIsPromoted :: PromotionFlag + , ifaceTyConSort :: IfaceTyConSort } + deriving (Eq) + +data IfaceMCoercion + = IfaceMRefl + | IfaceMCo IfaceCoercion + +data IfaceCoercion + = IfaceReflCo IfaceType + | IfaceGReflCo Role IfaceType (IfaceMCoercion) + | IfaceFunCo Role IfaceCoercion IfaceCoercion + | IfaceTyConAppCo Role IfaceTyCon [IfaceCoercion] + | IfaceAppCo IfaceCoercion IfaceCoercion + | IfaceForAllCo IfaceBndr IfaceCoercion IfaceCoercion + | IfaceCoVarCo IfLclName + | IfaceAxiomInstCo IfExtName BranchIndex [IfaceCoercion] + | IfaceAxiomRuleCo IfLclName [IfaceCoercion] + -- There are only a fixed number of CoAxiomRules, so it suffices + -- to use an IfaceLclName to distinguish them. + -- See Note [Adding built-in type families] in TcTypeNats + | IfaceUnivCo IfaceUnivCoProv Role IfaceType IfaceType + | IfaceSymCo IfaceCoercion + | IfaceTransCo IfaceCoercion IfaceCoercion + | IfaceNthCo Int IfaceCoercion + | IfaceLRCo LeftOrRight IfaceCoercion + | IfaceInstCo IfaceCoercion IfaceCoercion + | IfaceKindCo IfaceCoercion + | IfaceSubCo IfaceCoercion + | IfaceFreeCoVar CoVar -- See Note [Free tyvars in IfaceType] + | IfaceHoleCo CoVar -- ^ See Note [Holes in IfaceCoercion] + +data IfaceUnivCoProv + = IfaceUnsafeCoerceProv + | IfacePhantomProv IfaceCoercion + | IfaceProofIrrelProv IfaceCoercion + | IfacePluginProv String + +{- Note [Holes in IfaceCoercion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When typechecking fails the typechecker will produce a HoleCo to stand +in place of the unproven assertion. While we generally don't want to +let these unproven assertions leak into interface files, we still need +to be able to pretty-print them as we use IfaceType's pretty-printer +to render Types. For this reason IfaceCoercion has a IfaceHoleCo +constructor; however, we fails when asked to serialize to a +IfaceHoleCo to ensure that they don't end up in an interface file. + + +%************************************************************************ +%* * + Functions over IFaceTypes +* * +************************************************************************ +-} + +ifaceTyConHasKey :: IfaceTyCon -> Unique -> Bool +ifaceTyConHasKey tc key = ifaceTyConName tc `hasKey` key + +isIfaceLiftedTypeKind :: IfaceKind -> Bool +isIfaceLiftedTypeKind (IfaceTyConApp tc IA_Nil) + = isLiftedTypeKindTyConName (ifaceTyConName tc) +isIfaceLiftedTypeKind (IfaceTyConApp tc + (IA_Arg (IfaceTyConApp ptr_rep_lifted IA_Nil) + Required IA_Nil)) + = tc `ifaceTyConHasKey` tYPETyConKey + && ptr_rep_lifted `ifaceTyConHasKey` liftedRepDataConKey +isIfaceLiftedTypeKind _ = False + +splitIfaceSigmaTy :: IfaceType -> ([IfaceForAllBndr], [IfacePredType], IfaceType) +-- Mainly for printing purposes +-- +-- Here we split nested IfaceSigmaTy properly. +-- +-- @ +-- forall t. T t => forall m a b. M m => (a -> m b) -> t a -> m (t b) +-- @ +-- +-- If you called @splitIfaceSigmaTy@ on this type: +-- +-- @ +-- ([t, m, a, b], [T t, M m], (a -> m b) -> t a -> m (t b)) +-- @ +splitIfaceSigmaTy ty + = case (bndrs, theta) of + ([], []) -> (bndrs, theta, tau) + _ -> let (bndrs', theta', tau') = splitIfaceSigmaTy tau + in (bndrs ++ bndrs', theta ++ theta', tau') + where + (bndrs, rho) = split_foralls ty + (theta, tau) = split_rho rho + + split_foralls (IfaceForAllTy bndr ty) + = case split_foralls ty of { (bndrs, rho) -> (bndr:bndrs, rho) } + split_foralls rho = ([], rho) + + split_rho (IfaceFunTy InvisArg ty1 ty2) + = case split_rho ty2 of { (ps, tau) -> (ty1:ps, tau) } + split_rho tau = ([], tau) + +suppressIfaceInvisibles :: DynFlags -> [IfaceTyConBinder] -> [a] -> [a] +suppressIfaceInvisibles dflags tys xs + | gopt Opt_PrintExplicitKinds dflags = xs + | otherwise = suppress tys xs + where + suppress _ [] = [] + suppress [] a = a + suppress (k:ks) (x:xs) + | isInvisibleTyConBinder k = suppress ks xs + | otherwise = x : suppress ks xs + +stripIfaceInvisVars :: DynFlags -> [IfaceTyConBinder] -> [IfaceTyConBinder] +stripIfaceInvisVars dflags tyvars + | gopt Opt_PrintExplicitKinds dflags = tyvars + | otherwise = filterOut isInvisibleTyConBinder tyvars + +-- | Extract an 'IfaceBndr' from an 'IfaceForAllBndr'. +ifForAllBndrVar :: IfaceForAllBndr -> IfaceBndr +ifForAllBndrVar = binderVar + +-- | Extract the variable name from an 'IfaceForAllBndr'. +ifForAllBndrName :: IfaceForAllBndr -> IfLclName +ifForAllBndrName fab = ifaceBndrName (ifForAllBndrVar fab) + +-- | Extract an 'IfaceBndr' from an 'IfaceTyConBinder'. +ifTyConBinderVar :: IfaceTyConBinder -> IfaceBndr +ifTyConBinderVar = binderVar + +-- | Extract the variable name from an 'IfaceTyConBinder'. +ifTyConBinderName :: IfaceTyConBinder -> IfLclName +ifTyConBinderName tcb = ifaceBndrName (ifTyConBinderVar tcb) + +ifTypeIsVarFree :: IfaceType -> Bool +-- Returns True if the type definitely has no variables at all +-- Just used to control pretty printing +ifTypeIsVarFree ty = go ty + where + go (IfaceTyVar {}) = False + go (IfaceFreeTyVar {}) = False + go (IfaceAppTy fun args) = go fun && go_args args + go (IfaceFunTy _ arg res) = go arg && go res + go (IfaceForAllTy {}) = False + go (IfaceTyConApp _ args) = go_args args + go (IfaceTupleTy _ _ args) = go_args args + go (IfaceLitTy _) = True + go (IfaceCastTy {}) = False -- Safe + go (IfaceCoercionTy {}) = False -- Safe + + go_args IA_Nil = True + go_args (IA_Arg arg _ args) = go arg && go_args args + +{- Note [Substitution on IfaceType] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Substitutions on IfaceType are done only during pretty-printing to +construct the result type of a GADT, and does not deal with binders +(eg IfaceForAll), so it doesn't need fancy capture stuff. -} + +type IfaceTySubst = FastStringEnv IfaceType -- Note [Substitution on IfaceType] + +mkIfaceTySubst :: [(IfLclName,IfaceType)] -> IfaceTySubst +-- See Note [Substitution on IfaceType] +mkIfaceTySubst eq_spec = mkFsEnv eq_spec + +inDomIfaceTySubst :: IfaceTySubst -> IfaceTvBndr -> Bool +-- See Note [Substitution on IfaceType] +inDomIfaceTySubst subst (fs, _) = isJust (lookupFsEnv subst fs) + +substIfaceType :: IfaceTySubst -> IfaceType -> IfaceType +-- See Note [Substitution on IfaceType] +substIfaceType env ty + = go ty + where + go (IfaceFreeTyVar tv) = IfaceFreeTyVar tv + go (IfaceTyVar tv) = substIfaceTyVar env tv + go (IfaceAppTy t ts) = IfaceAppTy (go t) (substIfaceAppArgs env ts) + go (IfaceFunTy af t1 t2) = IfaceFunTy af (go t1) (go t2) + go ty@(IfaceLitTy {}) = ty + go (IfaceTyConApp tc tys) = IfaceTyConApp tc (substIfaceAppArgs env tys) + go (IfaceTupleTy s i tys) = IfaceTupleTy s i (substIfaceAppArgs env tys) + go (IfaceForAllTy {}) = pprPanic "substIfaceType" (ppr ty) + go (IfaceCastTy ty co) = IfaceCastTy (go ty) (go_co co) + go (IfaceCoercionTy co) = IfaceCoercionTy (go_co co) + + go_mco IfaceMRefl = IfaceMRefl + go_mco (IfaceMCo co) = IfaceMCo $ go_co co + + go_co (IfaceReflCo ty) = IfaceReflCo (go ty) + go_co (IfaceGReflCo r ty mco) = IfaceGReflCo r (go ty) (go_mco mco) + go_co (IfaceFunCo r c1 c2) = IfaceFunCo r (go_co c1) (go_co c2) + go_co (IfaceTyConAppCo r tc cos) = IfaceTyConAppCo r tc (go_cos cos) + go_co (IfaceAppCo c1 c2) = IfaceAppCo (go_co c1) (go_co c2) + go_co (IfaceForAllCo {}) = pprPanic "substIfaceCoercion" (ppr ty) + go_co (IfaceFreeCoVar cv) = IfaceFreeCoVar cv + go_co (IfaceCoVarCo cv) = IfaceCoVarCo cv + go_co (IfaceHoleCo cv) = IfaceHoleCo cv + go_co (IfaceAxiomInstCo a i cos) = IfaceAxiomInstCo a i (go_cos cos) + go_co (IfaceUnivCo prov r t1 t2) = IfaceUnivCo (go_prov prov) r (go t1) (go t2) + go_co (IfaceSymCo co) = IfaceSymCo (go_co co) + go_co (IfaceTransCo co1 co2) = IfaceTransCo (go_co co1) (go_co co2) + go_co (IfaceNthCo n co) = IfaceNthCo n (go_co co) + go_co (IfaceLRCo lr co) = IfaceLRCo lr (go_co co) + go_co (IfaceInstCo c1 c2) = IfaceInstCo (go_co c1) (go_co c2) + go_co (IfaceKindCo co) = IfaceKindCo (go_co co) + go_co (IfaceSubCo co) = IfaceSubCo (go_co co) + go_co (IfaceAxiomRuleCo n cos) = IfaceAxiomRuleCo n (go_cos cos) + + go_cos = map go_co + + go_prov IfaceUnsafeCoerceProv = IfaceUnsafeCoerceProv + go_prov (IfacePhantomProv co) = IfacePhantomProv (go_co co) + go_prov (IfaceProofIrrelProv co) = IfaceProofIrrelProv (go_co co) + go_prov (IfacePluginProv str) = IfacePluginProv str + +substIfaceAppArgs :: IfaceTySubst -> IfaceAppArgs -> IfaceAppArgs +substIfaceAppArgs env args + = go args + where + go IA_Nil = IA_Nil + go (IA_Arg ty arg tys) = IA_Arg (substIfaceType env ty) arg (go tys) + +substIfaceTyVar :: IfaceTySubst -> IfLclName -> IfaceType +substIfaceTyVar env tv + | Just ty <- lookupFsEnv env tv = ty + | otherwise = IfaceTyVar tv + + +{- +************************************************************************ +* * + Functions over IfaceAppArgs +* * +************************************************************************ +-} + +stripInvisArgs :: DynFlags -> IfaceAppArgs -> IfaceAppArgs +stripInvisArgs dflags tys + | gopt Opt_PrintExplicitKinds dflags = tys + | otherwise = suppress_invis tys + where + suppress_invis c + = case c of + IA_Nil -> IA_Nil + IA_Arg t argf ts + | isVisibleArgFlag argf + -> IA_Arg t argf $ suppress_invis ts + -- Keep recursing through the remainder of the arguments, as it's + -- possible that there are remaining invisible ones. + -- See the "In type declarations" section of Note [VarBndrs, + -- TyCoVarBinders, TyConBinders, and visibility] in TyCoRep. + | otherwise + -> suppress_invis ts + +appArgsIfaceTypes :: IfaceAppArgs -> [IfaceType] +appArgsIfaceTypes IA_Nil = [] +appArgsIfaceTypes (IA_Arg t _ ts) = t : appArgsIfaceTypes ts + +appArgsIfaceTypesArgFlags :: IfaceAppArgs -> [(IfaceType, ArgFlag)] +appArgsIfaceTypesArgFlags IA_Nil = [] +appArgsIfaceTypesArgFlags (IA_Arg t a ts) + = (t, a) : appArgsIfaceTypesArgFlags ts + +ifaceVisAppArgsLength :: IfaceAppArgs -> Int +ifaceVisAppArgsLength = go 0 + where + go !n IA_Nil = n + go n (IA_Arg _ argf rest) + | isVisibleArgFlag argf = go (n+1) rest + | otherwise = go n rest + +{- +Note [Suppressing invisible arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We use the IfaceAppArgs data type to specify which of the arguments to a type +should be displayed when pretty-printing, under the control of +-fprint-explicit-kinds. +See also Type.filterOutInvisibleTypes. +For example, given + + T :: forall k. (k->*) -> k -> * -- Ordinary kind polymorphism + 'Just :: forall k. k -> 'Maybe k -- Promoted + +we want + + T * Tree Int prints as T Tree Int + 'Just * prints as Just * + +For type constructors (IfaceTyConApp), IfaceAppArgs is a quite natural fit, +since the corresponding Core constructor: + + data Type + = ... + | TyConApp TyCon [Type] + +Already puts all of its arguments into a list. So when converting a Type to an +IfaceType (see toIfaceAppArgsX in ToIface), we simply use the kind of the TyCon +(which is cached) to guide the process of converting the argument Types into an +IfaceAppArgs list. + +We also want this behavior for IfaceAppTy, since given: + + data Proxy (a :: k) + f :: forall (t :: forall a. a -> Type). Proxy Type (t Bool True) + +We want to print the return type as `Proxy (t True)` without the use of +-fprint-explicit-kinds (#15330). Accomplishing this is trickier than in the +tycon case, because the corresponding Core constructor for IfaceAppTy: + + data Type + = ... + | AppTy Type Type + +Only stores one argument at a time. Therefore, when converting an AppTy to an +IfaceAppTy (in toIfaceTypeX in ToIface), we: + +1. Flatten the chain of AppTys down as much as possible +2. Use typeKind to determine the function Type's kind +3. Use this kind to guide the process of converting the argument Types into an + IfaceAppArgs list. + +By flattening the arguments like this, we obtain two benefits: + +(a) We can reuse the same machinery to pretty-print IfaceTyConApp arguments as + we do IfaceTyApp arguments, which means that we only need to implement the + logic to filter out invisible arguments once. +(b) Unlike for tycons, finding the kind of a type in general (through typeKind) + is not a constant-time operation, so by flattening the arguments first, we + decrease the number of times we have to call typeKind. + +Note [Pretty-printing invisible arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Suppressing invisible arguments] is all about how to avoid printing +invisible arguments when the -fprint-explicit-kinds flag is disables. Well, +what about when it's enabled? Then we can and should print invisible kind +arguments, and this Note explains how we do it. + +As two running examples, consider the following code: + + {-# LANGUAGE PolyKinds #-} + data T1 a + data T2 (a :: k) + +When displaying these types (with -fprint-explicit-kinds on), we could just +do the following: + + T1 k a + T2 k a + +That certainly gets the job done. But it lacks a crucial piece of information: +is the `k` argument inferred or specified? To communicate this, we use visible +kind application syntax to distinguish the two cases: + + T1 @{k} a + T2 @k a + +Here, @{k} indicates that `k` is an inferred argument, and @k indicates that +`k` is a specified argument. (See +Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep for +a lengthier explanation on what "inferred" and "specified" mean.) + +************************************************************************ +* * + Pretty-printing +* * +************************************************************************ +-} + +if_print_coercions :: SDoc -- ^ if printing coercions + -> SDoc -- ^ otherwise + -> SDoc +if_print_coercions yes no + = sdocWithDynFlags $ \dflags -> + getPprStyle $ \style -> + if gopt Opt_PrintExplicitCoercions dflags + || dumpStyle style || debugStyle style + then yes + else no + +pprIfaceInfixApp :: PprPrec -> SDoc -> SDoc -> SDoc -> SDoc +pprIfaceInfixApp ctxt_prec pp_tc pp_ty1 pp_ty2 + = maybeParen ctxt_prec opPrec $ + sep [pp_ty1, pp_tc <+> pp_ty2] + +pprIfacePrefixApp :: PprPrec -> SDoc -> [SDoc] -> SDoc +pprIfacePrefixApp ctxt_prec pp_fun pp_tys + | null pp_tys = pp_fun + | otherwise = maybeParen ctxt_prec appPrec $ + hang pp_fun 2 (sep pp_tys) + +-- ----------------------------- Printing binders ------------------------------------ + +instance Outputable IfaceBndr where + ppr (IfaceIdBndr bndr) = pprIfaceIdBndr bndr + ppr (IfaceTvBndr bndr) = char '@' <+> pprIfaceTvBndr False bndr + +pprIfaceBndrs :: [IfaceBndr] -> SDoc +pprIfaceBndrs bs = sep (map ppr bs) + +pprIfaceLamBndr :: IfaceLamBndr -> SDoc +pprIfaceLamBndr (b, IfaceNoOneShot) = ppr b +pprIfaceLamBndr (b, IfaceOneShot) = ppr b <> text "[OneShot]" + +pprIfaceIdBndr :: IfaceIdBndr -> SDoc +pprIfaceIdBndr (name, ty) = parens (ppr name <+> dcolon <+> ppr ty) + +pprIfaceTvBndr :: Bool -> IfaceTvBndr -> SDoc +pprIfaceTvBndr use_parens (tv, ki) + | isIfaceLiftedTypeKind ki = ppr tv + | otherwise = maybe_parens (ppr tv <+> dcolon <+> ppr ki) + where + maybe_parens | use_parens = parens + | otherwise = id + +pprIfaceTyConBinders :: [IfaceTyConBinder] -> SDoc +pprIfaceTyConBinders = sep . map go + where + go :: IfaceTyConBinder -> SDoc + go (Bndr (IfaceIdBndr bndr) _) = pprIfaceIdBndr bndr + go (Bndr (IfaceTvBndr bndr) vis) = + -- See Note [Pretty-printing invisible arguments] + case vis of + AnonTCB VisArg -> ppr_bndr True + AnonTCB InvisArg -> ppr_bndr True -- Rare; just promoted GADT data constructors + -- Should we print them differently? + NamedTCB Required -> ppr_bndr True + NamedTCB Specified -> char '@' <> ppr_bndr True + NamedTCB Inferred -> char '@' <> braces (ppr_bndr False) + where + ppr_bndr use_parens = pprIfaceTvBndr use_parens bndr + +instance Binary IfaceBndr where + put_ bh (IfaceIdBndr aa) = do + putByte bh 0 + put_ bh aa + put_ bh (IfaceTvBndr ab) = do + putByte bh 1 + put_ bh ab + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + return (IfaceIdBndr aa) + _ -> do ab <- get bh + return (IfaceTvBndr ab) + +instance Binary IfaceOneShot where + put_ bh IfaceNoOneShot = do + putByte bh 0 + put_ bh IfaceOneShot = do + putByte bh 1 + get bh = do + h <- getByte bh + case h of + 0 -> do return IfaceNoOneShot + _ -> do return IfaceOneShot + +-- ----------------------------- Printing IfaceType ------------------------------------ + +--------------------------------- +instance Outputable IfaceType where + ppr ty = pprIfaceType ty + +pprIfaceType, pprParendIfaceType :: IfaceType -> SDoc +pprIfaceType = pprPrecIfaceType topPrec +pprParendIfaceType = pprPrecIfaceType appPrec + +pprPrecIfaceType :: PprPrec -> IfaceType -> SDoc +-- We still need `eliminateRuntimeRep`, since the `pprPrecIfaceType` maybe +-- called from other places, besides `:type` and `:info`. +pprPrecIfaceType prec ty = eliminateRuntimeRep (ppr_ty prec) ty + +ppr_sigma :: PprPrec -> IfaceType -> SDoc +ppr_sigma ctxt_prec ty + = maybeParen ctxt_prec funPrec (pprIfaceSigmaType ShowForAllMust ty) + +ppr_ty :: PprPrec -> IfaceType -> SDoc +ppr_ty ctxt_prec ty@(IfaceForAllTy {}) = ppr_sigma ctxt_prec ty +ppr_ty ctxt_prec ty@(IfaceFunTy InvisArg _ _) = ppr_sigma ctxt_prec ty + +ppr_ty _ (IfaceFreeTyVar tyvar) = ppr tyvar -- This is the main reason for IfaceFreeTyVar! +ppr_ty _ (IfaceTyVar tyvar) = ppr tyvar -- See Note [TcTyVars in IfaceType] +ppr_ty ctxt_prec (IfaceTyConApp tc tys) = pprTyTcApp ctxt_prec tc tys +ppr_ty ctxt_prec (IfaceTupleTy i p tys) = pprTuple ctxt_prec i p tys +ppr_ty _ (IfaceLitTy n) = pprIfaceTyLit n + -- Function types +ppr_ty ctxt_prec (IfaceFunTy _ ty1 ty2) -- Should be VisArg + = -- We don't want to lose synonyms, so we mustn't use splitFunTys here. + maybeParen ctxt_prec funPrec $ + sep [ppr_ty funPrec ty1, sep (ppr_fun_tail ty2)] + where + ppr_fun_tail (IfaceFunTy VisArg ty1 ty2) + = (arrow <+> ppr_ty funPrec ty1) : ppr_fun_tail ty2 + ppr_fun_tail other_ty + = [arrow <+> pprIfaceType other_ty] + +ppr_ty ctxt_prec (IfaceAppTy t ts) + = if_print_coercions + ppr_app_ty + ppr_app_ty_no_casts + where + ppr_app_ty = + sdocWithDynFlags $ \dflags -> + pprIfacePrefixApp ctxt_prec + (ppr_ty funPrec t) + (map (ppr_app_arg appPrec) (tys_wo_kinds dflags)) + + tys_wo_kinds dflags = appArgsIfaceTypesArgFlags $ stripInvisArgs dflags ts + + -- Strip any casts from the head of the application + ppr_app_ty_no_casts = + case t of + IfaceCastTy head _ -> ppr_ty ctxt_prec (mk_app_tys head ts) + _ -> ppr_app_ty + + mk_app_tys :: IfaceType -> IfaceAppArgs -> IfaceType + mk_app_tys (IfaceTyConApp tc tys1) tys2 = + IfaceTyConApp tc (tys1 `mappend` tys2) + mk_app_tys t1 tys2 = IfaceAppTy t1 tys2 + +ppr_ty ctxt_prec (IfaceCastTy ty co) + = if_print_coercions + (parens (ppr_ty topPrec ty <+> text "|>" <+> ppr co)) + (ppr_ty ctxt_prec ty) + +ppr_ty ctxt_prec (IfaceCoercionTy co) + = if_print_coercions + (ppr_co ctxt_prec co) + (text "<>") + +{- Note [Defaulting RuntimeRep variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +RuntimeRep variables are considered by many (most?) users to be little +more than syntactic noise. When the notion was introduced there was a +signficant and understandable push-back from those with pedagogy in +mind, which argued that RuntimeRep variables would throw a wrench into +nearly any teach approach since they appear in even the lowly ($) +function's type, + + ($) :: forall (w :: RuntimeRep) a (b :: TYPE w). (a -> b) -> a -> b + +which is significantly less readable than its non RuntimeRep-polymorphic type of + + ($) :: (a -> b) -> a -> b + +Moreover, unboxed types don't appear all that often in run-of-the-mill +Haskell programs, so it makes little sense to make all users pay this +syntactic overhead. + +For this reason it was decided that we would hide RuntimeRep variables +for now (see #11549). We do this by defaulting all type variables of +kind RuntimeRep to LiftedRep. This is done in a pass right before +pretty-printing (defaultRuntimeRepVars, controlled by +-fprint-explicit-runtime-reps) + +This applies to /quantified/ variables like 'w' above. What about +variables that are /free/ in the type being printed, which certainly +happens in error messages. Suppose (#16074) we are reporting a +mismatch between two skolems + (a :: RuntimeRep) ~ (b :: RuntimeRep) +We certainly don't want to say "Can't match LiftedRep ~ LiftedRep"! + +But if we are printing the type + (forall (a :: Type r). blah +we do want to turn that (free) r into LiftedRep, so it prints as + (forall a. blah) + +Conclusion: keep track of whether we we are in the kind of a +binder; ohly if so, convert free RuntimeRep variables to LiftedRep. +-} + +-- | Default 'RuntimeRep' variables to 'LiftedPtr'. e.g. +-- +-- @ +-- ($) :: forall (r :: GHC.Types.RuntimeRep) a (b :: TYPE r). +-- (a -> b) -> a -> b +-- @ +-- +-- turns in to, +-- +-- @ ($) :: forall a (b :: *). (a -> b) -> a -> b @ +-- +-- We do this to prevent RuntimeRep variables from incurring a significant +-- syntactic overhead in otherwise simple type signatures (e.g. ($)). See +-- Note [Defaulting RuntimeRep variables] and #11549 for further discussion. +-- +defaultRuntimeRepVars :: IfaceType -> IfaceType +defaultRuntimeRepVars ty = go False emptyFsEnv ty + where + go :: Bool -- True <=> Inside the kind of a binder + -> FastStringEnv () -- Set of enclosing forall-ed RuntimeRep variables + -> IfaceType -- (replace them with LiftedRep) + -> IfaceType + go ink subs (IfaceForAllTy (Bndr (IfaceTvBndr (var, var_kind)) argf) ty) + | isRuntimeRep var_kind + , isInvisibleArgFlag argf -- Don't default *visible* quantification + -- or we get the mess in #13963 + = let subs' = extendFsEnv subs var () + -- Record that we should replace it with LiftedRep, + -- and recurse, discarding the forall + in go ink subs' ty + + go ink subs (IfaceForAllTy bndr ty) + = IfaceForAllTy (go_ifacebndr subs bndr) (go ink subs ty) + + go _ subs ty@(IfaceTyVar tv) + | tv `elemFsEnv` subs + = IfaceTyConApp liftedRep IA_Nil + | otherwise + = ty + + go in_kind _ ty@(IfaceFreeTyVar tv) + -- See Note [Defaulting RuntimeRep variables], about free vars + | in_kind && TyCoRep.isRuntimeRepTy (tyVarKind tv) + = IfaceTyConApp liftedRep IA_Nil + | otherwise + = ty + + go ink subs (IfaceTyConApp tc tc_args) + = IfaceTyConApp tc (go_args ink subs tc_args) + + go ink subs (IfaceTupleTy sort is_prom tc_args) + = IfaceTupleTy sort is_prom (go_args ink subs tc_args) + + go ink subs (IfaceFunTy af arg res) + = IfaceFunTy af (go ink subs arg) (go ink subs res) + + go ink subs (IfaceAppTy t ts) + = IfaceAppTy (go ink subs t) (go_args ink subs ts) + + go ink subs (IfaceCastTy x co) + = IfaceCastTy (go ink subs x) co + + go _ _ ty@(IfaceLitTy {}) = ty + go _ _ ty@(IfaceCoercionTy {}) = ty + + go_ifacebndr :: FastStringEnv () -> IfaceForAllBndr -> IfaceForAllBndr + go_ifacebndr subs (Bndr (IfaceIdBndr (n, t)) argf) + = Bndr (IfaceIdBndr (n, go True subs t)) argf + go_ifacebndr subs (Bndr (IfaceTvBndr (n, t)) argf) + = Bndr (IfaceTvBndr (n, go True subs t)) argf + + go_args :: Bool -> FastStringEnv () -> IfaceAppArgs -> IfaceAppArgs + go_args _ _ IA_Nil = IA_Nil + go_args ink subs (IA_Arg ty argf args) + = IA_Arg (go ink subs ty) argf (go_args ink subs args) + + liftedRep :: IfaceTyCon + liftedRep = IfaceTyCon dc_name (IfaceTyConInfo IsPromoted IfaceNormalTyCon) + where dc_name = getName liftedRepDataConTyCon + + isRuntimeRep :: IfaceType -> Bool + isRuntimeRep (IfaceTyConApp tc _) = + tc `ifaceTyConHasKey` runtimeRepTyConKey + isRuntimeRep _ = False + +eliminateRuntimeRep :: (IfaceType -> SDoc) -> IfaceType -> SDoc +eliminateRuntimeRep f ty + = sdocWithDynFlags $ \dflags -> + getPprStyle $ \sty -> + if userStyle sty && not (gopt Opt_PrintExplicitRuntimeReps dflags) + then f (defaultRuntimeRepVars ty) + else f ty + +instance Outputable IfaceAppArgs where + ppr tca = pprIfaceAppArgs tca + +pprIfaceAppArgs, pprParendIfaceAppArgs :: IfaceAppArgs -> SDoc +pprIfaceAppArgs = ppr_app_args topPrec +pprParendIfaceAppArgs = ppr_app_args appPrec + +ppr_app_args :: PprPrec -> IfaceAppArgs -> SDoc +ppr_app_args ctx_prec = go + where + go :: IfaceAppArgs -> SDoc + go IA_Nil = empty + go (IA_Arg t argf ts) = ppr_app_arg ctx_prec (t, argf) <+> go ts + +-- See Note [Pretty-printing invisible arguments] +ppr_app_arg :: PprPrec -> (IfaceType, ArgFlag) -> SDoc +ppr_app_arg ctx_prec (t, argf) = + sdocWithDynFlags $ \dflags -> + let print_kinds = gopt Opt_PrintExplicitKinds dflags + in case argf of + Required -> ppr_ty ctx_prec t + Specified | print_kinds + -> char '@' <> ppr_ty appPrec t + Inferred | print_kinds + -> char '@' <> braces (ppr_ty topPrec t) + _ -> empty + +------------------- +pprIfaceForAllPart :: [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc +pprIfaceForAllPart tvs ctxt sdoc + = ppr_iface_forall_part ShowForAllWhen tvs ctxt sdoc + +-- | Like 'pprIfaceForAllPart', but always uses an explicit @forall@. +pprIfaceForAllPartMust :: [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc +pprIfaceForAllPartMust tvs ctxt sdoc + = ppr_iface_forall_part ShowForAllMust tvs ctxt sdoc + +pprIfaceForAllCoPart :: [(IfLclName, IfaceCoercion)] -> SDoc -> SDoc +pprIfaceForAllCoPart tvs sdoc + = sep [ pprIfaceForAllCo tvs, sdoc ] + +ppr_iface_forall_part :: ShowForAllFlag + -> [IfaceForAllBndr] -> [IfacePredType] -> SDoc -> SDoc +ppr_iface_forall_part show_forall tvs ctxt sdoc + = sep [ case show_forall of + ShowForAllMust -> pprIfaceForAll tvs + ShowForAllWhen -> pprUserIfaceForAll tvs + , pprIfaceContextArr ctxt + , sdoc] + +-- | Render the "forall ... ." or "forall ... ->" bit of a type. +pprIfaceForAll :: [IfaceForAllBndr] -> SDoc +pprIfaceForAll [] = empty +pprIfaceForAll bndrs@(Bndr _ vis : _) + = sep [ add_separator (forAllLit <+> fsep docs) + , pprIfaceForAll bndrs' ] + where + (bndrs', docs) = ppr_itv_bndrs bndrs vis + + add_separator stuff = case vis of + Required -> stuff <+> arrow + _inv -> stuff <> dot + + +-- | Render the ... in @(forall ... .)@ or @(forall ... ->)@. +-- Returns both the list of not-yet-rendered binders and the doc. +-- No anonymous binders here! +ppr_itv_bndrs :: [IfaceForAllBndr] + -> ArgFlag -- ^ visibility of the first binder in the list + -> ([IfaceForAllBndr], [SDoc]) +ppr_itv_bndrs all_bndrs@(bndr@(Bndr _ vis) : bndrs) vis1 + | vis `sameVis` vis1 = let (bndrs', doc) = ppr_itv_bndrs bndrs vis1 in + (bndrs', pprIfaceForAllBndr bndr : doc) + | otherwise = (all_bndrs, []) +ppr_itv_bndrs [] _ = ([], []) + +pprIfaceForAllCo :: [(IfLclName, IfaceCoercion)] -> SDoc +pprIfaceForAllCo [] = empty +pprIfaceForAllCo tvs = text "forall" <+> pprIfaceForAllCoBndrs tvs <> dot + +pprIfaceForAllCoBndrs :: [(IfLclName, IfaceCoercion)] -> SDoc +pprIfaceForAllCoBndrs bndrs = hsep $ map pprIfaceForAllCoBndr bndrs + +pprIfaceForAllBndr :: IfaceForAllBndr -> SDoc +pprIfaceForAllBndr (Bndr (IfaceTvBndr tv) Inferred) + = sdocWithDynFlags $ \dflags -> + if gopt Opt_PrintExplicitForalls dflags + then braces $ pprIfaceTvBndr False tv + else pprIfaceTvBndr True tv +pprIfaceForAllBndr (Bndr (IfaceTvBndr tv) _) = pprIfaceTvBndr True tv +pprIfaceForAllBndr (Bndr (IfaceIdBndr idv) _) = pprIfaceIdBndr idv + +pprIfaceForAllCoBndr :: (IfLclName, IfaceCoercion) -> SDoc +pprIfaceForAllCoBndr (tv, kind_co) + = parens (ppr tv <+> dcolon <+> pprIfaceCoercion kind_co) + +-- | Show forall flag +-- +-- Unconditionally show the forall quantifier with ('ShowForAllMust') +-- or when ('ShowForAllWhen') the names used are free in the binder +-- or when compiling with -fprint-explicit-foralls. +data ShowForAllFlag = ShowForAllMust | ShowForAllWhen + +pprIfaceSigmaType :: ShowForAllFlag -> IfaceType -> SDoc +pprIfaceSigmaType show_forall ty + = eliminateRuntimeRep ppr_fn ty + where + ppr_fn iface_ty = + let (tvs, theta, tau) = splitIfaceSigmaTy iface_ty + in ppr_iface_forall_part show_forall tvs theta (ppr tau) + +pprUserIfaceForAll :: [IfaceForAllBndr] -> SDoc +pprUserIfaceForAll tvs + = sdocWithDynFlags $ \dflags -> + -- See Note [When to print foralls] + ppWhen (any tv_has_kind_var tvs + || any tv_is_required tvs + || gopt Opt_PrintExplicitForalls dflags) $ + pprIfaceForAll tvs + where + tv_has_kind_var (Bndr (IfaceTvBndr (_,kind)) _) + = not (ifTypeIsVarFree kind) + tv_has_kind_var _ = False + + tv_is_required = isVisibleArgFlag . binderArgFlag + +{- +Note [When to print foralls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We opt to explicitly pretty-print `forall`s if any of the following +criteria are met: + +1. -fprint-explicit-foralls is on. + +2. A bound type variable has a polymorphic kind. E.g., + + forall k (a::k). Proxy a -> Proxy a + + Since a's kind mentions a variable k, we print the foralls. + +3. A bound type variable is a visible argument (#14238). + Suppose we are printing the kind of: + + T :: forall k -> k -> Type + + The "forall k ->" notation means that this kind argument is required. + That is, it must be supplied at uses of T. E.g., + + f :: T (Type->Type) Monad -> Int + + So we print an explicit "T :: forall k -> k -> Type", + because omitting it and printing "T :: k -> Type" would be + utterly misleading. + + See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] + in TyCoRep. + +N.B. Until now (Aug 2018) we didn't check anything for coercion variables. + +Note [Printing foralls in type family instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We use the same criteria as in Note [When to print foralls] to determine +whether a type family instance should be pretty-printed with an explicit +`forall`. Example: + + type family Foo (a :: k) :: k where + Foo Maybe = [] + Foo (a :: Type) = Int + Foo a = a + +Without -fprint-explicit-foralls enabled, this will be pretty-printed as: + +type family Foo (a :: k) :: k where + Foo Maybe = [] + Foo a = Int + forall k (a :: k). Foo a = a + +Note that only the third equation has an explicit forall, since it has a type +variable with a non-Type kind. (If -fprint-explicit-foralls were enabled, then +the second equation would be preceded with `forall a.`.) + +There is one tricky point in the implementation: what visibility +do we give the type variables in a type family instance? Type family instances +only store type *variables*, not type variable *binders*, and only the latter +has visibility information. We opt to default the visibility of each of these +type variables to Specified because users can't ever instantiate these +variables manually, so the choice of visibility is only relevant to +pretty-printing. (This is why the `k` in `forall k (a :: k). ...` above is +printed the way it is, even though it wasn't written explicitly in the +original source code.) + +We adopt the same strategy for data family instances. Example: + + data family DF (a :: k) + data instance DF '[a, b] = DFList + +That data family instance is pretty-printed as: + + data instance forall j (a :: j) (b :: j). DF '[a, b] = DFList + +This is despite that the representation tycon for this data instance (call it +$DF:List) actually has different visibilities for its binders. +However, the visibilities of these binders are utterly irrelevant to the +programmer, who cares only about the specificity of variables in `DF`'s type, +not $DF:List's type. Therefore, we opt to pretty-print all variables in data +family instances as Specified. + +Note [Printing promoted type constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this GHCi session (#14343) + > _ :: Proxy '[ 'True ] + error: + Found hole: _ :: Proxy '['True] + +This would be bad, because the '[' looks like a character literal. +Solution: in type-level lists and tuples, add a leading space +if the first type is itself promoted. See pprSpaceIfPromotedTyCon. +-} + + +------------------- + +-- | Prefix a space if the given 'IfaceType' is a promoted 'TyCon'. +-- See Note [Printing promoted type constructors] +pprSpaceIfPromotedTyCon :: IfaceType -> SDoc -> SDoc +pprSpaceIfPromotedTyCon (IfaceTyConApp tyCon _) + = case ifaceTyConIsPromoted (ifaceTyConInfo tyCon) of + IsPromoted -> (space <>) + _ -> id +pprSpaceIfPromotedTyCon _ + = id + +-- See equivalent function in TyCoRep.hs +pprIfaceTyList :: PprPrec -> IfaceType -> IfaceType -> SDoc +-- Given a type-level list (t1 ': t2), see if we can print +-- it in list notation [t1, ...]. +-- Precondition: Opt_PrintExplicitKinds is off +pprIfaceTyList ctxt_prec ty1 ty2 + = case gather ty2 of + (arg_tys, Nothing) + -> char '\'' <> brackets (pprSpaceIfPromotedTyCon ty1 (fsep + (punctuate comma (map (ppr_ty topPrec) (ty1:arg_tys))))) + (arg_tys, Just tl) + -> maybeParen ctxt_prec funPrec $ hang (ppr_ty funPrec ty1) + 2 (fsep [ colon <+> ppr_ty funPrec ty | ty <- arg_tys ++ [tl]]) + where + gather :: IfaceType -> ([IfaceType], Maybe IfaceType) + -- (gather ty) = (tys, Nothing) means ty is a list [t1, .., tn] + -- = (tys, Just tl) means ty is of form t1:t2:...tn:tl + gather (IfaceTyConApp tc tys) + | tc `ifaceTyConHasKey` consDataConKey + , IA_Arg _ argf (IA_Arg ty1 Required (IA_Arg ty2 Required IA_Nil)) <- tys + , isInvisibleArgFlag argf + , (args, tl) <- gather ty2 + = (ty1:args, tl) + | tc `ifaceTyConHasKey` nilDataConKey + = ([], Nothing) + gather ty = ([], Just ty) + +pprIfaceTypeApp :: PprPrec -> IfaceTyCon -> IfaceAppArgs -> SDoc +pprIfaceTypeApp prec tc args = pprTyTcApp prec tc args + +pprTyTcApp :: PprPrec -> IfaceTyCon -> IfaceAppArgs -> SDoc +pprTyTcApp ctxt_prec tc tys = + sdocWithDynFlags $ \dflags -> + getPprStyle $ \style -> + pprTyTcApp' ctxt_prec tc tys dflags style + +pprTyTcApp' :: PprPrec -> IfaceTyCon -> IfaceAppArgs + -> DynFlags -> PprStyle -> SDoc +pprTyTcApp' ctxt_prec tc tys dflags style + | ifaceTyConName tc `hasKey` ipClassKey + , IA_Arg (IfaceLitTy (IfaceStrTyLit n)) + Required (IA_Arg ty Required IA_Nil) <- tys + = maybeParen ctxt_prec funPrec + $ char '?' <> ftext n <> text "::" <> ppr_ty topPrec ty + + | IfaceTupleTyCon arity sort <- ifaceTyConSort info + , not (debugStyle style) + , arity == ifaceVisAppArgsLength tys + = pprTuple ctxt_prec sort (ifaceTyConIsPromoted info) tys + + | IfaceSumTyCon arity <- ifaceTyConSort info + = pprSum arity (ifaceTyConIsPromoted info) tys + + | tc `ifaceTyConHasKey` consDataConKey + , not (gopt Opt_PrintExplicitKinds dflags) + , IA_Arg _ argf (IA_Arg ty1 Required (IA_Arg ty2 Required IA_Nil)) <- tys + , isInvisibleArgFlag argf + = pprIfaceTyList ctxt_prec ty1 ty2 + + | tc `ifaceTyConHasKey` tYPETyConKey + , IA_Arg (IfaceTyConApp rep IA_Nil) Required IA_Nil <- tys + , rep `ifaceTyConHasKey` liftedRepDataConKey + = kindType + + | otherwise + = getPprDebug $ \dbg -> + if | not dbg && tc `ifaceTyConHasKey` errorMessageTypeErrorFamKey + -- Suppress detail unles you _really_ want to see + -> text "(TypeError ...)" + + | Just doc <- ppr_equality ctxt_prec tc (appArgsIfaceTypes tys) + -> doc + + | otherwise + -> ppr_iface_tc_app ppr_app_arg ctxt_prec tc tys_wo_kinds + where + info = ifaceTyConInfo tc + tys_wo_kinds = appArgsIfaceTypesArgFlags $ stripInvisArgs dflags tys + +-- | Pretty-print a type-level equality. +-- Returns (Just doc) if the argument is a /saturated/ application +-- of eqTyCon (~) +-- eqPrimTyCon (~#) +-- eqReprPrimTyCon (~R#) +-- heqTyCon (~~) +-- +-- See Note [Equality predicates in IfaceType] +-- and Note [The equality types story] in TysPrim +ppr_equality :: PprPrec -> IfaceTyCon -> [IfaceType] -> Maybe SDoc +ppr_equality ctxt_prec tc args + | hetero_eq_tc + , [k1, k2, t1, t2] <- args + = Just $ print_equality (k1, k2, t1, t2) + + | hom_eq_tc + , [k, t1, t2] <- args + = Just $ print_equality (k, k, t1, t2) + + | otherwise + = Nothing + where + homogeneous = tc_name `hasKey` eqTyConKey -- (~) + || hetero_tc_used_homogeneously + where + hetero_tc_used_homogeneously + = case ifaceTyConSort $ ifaceTyConInfo tc of + IfaceEqualityTyCon -> True + _other -> False + -- True <=> a heterogeneous equality whose arguments + -- are (in this case) of the same kind + + tc_name = ifaceTyConName tc + pp = ppr_ty + hom_eq_tc = tc_name `hasKey` eqTyConKey -- (~) + hetero_eq_tc = tc_name `hasKey` eqPrimTyConKey -- (~#) + || tc_name `hasKey` eqReprPrimTyConKey -- (~R#) + || tc_name `hasKey` heqTyConKey -- (~~) + nominal_eq_tc = tc_name `hasKey` heqTyConKey -- (~~) + || tc_name `hasKey` eqPrimTyConKey -- (~#) + print_equality args = + sdocWithDynFlags $ \dflags -> + getPprStyle $ \style -> + print_equality' args style dflags + + print_equality' (ki1, ki2, ty1, ty2) style dflags + | -- If -fprint-equality-relations is on, just print the original TyCon + print_eqs + = ppr_infix_eq (ppr tc) + + | -- Homogeneous use of heterogeneous equality (ty1 ~~ ty2) + -- or unlifted equality (ty1 ~# ty2) + nominal_eq_tc, homogeneous + = ppr_infix_eq (text "~") + + | -- Heterogeneous use of unlifted equality (ty1 ~# ty2) + not homogeneous + = ppr_infix_eq (ppr heqTyCon) + + | -- Homogeneous use of representational unlifted equality (ty1 ~R# ty2) + tc_name `hasKey` eqReprPrimTyConKey, homogeneous + = let ki | print_kinds = [pp appPrec ki1] + | otherwise = [] + in pprIfacePrefixApp ctxt_prec (ppr coercibleTyCon) + (ki ++ [pp appPrec ty1, pp appPrec ty2]) + + -- The other cases work as you'd expect + | otherwise + = ppr_infix_eq (ppr tc) + where + ppr_infix_eq :: SDoc -> SDoc + ppr_infix_eq eq_op = pprIfaceInfixApp ctxt_prec eq_op + (pp_ty_ki ty1 ki1) (pp_ty_ki ty2 ki2) + where + pp_ty_ki ty ki + | print_kinds + = parens (pp topPrec ty <+> dcolon <+> pp opPrec ki) + | otherwise + = pp opPrec ty + + print_kinds = gopt Opt_PrintExplicitKinds dflags + print_eqs = gopt Opt_PrintEqualityRelations dflags || + dumpStyle style || debugStyle style + + +pprIfaceCoTcApp :: PprPrec -> IfaceTyCon -> [IfaceCoercion] -> SDoc +pprIfaceCoTcApp ctxt_prec tc tys = + ppr_iface_tc_app (\prec (co, _) -> ppr_co prec co) ctxt_prec tc + (map (, Required) tys) + -- We are trying to re-use ppr_iface_tc_app here, which requires its + -- arguments to be accompanied by visibilities. But visibility is + -- irrelevant when printing coercions, so just default everything to + -- Required. + +-- | Pretty-prints an application of a type constructor to some arguments +-- (whose visibilities are known). This is polymorphic (over @a@) since we use +-- this function to pretty-print two different things: +-- +-- 1. Types (from `pprTyTcApp'`) +-- +-- 2. Coercions (from 'pprIfaceCoTcApp') +ppr_iface_tc_app :: (PprPrec -> (a, ArgFlag) -> SDoc) + -> PprPrec -> IfaceTyCon -> [(a, ArgFlag)] -> SDoc +ppr_iface_tc_app pp _ tc [ty] + | tc `ifaceTyConHasKey` listTyConKey = pprPromotionQuote tc <> brackets (pp topPrec ty) + +ppr_iface_tc_app pp ctxt_prec tc tys + | tc `ifaceTyConHasKey` liftedTypeKindTyConKey + = kindType + + | not (isSymOcc (nameOccName (ifaceTyConName tc))) + = pprIfacePrefixApp ctxt_prec (ppr tc) (map (pp appPrec) tys) + + | [ ty1@(_, Required) + , ty2@(_, Required) ] <- tys + -- Infix, two visible arguments (we know nothing of precedence though). + -- Don't apply this special case if one of the arguments is invisible, + -- lest we print something like (@LiftedRep -> @LiftedRep) (#15941). + = pprIfaceInfixApp ctxt_prec (ppr tc) + (pp opPrec ty1) (pp opPrec ty2) + + | otherwise + = pprIfacePrefixApp ctxt_prec (parens (ppr tc)) (map (pp appPrec) tys) + +pprSum :: Arity -> PromotionFlag -> IfaceAppArgs -> SDoc +pprSum _arity is_promoted args + = -- drop the RuntimeRep vars. + -- See Note [Unboxed tuple RuntimeRep vars] in TyCon + let tys = appArgsIfaceTypes args + args' = drop (length tys `div` 2) tys + in pprPromotionQuoteI is_promoted + <> sumParens (pprWithBars (ppr_ty topPrec) args') + +pprTuple :: PprPrec -> TupleSort -> PromotionFlag -> IfaceAppArgs -> SDoc +pprTuple ctxt_prec ConstraintTuple NotPromoted IA_Nil + = maybeParen ctxt_prec appPrec $ + text "() :: Constraint" + +-- All promoted constructors have kind arguments +pprTuple _ sort IsPromoted args + = let tys = appArgsIfaceTypes args + args' = drop (length tys `div` 2) tys + spaceIfPromoted = case args' of + arg0:_ -> pprSpaceIfPromotedTyCon arg0 + _ -> id + in pprPromotionQuoteI IsPromoted <> + tupleParens sort (spaceIfPromoted (pprWithCommas pprIfaceType args')) + +pprTuple _ sort promoted args + = -- drop the RuntimeRep vars. + -- See Note [Unboxed tuple RuntimeRep vars] in TyCon + let tys = appArgsIfaceTypes args + args' = case sort of + UnboxedTuple -> drop (length tys `div` 2) tys + _ -> tys + in + pprPromotionQuoteI promoted <> + tupleParens sort (pprWithCommas pprIfaceType args') + +pprIfaceTyLit :: IfaceTyLit -> SDoc +pprIfaceTyLit (IfaceNumTyLit n) = integer n +pprIfaceTyLit (IfaceStrTyLit n) = text (show n) + +pprIfaceCoercion, pprParendIfaceCoercion :: IfaceCoercion -> SDoc +pprIfaceCoercion = ppr_co topPrec +pprParendIfaceCoercion = ppr_co appPrec + +ppr_co :: PprPrec -> IfaceCoercion -> SDoc +ppr_co _ (IfaceReflCo ty) = angleBrackets (ppr ty) <> ppr_role Nominal +ppr_co _ (IfaceGReflCo r ty IfaceMRefl) + = angleBrackets (ppr ty) <> ppr_role r +ppr_co ctxt_prec (IfaceGReflCo r ty (IfaceMCo co)) + = ppr_special_co ctxt_prec + (text "GRefl" <+> ppr r <+> pprParendIfaceType ty) [co] +ppr_co ctxt_prec (IfaceFunCo r co1 co2) + = maybeParen ctxt_prec funPrec $ + sep (ppr_co funPrec co1 : ppr_fun_tail co2) + where + ppr_fun_tail (IfaceFunCo r co1 co2) + = (arrow <> ppr_role r <+> ppr_co funPrec co1) : ppr_fun_tail co2 + ppr_fun_tail other_co + = [arrow <> ppr_role r <+> pprIfaceCoercion other_co] + +ppr_co _ (IfaceTyConAppCo r tc cos) + = parens (pprIfaceCoTcApp topPrec tc cos) <> ppr_role r +ppr_co ctxt_prec (IfaceAppCo co1 co2) + = maybeParen ctxt_prec appPrec $ + ppr_co funPrec co1 <+> pprParendIfaceCoercion co2 +ppr_co ctxt_prec co@(IfaceForAllCo {}) + = maybeParen ctxt_prec funPrec $ + pprIfaceForAllCoPart tvs (pprIfaceCoercion inner_co) + where + (tvs, inner_co) = split_co co + + split_co (IfaceForAllCo (IfaceTvBndr (name, _)) kind_co co') + = let (tvs, co'') = split_co co' in ((name,kind_co):tvs,co'') + split_co (IfaceForAllCo (IfaceIdBndr (name, _)) kind_co co') + = let (tvs, co'') = split_co co' in ((name,kind_co):tvs,co'') + split_co co' = ([], co') + +-- Why these three? See Note [TcTyVars in IfaceType] +ppr_co _ (IfaceFreeCoVar covar) = ppr covar +ppr_co _ (IfaceCoVarCo covar) = ppr covar +ppr_co _ (IfaceHoleCo covar) = braces (ppr covar) + +ppr_co ctxt_prec (IfaceUnivCo IfaceUnsafeCoerceProv r ty1 ty2) + = maybeParen ctxt_prec appPrec $ + text "UnsafeCo" <+> ppr r <+> + pprParendIfaceType ty1 <+> pprParendIfaceType ty2 + +ppr_co _ (IfaceUnivCo prov role ty1 ty2) + = text "Univ" <> (parens $ + sep [ ppr role <+> pprIfaceUnivCoProv prov + , dcolon <+> ppr ty1 <> comma <+> ppr ty2 ]) + +ppr_co ctxt_prec (IfaceInstCo co ty) + = maybeParen ctxt_prec appPrec $ + text "Inst" <+> pprParendIfaceCoercion co + <+> pprParendIfaceCoercion ty + +ppr_co ctxt_prec (IfaceAxiomRuleCo tc cos) + = maybeParen ctxt_prec appPrec $ ppr tc <+> parens (interpp'SP cos) + +ppr_co ctxt_prec (IfaceAxiomInstCo n i cos) + = ppr_special_co ctxt_prec (ppr n <> brackets (ppr i)) cos +ppr_co ctxt_prec (IfaceSymCo co) + = ppr_special_co ctxt_prec (text "Sym") [co] +ppr_co ctxt_prec (IfaceTransCo co1 co2) + = maybeParen ctxt_prec opPrec $ + ppr_co opPrec co1 <+> semi <+> ppr_co opPrec co2 +ppr_co ctxt_prec (IfaceNthCo d co) + = ppr_special_co ctxt_prec (text "Nth:" <> int d) [co] +ppr_co ctxt_prec (IfaceLRCo lr co) + = ppr_special_co ctxt_prec (ppr lr) [co] +ppr_co ctxt_prec (IfaceSubCo co) + = ppr_special_co ctxt_prec (text "Sub") [co] +ppr_co ctxt_prec (IfaceKindCo co) + = ppr_special_co ctxt_prec (text "Kind") [co] + +ppr_special_co :: PprPrec -> SDoc -> [IfaceCoercion] -> SDoc +ppr_special_co ctxt_prec doc cos + = maybeParen ctxt_prec appPrec + (sep [doc, nest 4 (sep (map pprParendIfaceCoercion cos))]) + +ppr_role :: Role -> SDoc +ppr_role r = underscore <> pp_role + where pp_role = case r of + Nominal -> char 'N' + Representational -> char 'R' + Phantom -> char 'P' + +------------------ +pprIfaceUnivCoProv :: IfaceUnivCoProv -> SDoc +pprIfaceUnivCoProv IfaceUnsafeCoerceProv + = text "unsafe" +pprIfaceUnivCoProv (IfacePhantomProv co) + = text "phantom" <+> pprParendIfaceCoercion co +pprIfaceUnivCoProv (IfaceProofIrrelProv co) + = text "irrel" <+> pprParendIfaceCoercion co +pprIfaceUnivCoProv (IfacePluginProv s) + = text "plugin" <+> doubleQuotes (text s) + +------------------- +instance Outputable IfaceTyCon where + ppr tc = pprPromotionQuote tc <> ppr (ifaceTyConName tc) + +pprPromotionQuote :: IfaceTyCon -> SDoc +pprPromotionQuote tc = + pprPromotionQuoteI $ ifaceTyConIsPromoted $ ifaceTyConInfo tc + +pprPromotionQuoteI :: PromotionFlag -> SDoc +pprPromotionQuoteI NotPromoted = empty +pprPromotionQuoteI IsPromoted = char '\'' + +instance Outputable IfaceCoercion where + ppr = pprIfaceCoercion + +instance Binary IfaceTyCon where + put_ bh (IfaceTyCon n i) = put_ bh n >> put_ bh i + + get bh = do n <- get bh + i <- get bh + return (IfaceTyCon n i) + +instance Binary IfaceTyConSort where + put_ bh IfaceNormalTyCon = putByte bh 0 + put_ bh (IfaceTupleTyCon arity sort) = putByte bh 1 >> put_ bh arity >> put_ bh sort + put_ bh (IfaceSumTyCon arity) = putByte bh 2 >> put_ bh arity + put_ bh IfaceEqualityTyCon = putByte bh 3 + + get bh = do + n <- getByte bh + case n of + 0 -> return IfaceNormalTyCon + 1 -> IfaceTupleTyCon <$> get bh <*> get bh + 2 -> IfaceSumTyCon <$> get bh + _ -> return IfaceEqualityTyCon + +instance Binary IfaceTyConInfo where + put_ bh (IfaceTyConInfo i s) = put_ bh i >> put_ bh s + + get bh = IfaceTyConInfo <$> get bh <*> get bh + +instance Outputable IfaceTyLit where + ppr = pprIfaceTyLit + +instance Binary IfaceTyLit where + put_ bh (IfaceNumTyLit n) = putByte bh 1 >> put_ bh n + put_ bh (IfaceStrTyLit n) = putByte bh 2 >> put_ bh n + + get bh = + do tag <- getByte bh + case tag of + 1 -> do { n <- get bh + ; return (IfaceNumTyLit n) } + 2 -> do { n <- get bh + ; return (IfaceStrTyLit n) } + _ -> panic ("get IfaceTyLit " ++ show tag) + +instance Binary IfaceAppArgs where + put_ bh tk = + case tk of + IA_Arg t a ts -> putByte bh 0 >> put_ bh t >> put_ bh a >> put_ bh ts + IA_Nil -> putByte bh 1 + + get bh = + do c <- getByte bh + case c of + 0 -> do + t <- get bh + a <- get bh + ts <- get bh + return $! IA_Arg t a ts + 1 -> return IA_Nil + _ -> panic ("get IfaceAppArgs " ++ show c) + +------------------- + +-- Some notes about printing contexts +-- +-- In the event that we are printing a singleton context (e.g. @Eq a@) we can +-- omit parentheses. However, we must take care to set the precedence correctly +-- to opPrec, since something like @a :~: b@ must be parenthesized (see +-- #9658). +-- +-- When printing a larger context we use 'fsep' instead of 'sep' so that +-- the context doesn't get displayed as a giant column. Rather than, +-- instance (Eq a, +-- Eq b, +-- Eq c, +-- Eq d, +-- Eq e, +-- Eq f, +-- Eq g, +-- Eq h, +-- Eq i, +-- Eq j, +-- Eq k, +-- Eq l) => +-- Eq (a, b, c, d, e, f, g, h, i, j, k, l) +-- +-- we want +-- +-- instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g, Eq h, Eq i, +-- Eq j, Eq k, Eq l) => +-- Eq (a, b, c, d, e, f, g, h, i, j, k, l) + + + +-- | Prints "(C a, D b) =>", including the arrow. +-- Used when we want to print a context in a type, so we +-- use 'funPrec' to decide whether to parenthesise a singleton +-- predicate; e.g. Num a => a -> a +pprIfaceContextArr :: [IfacePredType] -> SDoc +pprIfaceContextArr [] = empty +pprIfaceContextArr [pred] = ppr_ty funPrec pred <+> darrow +pprIfaceContextArr preds = ppr_parend_preds preds <+> darrow + +-- | Prints a context or @()@ if empty +-- You give it the context precedence +pprIfaceContext :: PprPrec -> [IfacePredType] -> SDoc +pprIfaceContext _ [] = text "()" +pprIfaceContext prec [pred] = ppr_ty prec pred +pprIfaceContext _ preds = ppr_parend_preds preds + +ppr_parend_preds :: [IfacePredType] -> SDoc +ppr_parend_preds preds = parens (fsep (punctuate comma (map ppr preds))) + +instance Binary IfaceType where + put_ _ (IfaceFreeTyVar tv) + = pprPanic "Can't serialise IfaceFreeTyVar" (ppr tv) + + put_ bh (IfaceForAllTy aa ab) = do + putByte bh 0 + put_ bh aa + put_ bh ab + put_ bh (IfaceTyVar ad) = do + putByte bh 1 + put_ bh ad + put_ bh (IfaceAppTy ae af) = do + putByte bh 2 + put_ bh ae + put_ bh af + put_ bh (IfaceFunTy af ag ah) = do + putByte bh 3 + put_ bh af + put_ bh ag + put_ bh ah + put_ bh (IfaceTyConApp tc tys) + = do { putByte bh 5; put_ bh tc; put_ bh tys } + put_ bh (IfaceCastTy a b) + = do { putByte bh 6; put_ bh a; put_ bh b } + put_ bh (IfaceCoercionTy a) + = do { putByte bh 7; put_ bh a } + put_ bh (IfaceTupleTy s i tys) + = do { putByte bh 8; put_ bh s; put_ bh i; put_ bh tys } + put_ bh (IfaceLitTy n) + = do { putByte bh 9; put_ bh n } + + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + ab <- get bh + return (IfaceForAllTy aa ab) + 1 -> do ad <- get bh + return (IfaceTyVar ad) + 2 -> do ae <- get bh + af <- get bh + return (IfaceAppTy ae af) + 3 -> do af <- get bh + ag <- get bh + ah <- get bh + return (IfaceFunTy af ag ah) + 5 -> do { tc <- get bh; tys <- get bh + ; return (IfaceTyConApp tc tys) } + 6 -> do { a <- get bh; b <- get bh + ; return (IfaceCastTy a b) } + 7 -> do { a <- get bh + ; return (IfaceCoercionTy a) } + + 8 -> do { s <- get bh; i <- get bh; tys <- get bh + ; return (IfaceTupleTy s i tys) } + _ -> do n <- get bh + return (IfaceLitTy n) + +instance Binary IfaceMCoercion where + put_ bh IfaceMRefl = do + putByte bh 1 + put_ bh (IfaceMCo co) = do + putByte bh 2 + put_ bh co + + get bh = do + tag <- getByte bh + case tag of + 1 -> return IfaceMRefl + 2 -> do a <- get bh + return $ IfaceMCo a + _ -> panic ("get IfaceMCoercion " ++ show tag) + +instance Binary IfaceCoercion where + put_ bh (IfaceReflCo a) = do + putByte bh 1 + put_ bh a + put_ bh (IfaceGReflCo a b c) = do + putByte bh 2 + put_ bh a + put_ bh b + put_ bh c + put_ bh (IfaceFunCo a b c) = do + putByte bh 3 + put_ bh a + put_ bh b + put_ bh c + put_ bh (IfaceTyConAppCo a b c) = do + putByte bh 4 + put_ bh a + put_ bh b + put_ bh c + put_ bh (IfaceAppCo a b) = do + putByte bh 5 + put_ bh a + put_ bh b + put_ bh (IfaceForAllCo a b c) = do + putByte bh 6 + put_ bh a + put_ bh b + put_ bh c + put_ bh (IfaceCoVarCo a) = do + putByte bh 7 + put_ bh a + put_ bh (IfaceAxiomInstCo a b c) = do + putByte bh 8 + put_ bh a + put_ bh b + put_ bh c + put_ bh (IfaceUnivCo a b c d) = do + putByte bh 9 + put_ bh a + put_ bh b + put_ bh c + put_ bh d + put_ bh (IfaceSymCo a) = do + putByte bh 10 + put_ bh a + put_ bh (IfaceTransCo a b) = do + putByte bh 11 + put_ bh a + put_ bh b + put_ bh (IfaceNthCo a b) = do + putByte bh 12 + put_ bh a + put_ bh b + put_ bh (IfaceLRCo a b) = do + putByte bh 13 + put_ bh a + put_ bh b + put_ bh (IfaceInstCo a b) = do + putByte bh 14 + put_ bh a + put_ bh b + put_ bh (IfaceKindCo a) = do + putByte bh 15 + put_ bh a + put_ bh (IfaceSubCo a) = do + putByte bh 16 + put_ bh a + put_ bh (IfaceAxiomRuleCo a b) = do + putByte bh 17 + put_ bh a + put_ bh b + put_ _ (IfaceFreeCoVar cv) + = pprPanic "Can't serialise IfaceFreeCoVar" (ppr cv) + put_ _ (IfaceHoleCo cv) + = pprPanic "Can't serialise IfaceHoleCo" (ppr cv) + -- See Note [Holes in IfaceCoercion] + + get bh = do + tag <- getByte bh + case tag of + 1 -> do a <- get bh + return $ IfaceReflCo a + 2 -> do a <- get bh + b <- get bh + c <- get bh + return $ IfaceGReflCo a b c + 3 -> do a <- get bh + b <- get bh + c <- get bh + return $ IfaceFunCo a b c + 4 -> do a <- get bh + b <- get bh + c <- get bh + return $ IfaceTyConAppCo a b c + 5 -> do a <- get bh + b <- get bh + return $ IfaceAppCo a b + 6 -> do a <- get bh + b <- get bh + c <- get bh + return $ IfaceForAllCo a b c + 7 -> do a <- get bh + return $ IfaceCoVarCo a + 8 -> do a <- get bh + b <- get bh + c <- get bh + return $ IfaceAxiomInstCo a b c + 9 -> do a <- get bh + b <- get bh + c <- get bh + d <- get bh + return $ IfaceUnivCo a b c d + 10-> do a <- get bh + return $ IfaceSymCo a + 11-> do a <- get bh + b <- get bh + return $ IfaceTransCo a b + 12-> do a <- get bh + b <- get bh + return $ IfaceNthCo a b + 13-> do a <- get bh + b <- get bh + return $ IfaceLRCo a b + 14-> do a <- get bh + b <- get bh + return $ IfaceInstCo a b + 15-> do a <- get bh + return $ IfaceKindCo a + 16-> do a <- get bh + return $ IfaceSubCo a + 17-> do a <- get bh + b <- get bh + return $ IfaceAxiomRuleCo a b + _ -> panic ("get IfaceCoercion " ++ show tag) + +instance Binary IfaceUnivCoProv where + put_ bh IfaceUnsafeCoerceProv = putByte bh 1 + put_ bh (IfacePhantomProv a) = do + putByte bh 2 + put_ bh a + put_ bh (IfaceProofIrrelProv a) = do + putByte bh 3 + put_ bh a + put_ bh (IfacePluginProv a) = do + putByte bh 4 + put_ bh a + + get bh = do + tag <- getByte bh + case tag of + 1 -> return $ IfaceUnsafeCoerceProv + 2 -> do a <- get bh + return $ IfacePhantomProv a + 3 -> do a <- get bh + return $ IfaceProofIrrelProv a + 4 -> do a <- get bh + return $ IfacePluginProv a + _ -> panic ("get IfaceUnivCoProv " ++ show tag) + + +instance Binary (DefMethSpec IfaceType) where + put_ bh VanillaDM = putByte bh 0 + put_ bh (GenericDM t) = putByte bh 1 >> put_ bh t + get bh = do + h <- getByte bh + case h of + 0 -> return VanillaDM + _ -> do { t <- get bh; return (GenericDM t) } diff --git a/compiler/iface/IfaceType.hs-boot b/compiler/iface/IfaceType.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/iface/IfaceType.hs-boot @@ -0,0 +1,15 @@ +-- Used only by ToIface.hs-boot + +module IfaceType( IfaceType, IfaceTyCon, IfaceForAllBndr + , IfaceCoercion, IfaceTyLit, IfaceAppArgs ) where + +import Var (VarBndr, ArgFlag) + +data IfaceAppArgs + +data IfaceType +data IfaceTyCon +data IfaceTyLit +data IfaceCoercion +data IfaceBndr +type IfaceForAllBndr = VarBndr IfaceBndr ArgFlag diff --git a/compiler/iface/ToIface.hs b/compiler/iface/ToIface.hs new file mode 100644 --- /dev/null +++ b/compiler/iface/ToIface.hs @@ -0,0 +1,650 @@ +{-# LANGUAGE CPP #-} + +-- | Functions for converting Core things to interface file things. +module ToIface + ( -- * Binders + toIfaceTvBndr + , toIfaceTvBndrs + , toIfaceIdBndr + , toIfaceBndr + , toIfaceForAllBndr + , toIfaceTyCoVarBinders + , toIfaceTyVar + -- * Types + , toIfaceType, toIfaceTypeX + , toIfaceKind + , toIfaceTcArgs + , toIfaceTyCon + , toIfaceTyCon_name + , toIfaceTyLit + -- * Tidying types + , tidyToIfaceType + , tidyToIfaceContext + , tidyToIfaceTcArgs + -- * Coercions + , toIfaceCoercion, toIfaceCoercionX + -- * Pattern synonyms + , patSynToIfaceDecl + -- * Expressions + , toIfaceExpr + , toIfaceBang + , toIfaceSrcBang + , toIfaceLetBndr + , toIfaceIdDetails + , toIfaceIdInfo + , toIfUnfolding + , toIfaceOneShot + , toIfaceTickish + , toIfaceBind + , toIfaceAlt + , toIfaceCon + , toIfaceApp + , toIfaceVar + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import IfaceSyn +import DataCon +import Id +import IdInfo +import CoreSyn +import TyCon hiding ( pprPromotionQuote ) +import CoAxiom +import TysPrim ( eqPrimTyCon, eqReprPrimTyCon ) +import TysWiredIn ( heqTyCon ) +import MkId ( noinlineIdName ) +import PrelNames +import Name +import BasicTypes +import Type +import PatSyn +import Outputable +import FastString +import Util +import Var +import VarEnv +import VarSet +import TyCoRep +import Demand ( isTopSig ) + +import Data.Maybe ( catMaybes ) + +---------------- +toIfaceTvBndr :: TyVar -> IfaceTvBndr +toIfaceTvBndr = toIfaceTvBndrX emptyVarSet + +toIfaceTvBndrX :: VarSet -> TyVar -> IfaceTvBndr +toIfaceTvBndrX fr tyvar = ( occNameFS (getOccName tyvar) + , toIfaceTypeX fr (tyVarKind tyvar) + ) + +toIfaceTvBndrs :: [TyVar] -> [IfaceTvBndr] +toIfaceTvBndrs = map toIfaceTvBndr + +toIfaceIdBndr :: Id -> IfaceIdBndr +toIfaceIdBndr = toIfaceIdBndrX emptyVarSet + +toIfaceIdBndrX :: VarSet -> CoVar -> IfaceIdBndr +toIfaceIdBndrX fr covar = ( occNameFS (getOccName covar) + , toIfaceTypeX fr (varType covar) + ) + +toIfaceBndr :: Var -> IfaceBndr +toIfaceBndr var + | isId var = IfaceIdBndr (toIfaceIdBndr var) + | otherwise = IfaceTvBndr (toIfaceTvBndr var) + +toIfaceBndrX :: VarSet -> Var -> IfaceBndr +toIfaceBndrX fr var + | isId var = IfaceIdBndr (toIfaceIdBndrX fr var) + | otherwise = IfaceTvBndr (toIfaceTvBndrX fr var) + +toIfaceTyCoVarBinder :: VarBndr Var vis -> VarBndr IfaceBndr vis +toIfaceTyCoVarBinder (Bndr tv vis) = Bndr (toIfaceBndr tv) vis + +toIfaceTyCoVarBinders :: [VarBndr Var vis] -> [VarBndr IfaceBndr vis] +toIfaceTyCoVarBinders = map toIfaceTyCoVarBinder + +{- +************************************************************************ +* * + Conversion from Type to IfaceType +* * +************************************************************************ +-} + +toIfaceKind :: Type -> IfaceType +toIfaceKind = toIfaceType + +--------------------- +toIfaceType :: Type -> IfaceType +toIfaceType = toIfaceTypeX emptyVarSet + +toIfaceTypeX :: VarSet -> Type -> IfaceType +-- (toIfaceTypeX free ty) +-- translates the tyvars in 'free' as IfaceFreeTyVars +-- +-- Synonyms are retained in the interface type +toIfaceTypeX fr (TyVarTy tv) -- See Note [TcTyVars in IfaceType] in IfaceType + | tv `elemVarSet` fr = IfaceFreeTyVar tv + | otherwise = IfaceTyVar (toIfaceTyVar tv) +toIfaceTypeX fr ty@(AppTy {}) = + -- Flatten as many argument AppTys as possible, then turn them into an + -- IfaceAppArgs list. + -- See Note [Suppressing invisible arguments] in IfaceType. + let (head, args) = splitAppTys ty + in IfaceAppTy (toIfaceTypeX fr head) (toIfaceAppTyArgsX fr head args) +toIfaceTypeX _ (LitTy n) = IfaceLitTy (toIfaceTyLit n) +toIfaceTypeX fr (ForAllTy b t) = IfaceForAllTy (toIfaceForAllBndrX fr b) + (toIfaceTypeX (fr `delVarSet` binderVar b) t) +toIfaceTypeX fr (FunTy { ft_arg = t1, ft_res = t2, ft_af = af }) + = IfaceFunTy af (toIfaceTypeX fr t1) (toIfaceTypeX fr t2) +toIfaceTypeX fr (CastTy ty co) = IfaceCastTy (toIfaceTypeX fr ty) (toIfaceCoercionX fr co) +toIfaceTypeX fr (CoercionTy co) = IfaceCoercionTy (toIfaceCoercionX fr co) + +toIfaceTypeX fr (TyConApp tc tys) + -- tuples + | Just sort <- tyConTuple_maybe tc + , n_tys == arity + = IfaceTupleTy sort NotPromoted (toIfaceTcArgsX fr tc tys) + + | Just dc <- isPromotedDataCon_maybe tc + , isTupleDataCon dc + , n_tys == 2*arity + = IfaceTupleTy BoxedTuple IsPromoted (toIfaceTcArgsX fr tc (drop arity tys)) + + | tc `elem` [ eqPrimTyCon, eqReprPrimTyCon, heqTyCon ] + , (k1:k2:_) <- tys + = let info = IfaceTyConInfo NotPromoted sort + sort | k1 `eqType` k2 = IfaceEqualityTyCon + | otherwise = IfaceNormalTyCon + in IfaceTyConApp (IfaceTyCon (tyConName tc) info) (toIfaceTcArgsX fr tc tys) + + -- other applications + | otherwise + = IfaceTyConApp (toIfaceTyCon tc) (toIfaceTcArgsX fr tc tys) + where + arity = tyConArity tc + n_tys = length tys + +toIfaceTyVar :: TyVar -> FastString +toIfaceTyVar = occNameFS . getOccName + +toIfaceCoVar :: CoVar -> FastString +toIfaceCoVar = occNameFS . getOccName + +toIfaceForAllBndr :: TyCoVarBinder -> IfaceForAllBndr +toIfaceForAllBndr = toIfaceForAllBndrX emptyVarSet + +toIfaceForAllBndrX :: VarSet -> TyCoVarBinder -> IfaceForAllBndr +toIfaceForAllBndrX fr (Bndr v vis) = Bndr (toIfaceBndrX fr v) vis + +---------------- +toIfaceTyCon :: TyCon -> IfaceTyCon +toIfaceTyCon tc + = IfaceTyCon tc_name info + where + tc_name = tyConName tc + info = IfaceTyConInfo promoted sort + promoted | isPromotedDataCon tc = IsPromoted + | otherwise = NotPromoted + + tupleSort :: TyCon -> Maybe IfaceTyConSort + tupleSort tc' = + case tyConTuple_maybe tc' of + Just UnboxedTuple -> let arity = tyConArity tc' `div` 2 + in Just $ IfaceTupleTyCon arity UnboxedTuple + Just sort -> let arity = tyConArity tc' + in Just $ IfaceTupleTyCon arity sort + Nothing -> Nothing + + sort + | Just tsort <- tupleSort tc = tsort + + | Just dcon <- isPromotedDataCon_maybe tc + , let tc' = dataConTyCon dcon + , Just tsort <- tupleSort tc' = tsort + + | isUnboxedSumTyCon tc + , Just cons <- isDataSumTyCon_maybe tc = IfaceSumTyCon (length cons) + + | otherwise = IfaceNormalTyCon + + +toIfaceTyCon_name :: Name -> IfaceTyCon +toIfaceTyCon_name n = IfaceTyCon n info + where info = IfaceTyConInfo NotPromoted IfaceNormalTyCon + -- Used for the "rough-match" tycon stuff, + -- where pretty-printing is not an issue + +toIfaceTyLit :: TyLit -> IfaceTyLit +toIfaceTyLit (NumTyLit x) = IfaceNumTyLit x +toIfaceTyLit (StrTyLit x) = IfaceStrTyLit x + +---------------- +toIfaceCoercion :: Coercion -> IfaceCoercion +toIfaceCoercion = toIfaceCoercionX emptyVarSet + +toIfaceCoercionX :: VarSet -> Coercion -> IfaceCoercion +-- (toIfaceCoercionX free ty) +-- translates the tyvars in 'free' as IfaceFreeTyVars +toIfaceCoercionX fr co + = go co + where + go_mco MRefl = IfaceMRefl + go_mco (MCo co) = IfaceMCo $ go co + + go (Refl ty) = IfaceReflCo (toIfaceTypeX fr ty) + go (GRefl r ty mco) = IfaceGReflCo r (toIfaceTypeX fr ty) (go_mco mco) + go (CoVarCo cv) + -- See [TcTyVars in IfaceType] in IfaceType + | cv `elemVarSet` fr = IfaceFreeCoVar cv + | otherwise = IfaceCoVarCo (toIfaceCoVar cv) + go (HoleCo h) = IfaceHoleCo (coHoleCoVar h) + + go (AppCo co1 co2) = IfaceAppCo (go co1) (go co2) + go (SymCo co) = IfaceSymCo (go co) + go (TransCo co1 co2) = IfaceTransCo (go co1) (go co2) + go (NthCo _r d co) = IfaceNthCo d (go co) + go (LRCo lr co) = IfaceLRCo lr (go co) + go (InstCo co arg) = IfaceInstCo (go co) (go arg) + go (KindCo c) = IfaceKindCo (go c) + go (SubCo co) = IfaceSubCo (go co) + go (AxiomRuleCo co cs) = IfaceAxiomRuleCo (coaxrName co) (map go cs) + go (AxiomInstCo c i cs) = IfaceAxiomInstCo (coAxiomName c) i (map go cs) + go (UnivCo p r t1 t2) = IfaceUnivCo (go_prov p) r + (toIfaceTypeX fr t1) + (toIfaceTypeX fr t2) + go (TyConAppCo r tc cos) + | tc `hasKey` funTyConKey + , [_,_,_,_] <- cos = pprPanic "toIfaceCoercion" (ppr co) + | otherwise = IfaceTyConAppCo r (toIfaceTyCon tc) (map go cos) + go (FunCo r co1 co2) = IfaceFunCo r (go co1) (go co2) + + go (ForAllCo tv k co) = IfaceForAllCo (toIfaceBndr tv) + (toIfaceCoercionX fr' k) + (toIfaceCoercionX fr' co) + where + fr' = fr `delVarSet` tv + + go_prov :: UnivCoProvenance -> IfaceUnivCoProv + go_prov UnsafeCoerceProv = IfaceUnsafeCoerceProv + go_prov (PhantomProv co) = IfacePhantomProv (go co) + go_prov (ProofIrrelProv co) = IfaceProofIrrelProv (go co) + go_prov (PluginProv str) = IfacePluginProv str + +toIfaceTcArgs :: TyCon -> [Type] -> IfaceAppArgs +toIfaceTcArgs = toIfaceTcArgsX emptyVarSet + +toIfaceTcArgsX :: VarSet -> TyCon -> [Type] -> IfaceAppArgs +toIfaceTcArgsX fr tc ty_args = toIfaceAppArgsX fr (tyConKind tc) ty_args + +toIfaceAppTyArgsX :: VarSet -> Type -> [Type] -> IfaceAppArgs +toIfaceAppTyArgsX fr ty ty_args = toIfaceAppArgsX fr (typeKind ty) ty_args + +toIfaceAppArgsX :: VarSet -> Kind -> [Type] -> IfaceAppArgs +-- See Note [Suppressing invisible arguments] in IfaceType +-- We produce a result list of args describing visibility +-- The awkward case is +-- T :: forall k. * -> k +-- And consider +-- T (forall j. blah) * blib +-- Is 'blib' visible? It depends on the visibility flag on j, +-- so we have to substitute for k. Annoying! +toIfaceAppArgsX fr kind ty_args + = go (mkEmptyTCvSubst in_scope) kind ty_args + where + in_scope = mkInScopeSet (tyCoVarsOfTypes ty_args) + + go _ _ [] = IA_Nil + go env ty ts + | Just ty' <- coreView ty + = go env ty' ts + go env (ForAllTy (Bndr tv vis) res) (t:ts) + = IA_Arg t' vis ts' + where + t' = toIfaceTypeX fr t + ts' = go (extendTCvSubst env tv t) res ts + + go env (FunTy { ft_res = res }) (t:ts) -- No type-class args in tycon apps + = IA_Arg (toIfaceTypeX fr t) Required (go env res ts) + + go env ty ts@(t1:ts1) + | not (isEmptyTCvSubst env) + = go (zapTCvSubst env) (substTy env ty) ts + -- See Note [Care with kind instantiation] in Type.hs + + | otherwise + = -- There's a kind error in the type we are trying to print + -- e.g. kind = k, ty_args = [Int] + -- This is probably a compiler bug, so we print a trace and + -- carry on as if it were FunTy. Without the test for + -- isEmptyTCvSubst we'd get an infinite loop (#15473) + WARN( True, ppr kind $$ ppr ty_args ) + IA_Arg (toIfaceTypeX fr t1) Required (go env ty ts1) + +tidyToIfaceType :: TidyEnv -> Type -> IfaceType +tidyToIfaceType env ty = toIfaceType (tidyType env ty) + +tidyToIfaceTcArgs :: TidyEnv -> TyCon -> [Type] -> IfaceAppArgs +tidyToIfaceTcArgs env tc tys = toIfaceTcArgs tc (tidyTypes env tys) + +tidyToIfaceContext :: TidyEnv -> ThetaType -> IfaceContext +tidyToIfaceContext env theta = map (tidyToIfaceType env) theta + +{- +************************************************************************ +* * + Conversion of pattern synonyms +* * +************************************************************************ +-} + +patSynToIfaceDecl :: PatSyn -> IfaceDecl +patSynToIfaceDecl ps + = IfacePatSyn { ifName = getName $ ps + , ifPatMatcher = to_if_pr (patSynMatcher ps) + , ifPatBuilder = fmap to_if_pr (patSynBuilder ps) + , ifPatIsInfix = patSynIsInfix ps + , ifPatUnivBndrs = map toIfaceForAllBndr univ_bndrs' + , ifPatExBndrs = map toIfaceForAllBndr ex_bndrs' + , ifPatProvCtxt = tidyToIfaceContext env2 prov_theta + , ifPatReqCtxt = tidyToIfaceContext env2 req_theta + , ifPatArgs = map (tidyToIfaceType env2) args + , ifPatTy = tidyToIfaceType env2 rhs_ty + , ifFieldLabels = (patSynFieldLabels ps) + } + where + (_univ_tvs, req_theta, _ex_tvs, prov_theta, args, rhs_ty) = patSynSig ps + univ_bndrs = patSynUnivTyVarBinders ps + ex_bndrs = patSynExTyVarBinders ps + (env1, univ_bndrs') = tidyTyCoVarBinders emptyTidyEnv univ_bndrs + (env2, ex_bndrs') = tidyTyCoVarBinders env1 ex_bndrs + to_if_pr (id, needs_dummy) = (idName id, needs_dummy) + +{- +************************************************************************ +* * + Conversion of other things +* * +************************************************************************ +-} + +toIfaceBang :: TidyEnv -> HsImplBang -> IfaceBang +toIfaceBang _ HsLazy = IfNoBang +toIfaceBang _ (HsUnpack Nothing) = IfUnpack +toIfaceBang env (HsUnpack (Just co)) = IfUnpackCo (toIfaceCoercion (tidyCo env co)) +toIfaceBang _ HsStrict = IfStrict + +toIfaceSrcBang :: HsSrcBang -> IfaceSrcBang +toIfaceSrcBang (HsSrcBang _ unpk bang) = IfSrcBang unpk bang + +toIfaceLetBndr :: Id -> IfaceLetBndr +toIfaceLetBndr id = IfLetBndr (occNameFS (getOccName id)) + (toIfaceType (idType id)) + (toIfaceIdInfo (idInfo id)) + (toIfaceJoinInfo (isJoinId_maybe id)) + -- Put into the interface file any IdInfo that CoreTidy.tidyLetBndr + -- has left on the Id. See Note [IdInfo on nested let-bindings] in IfaceSyn + +toIfaceIdDetails :: IdDetails -> IfaceIdDetails +toIfaceIdDetails VanillaId = IfVanillaId +toIfaceIdDetails (DFunId {}) = IfDFunId +toIfaceIdDetails (RecSelId { sel_naughty = n + , sel_tycon = tc }) = + let iface = case tc of + RecSelData ty_con -> Left (toIfaceTyCon ty_con) + RecSelPatSyn pat_syn -> Right (patSynToIfaceDecl pat_syn) + in IfRecSelId iface n + + -- The remaining cases are all "implicit Ids" which don't + -- appear in interface files at all +toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other) + IfVanillaId -- Unexpected; the other + +toIfaceIdInfo :: IdInfo -> IfaceIdInfo +toIfaceIdInfo id_info + = case catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, + inline_hsinfo, unfold_hsinfo, levity_hsinfo] of + [] -> NoInfo + infos -> HasInfo infos + -- NB: strictness and arity must appear in the list before unfolding + -- See TcIface.tcUnfolding + where + ------------ Arity -------------- + arity_info = arityInfo id_info + arity_hsinfo | arity_info == 0 = Nothing + | otherwise = Just (HsArity arity_info) + + ------------ Caf Info -------------- + caf_info = cafInfo id_info + caf_hsinfo = case caf_info of + NoCafRefs -> Just HsNoCafRefs + _other -> Nothing + + ------------ Strictness -------------- + -- No point in explicitly exporting TopSig + sig_info = strictnessInfo id_info + strict_hsinfo | not (isTopSig sig_info) = Just (HsStrictness sig_info) + | otherwise = Nothing + + ------------ Unfolding -------------- + unfold_hsinfo = toIfUnfolding loop_breaker (unfoldingInfo id_info) + loop_breaker = isStrongLoopBreaker (occInfo id_info) + + ------------ Inline prag -------------- + inline_prag = inlinePragInfo id_info + inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing + | otherwise = Just (HsInline inline_prag) + + ------------ Levity polymorphism ---------- + levity_hsinfo | isNeverLevPolyIdInfo id_info = Just HsLevity + | otherwise = Nothing + +toIfaceJoinInfo :: Maybe JoinArity -> IfaceJoinInfo +toIfaceJoinInfo (Just ar) = IfaceJoinPoint ar +toIfaceJoinInfo Nothing = IfaceNotJoinPoint + +-------------------------- +toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem +toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs + , uf_src = src + , uf_guidance = guidance }) + = Just $ HsUnfold lb $ + case src of + InlineStable + -> case guidance of + UnfWhen {ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok } + -> IfInlineRule arity unsat_ok boring_ok if_rhs + _other -> IfCoreUnfold True if_rhs + InlineCompulsory -> IfCompulsory if_rhs + InlineRhs -> IfCoreUnfold False if_rhs + -- Yes, even if guidance is UnfNever, expose the unfolding + -- If we didn't want to expose the unfolding, TidyPgm would + -- have stuck in NoUnfolding. For supercompilation we want + -- to see that unfolding! + where + if_rhs = toIfaceExpr rhs + +toIfUnfolding lb (DFunUnfolding { df_bndrs = bndrs, df_args = args }) + = Just (HsUnfold lb (IfDFunUnfold (map toIfaceBndr bndrs) (map toIfaceExpr args))) + -- No need to serialise the data constructor; + -- we can recover it from the type of the dfun + +toIfUnfolding _ (OtherCon {}) = Nothing + -- The binding site of an Id doesn't have OtherCon, except perhaps + -- where we have called zapUnfolding; and that evald'ness info is + -- not needed by importing modules + +toIfUnfolding _ BootUnfolding = Nothing + -- Can't happen; we only have BootUnfolding for imported binders + +toIfUnfolding _ NoUnfolding = Nothing + +{- +************************************************************************ +* * + Conversion of expressions +* * +************************************************************************ +-} + +toIfaceExpr :: CoreExpr -> IfaceExpr +toIfaceExpr (Var v) = toIfaceVar v +toIfaceExpr (Lit l) = IfaceLit l +toIfaceExpr (Type ty) = IfaceType (toIfaceType ty) +toIfaceExpr (Coercion co) = IfaceCo (toIfaceCoercion co) +toIfaceExpr (Lam x b) = IfaceLam (toIfaceBndr x, toIfaceOneShot x) (toIfaceExpr b) +toIfaceExpr (App f a) = toIfaceApp f [a] +toIfaceExpr (Case s x ty as) + | null as = IfaceECase (toIfaceExpr s) (toIfaceType ty) + | otherwise = IfaceCase (toIfaceExpr s) (getOccFS x) (map toIfaceAlt as) +toIfaceExpr (Let b e) = IfaceLet (toIfaceBind b) (toIfaceExpr e) +toIfaceExpr (Cast e co) = IfaceCast (toIfaceExpr e) (toIfaceCoercion co) +toIfaceExpr (Tick t e) + | Just t' <- toIfaceTickish t = IfaceTick t' (toIfaceExpr e) + | otherwise = toIfaceExpr e + +toIfaceOneShot :: Id -> IfaceOneShot +toIfaceOneShot id | isId id + , OneShotLam <- oneShotInfo (idInfo id) + = IfaceOneShot + | otherwise + = IfaceNoOneShot + +--------------------- +toIfaceTickish :: Tickish Id -> Maybe IfaceTickish +toIfaceTickish (ProfNote cc tick push) = Just (IfaceSCC cc tick push) +toIfaceTickish (HpcTick modl ix) = Just (IfaceHpcTick modl ix) +toIfaceTickish (SourceNote src names) = Just (IfaceSource src names) +toIfaceTickish (Breakpoint {}) = Nothing + -- Ignore breakpoints, since they are relevant only to GHCi, and + -- should not be serialised (#8333) + +--------------------- +toIfaceBind :: Bind Id -> IfaceBinding +toIfaceBind (NonRec b r) = IfaceNonRec (toIfaceLetBndr b) (toIfaceExpr r) +toIfaceBind (Rec prs) = IfaceRec [(toIfaceLetBndr b, toIfaceExpr r) | (b,r) <- prs] + +--------------------- +toIfaceAlt :: (AltCon, [Var], CoreExpr) + -> (IfaceConAlt, [FastString], IfaceExpr) +toIfaceAlt (c,bs,r) = (toIfaceCon c, map getOccFS bs, toIfaceExpr r) + +--------------------- +toIfaceCon :: AltCon -> IfaceConAlt +toIfaceCon (DataAlt dc) = IfaceDataAlt (getName dc) +toIfaceCon (LitAlt l) = IfaceLitAlt l +toIfaceCon DEFAULT = IfaceDefault + +--------------------- +toIfaceApp :: Expr CoreBndr -> [Arg CoreBndr] -> IfaceExpr +toIfaceApp (App f a) as = toIfaceApp f (a:as) +toIfaceApp (Var v) as + = case isDataConWorkId_maybe v of + -- We convert the *worker* for tuples into IfaceTuples + Just dc | saturated + , Just tup_sort <- tyConTuple_maybe tc + -> IfaceTuple tup_sort tup_args + where + val_args = dropWhile isTypeArg as + saturated = val_args `lengthIs` idArity v + tup_args = map toIfaceExpr val_args + tc = dataConTyCon dc + + _ -> mkIfaceApps (toIfaceVar v) as + +toIfaceApp e as = mkIfaceApps (toIfaceExpr e) as + +mkIfaceApps :: IfaceExpr -> [CoreExpr] -> IfaceExpr +mkIfaceApps f as = foldl' (\f a -> IfaceApp f (toIfaceExpr a)) f as + +--------------------- +toIfaceVar :: Id -> IfaceExpr +toIfaceVar v + | isBootUnfolding (idUnfolding v) + = -- See Note [Inlining and hs-boot files] + IfaceApp (IfaceApp (IfaceExt noinlineIdName) + (IfaceType (toIfaceType (idType v)))) + (IfaceExt name) -- don't use mkIfaceApps, or infinite loop + + | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType (idType v)) + -- Foreign calls have special syntax + + | isExternalName name = IfaceExt name + | otherwise = IfaceLcl (getOccFS name) + where name = idName v + + +{- Note [Inlining and hs-boot files] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this example (#10083, #12789): + + ---------- RSR.hs-boot ------------ + module RSR where + data RSR + eqRSR :: RSR -> RSR -> Bool + + ---------- SR.hs ------------ + module SR where + import {-# SOURCE #-} RSR + data SR = MkSR RSR + eqSR (MkSR r1) (MkSR r2) = eqRSR r1 r2 + + ---------- RSR.hs ------------ + module RSR where + import SR + data RSR = MkRSR SR -- deriving( Eq ) + eqRSR (MkRSR s1) (MkRSR s2) = (eqSR s1 s2) + foo x y = not (eqRSR x y) + +When compiling RSR we get this code + + RSR.eqRSR :: RSR -> RSR -> Bool + RSR.eqRSR = \ (ds1 :: RSR.RSR) (ds2 :: RSR.RSR) -> + case ds1 of _ { RSR.MkRSR s1 -> + case ds2 of _ { RSR.MkRSR s2 -> + SR.eqSR s1 s2 }} + + RSR.foo :: RSR -> RSR -> Bool + RSR.foo = \ (x :: RSR) (y :: RSR) -> not (RSR.eqRSR x y) + +Now, when optimising foo: + Inline eqRSR (small, non-rec) + Inline eqSR (small, non-rec) +but the result of inlining eqSR from SR is another call to eqRSR, so +everything repeats. Neither eqSR nor eqRSR are (apparently) loop +breakers. + +Solution: in the unfolding of eqSR in SR.hi, replace `eqRSR` in SR +with `noinline eqRSR`, so that eqRSR doesn't get inlined. This means +that when GHC inlines `eqSR`, it will not also inline `eqRSR`, exactly +as would have been the case if `foo` had been defined in SR.hs (and +marked as a loop-breaker). + +But how do we arrange for this to happen? There are two ingredients: + + 1. When we serialize out unfoldings to IfaceExprs (toIfaceVar), + for every variable reference we see if we are referring to an + 'Id' that came from an hs-boot file. If so, we add a `noinline` + to the reference. + + 2. But how do we know if a reference came from an hs-boot file + or not? We could record this directly in the 'IdInfo', but + actually we deduce this by looking at the unfolding: 'Id's + that come from boot files are given a special unfolding + (upon typechecking) 'BootUnfolding' which say that there is + no unfolding, and the reason is because the 'Id' came from + a boot file. + +Here is a solution that doesn't work: when compiling RSR, +add a NOINLINE pragma to every function exported by the boot-file +for RSR (if it exists). Doing so makes the bootstrapped GHC itself +slower by 8% overall (on #9872a-d, and T1969: the reason +is that these NOINLINE'd functions now can't be profitably inlined +outside of the hs-boot loop. + +-} diff --git a/compiler/iface/ToIface.hs-boot b/compiler/iface/ToIface.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/iface/ToIface.hs-boot @@ -0,0 +1,18 @@ +module ToIface where + +import {-# SOURCE #-} TyCoRep +import {-# SOURCE #-} IfaceType( IfaceType, IfaceTyCon, IfaceForAllBndr + , IfaceCoercion, IfaceTyLit, IfaceAppArgs ) +import Var ( TyCoVarBinder ) +import VarEnv ( TidyEnv ) +import TyCon ( TyCon ) +import VarSet( VarSet ) + +-- For TyCoRep +toIfaceTypeX :: VarSet -> Type -> IfaceType +toIfaceTyLit :: TyLit -> IfaceTyLit +toIfaceForAllBndr :: TyCoVarBinder -> IfaceForAllBndr +toIfaceTyCon :: TyCon -> IfaceTyCon +toIfaceTcArgs :: TyCon -> [Type] -> IfaceAppArgs +toIfaceCoercionX :: VarSet -> Coercion -> IfaceCoercion +tidyToIfaceTcArgs :: TidyEnv -> TyCon -> [Type] -> IfaceAppArgs diff --git a/compiler/main/Annotations.hs b/compiler/main/Annotations.hs new file mode 100644 --- /dev/null +++ b/compiler/main/Annotations.hs @@ -0,0 +1,134 @@ +-- | +-- Support for source code annotation feature of GHC. That is the ANN pragma. +-- +-- (c) The University of Glasgow 2006 +-- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-- +module Annotations ( + -- * Main Annotation data types + Annotation(..), AnnPayload, + AnnTarget(..), CoreAnnTarget, + getAnnTargetName_maybe, + + -- * AnnEnv for collecting and querying Annotations + AnnEnv, + mkAnnEnv, extendAnnEnvList, plusAnnEnv, emptyAnnEnv, + findAnns, findAnnsByTypeRep, + deserializeAnns + ) where + +import GhcPrelude + +import Binary +import Module ( Module ) +import Name +import Outputable +import GHC.Serialized +import UniqFM +import Unique + +import Control.Monad +import Data.Maybe +import Data.Typeable +import Data.Word ( Word8 ) + + +-- | Represents an annotation after it has been sufficiently desugared from +-- it's initial form of 'HsDecls.AnnDecl' +data Annotation = Annotation { + ann_target :: CoreAnnTarget, -- ^ The target of the annotation + ann_value :: AnnPayload + } + +type AnnPayload = Serialized -- ^ The "payload" of an annotation + -- allows recovery of its value at a given type, + -- and can be persisted to an interface file + +-- | An annotation target +data AnnTarget name + = NamedTarget name -- ^ We are annotating something with a name: + -- a type or identifier + | ModuleTarget Module -- ^ We are annotating a particular module + +-- | The kind of annotation target found in the middle end of the compiler +type CoreAnnTarget = AnnTarget Name + +instance Functor AnnTarget where + fmap f (NamedTarget nm) = NamedTarget (f nm) + fmap _ (ModuleTarget mod) = ModuleTarget mod + +-- | Get the 'name' of an annotation target if it exists. +getAnnTargetName_maybe :: AnnTarget name -> Maybe name +getAnnTargetName_maybe (NamedTarget nm) = Just nm +getAnnTargetName_maybe _ = Nothing + +instance Uniquable name => Uniquable (AnnTarget name) where + getUnique (NamedTarget nm) = getUnique nm + getUnique (ModuleTarget mod) = deriveUnique (getUnique mod) 0 + -- deriveUnique prevents OccName uniques clashing with NamedTarget + +instance Outputable name => Outputable (AnnTarget name) where + ppr (NamedTarget nm) = text "Named target" <+> ppr nm + ppr (ModuleTarget mod) = text "Module target" <+> ppr mod + +instance Binary name => Binary (AnnTarget name) where + put_ bh (NamedTarget a) = do + putByte bh 0 + put_ bh a + put_ bh (ModuleTarget a) = do + putByte bh 1 + put_ bh a + get bh = do + h <- getByte bh + case h of + 0 -> liftM NamedTarget $ get bh + _ -> liftM ModuleTarget $ get bh + +instance Outputable Annotation where + ppr ann = ppr (ann_target ann) + +-- | A collection of annotations +-- Can't use a type synonym or we hit bug #2412 due to source import +newtype AnnEnv = MkAnnEnv (UniqFM [AnnPayload]) + +-- | An empty annotation environment. +emptyAnnEnv :: AnnEnv +emptyAnnEnv = MkAnnEnv emptyUFM + +-- | Construct a new annotation environment that contains the list of +-- annotations provided. +mkAnnEnv :: [Annotation] -> AnnEnv +mkAnnEnv = extendAnnEnvList emptyAnnEnv + +-- | Add the given annotation to the environment. +extendAnnEnvList :: AnnEnv -> [Annotation] -> AnnEnv +extendAnnEnvList (MkAnnEnv env) anns + = MkAnnEnv $ addListToUFM_C (++) env $ + map (\ann -> (getUnique (ann_target ann), [ann_value ann])) anns + +-- | Union two annotation environments. +plusAnnEnv :: AnnEnv -> AnnEnv -> AnnEnv +plusAnnEnv (MkAnnEnv env1) (MkAnnEnv env2) = MkAnnEnv $ plusUFM_C (++) env1 env2 + +-- | Find the annotations attached to the given target as 'Typeable' +-- values of your choice. If no deserializer is specified, +-- only transient annotations will be returned. +findAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> CoreAnnTarget -> [a] +findAnns deserialize (MkAnnEnv ann_env) + = (mapMaybe (fromSerialized deserialize)) + . (lookupWithDefaultUFM ann_env []) + +-- | Find the annotations attached to the given target as 'Typeable' +-- values of your choice. If no deserializer is specified, +-- only transient annotations will be returned. +findAnnsByTypeRep :: AnnEnv -> CoreAnnTarget -> TypeRep -> [[Word8]] +findAnnsByTypeRep (MkAnnEnv ann_env) target tyrep + = [ ws | Serialized tyrep' ws <- lookupWithDefaultUFM ann_env [] target + , tyrep' == tyrep ] + +-- | Deserialize all annotations of a given type. This happens lazily, that is +-- no deserialization will take place until the [a] is actually demanded and +-- the [a] can also be empty (the UniqFM is not filtered). +deserializeAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> UniqFM [a] +deserializeAnns deserialize (MkAnnEnv ann_env) + = mapUFM (mapMaybe (fromSerialized deserialize)) ann_env diff --git a/compiler/main/CmdLineParser.hs b/compiler/main/CmdLineParser.hs new file mode 100644 --- /dev/null +++ b/compiler/main/CmdLineParser.hs @@ -0,0 +1,340 @@ +{-# LANGUAGE CPP #-} + +------------------------------------------------------------------------------- +-- +-- | Command-line parser +-- +-- This is an abstract command-line parser used by DynFlags. +-- +-- (c) The University of Glasgow 2005 +-- +------------------------------------------------------------------------------- + +module CmdLineParser + ( + processArgs, OptKind(..), GhcFlagMode(..), + CmdLineP(..), getCmdLineState, putCmdLineState, + Flag(..), defFlag, defGhcFlag, defGhciFlag, defHiddenFlag, + errorsToGhcException, + + Err(..), Warn(..), WarnReason(..), + + EwM, runEwM, addErr, addWarn, addFlagWarn, getArg, getCurLoc, liftEwM, + deprecate + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import Util +import Outputable +import Panic +import Bag +import SrcLoc +import Json + +import Data.Function +import Data.List + +import Control.Monad (liftM, ap) + +-------------------------------------------------------- +-- The Flag and OptKind types +-------------------------------------------------------- + +data Flag m = Flag + { flagName :: String, -- Flag, without the leading "-" + flagOptKind :: OptKind m, -- What to do if we see it + flagGhcMode :: GhcFlagMode -- Which modes this flag affects + } + +defFlag :: String -> OptKind m -> Flag m +defFlag name optKind = Flag name optKind AllModes + +defGhcFlag :: String -> OptKind m -> Flag m +defGhcFlag name optKind = Flag name optKind OnlyGhc + +defGhciFlag :: String -> OptKind m -> Flag m +defGhciFlag name optKind = Flag name optKind OnlyGhci + +defHiddenFlag :: String -> OptKind m -> Flag m +defHiddenFlag name optKind = Flag name optKind HiddenFlag + +-- | GHC flag modes describing when a flag has an effect. +data GhcFlagMode + = OnlyGhc -- ^ The flag only affects the non-interactive GHC + | OnlyGhci -- ^ The flag only affects the interactive GHC + | AllModes -- ^ The flag affects multiple ghc modes + | HiddenFlag -- ^ This flag should not be seen in cli completion + +data OptKind m -- Suppose the flag is -f + = NoArg (EwM m ()) -- -f all by itself + | HasArg (String -> EwM m ()) -- -farg or -f arg + | SepArg (String -> EwM m ()) -- -f arg + | Prefix (String -> EwM m ()) -- -farg + | OptPrefix (String -> EwM m ()) -- -f or -farg (i.e. the arg is optional) + | OptIntSuffix (Maybe Int -> EwM m ()) -- -f or -f=n; pass n to fn + | IntSuffix (Int -> EwM m ()) -- -f or -f=n; pass n to fn + | FloatSuffix (Float -> EwM m ()) -- -f or -f=n; pass n to fn + | PassFlag (String -> EwM m ()) -- -f; pass "-f" fn + | AnySuffix (String -> EwM m ()) -- -f or -farg; pass entire "-farg" to fn + + +-------------------------------------------------------- +-- The EwM monad +-------------------------------------------------------- + +-- | Used when filtering warnings: if a reason is given +-- it can be filtered out when displaying. +data WarnReason + = NoReason + | ReasonDeprecatedFlag + | ReasonUnrecognisedFlag + deriving (Eq, Show) + +instance Outputable WarnReason where + ppr = text . show + +instance ToJson WarnReason where + json NoReason = JSNull + json reason = JSString $ show reason + +-- | A command-line error message +newtype Err = Err { errMsg :: Located String } + +-- | A command-line warning message and the reason it arose +data Warn = Warn + { warnReason :: WarnReason, + warnMsg :: Located String + } + +type Errs = Bag Err +type Warns = Bag Warn + +-- EwM ("errors and warnings monad") is a monad +-- transformer for m that adds an (err, warn) state +newtype EwM m a = EwM { unEwM :: Located String -- Current parse arg + -> Errs -> Warns + -> m (Errs, Warns, a) } + +instance Monad m => Functor (EwM m) where + fmap = liftM + +instance Monad m => Applicative (EwM m) where + pure v = EwM (\_ e w -> return (e, w, v)) + (<*>) = ap + +instance Monad m => Monad (EwM m) where + (EwM f) >>= k = EwM (\l e w -> do (e', w', r) <- f l e w + unEwM (k r) l e' w') + +runEwM :: EwM m a -> m (Errs, Warns, a) +runEwM action = unEwM action (panic "processArgs: no arg yet") emptyBag emptyBag + +setArg :: Located String -> EwM m () -> EwM m () +setArg l (EwM f) = EwM (\_ es ws -> f l es ws) + +addErr :: Monad m => String -> EwM m () +addErr e = EwM (\(L loc _) es ws -> return (es `snocBag` Err (L loc e), ws, ())) + +addWarn :: Monad m => String -> EwM m () +addWarn = addFlagWarn NoReason + +addFlagWarn :: Monad m => WarnReason -> String -> EwM m () +addFlagWarn reason msg = EwM $ + (\(L loc _) es ws -> return (es, ws `snocBag` Warn reason (L loc msg), ())) + +deprecate :: Monad m => String -> EwM m () +deprecate s = do + arg <- getArg + addFlagWarn ReasonDeprecatedFlag (arg ++ " is deprecated: " ++ s) + +getArg :: Monad m => EwM m String +getArg = EwM (\(L _ arg) es ws -> return (es, ws, arg)) + +getCurLoc :: Monad m => EwM m SrcSpan +getCurLoc = EwM (\(L loc _) es ws -> return (es, ws, loc)) + +liftEwM :: Monad m => m a -> EwM m a +liftEwM action = EwM (\_ es ws -> do { r <- action; return (es, ws, r) }) + + +-------------------------------------------------------- +-- A state monad for use in the command-line parser +-------------------------------------------------------- + +-- (CmdLineP s) typically instantiates the 'm' in (EwM m) and (OptKind m) +newtype CmdLineP s a = CmdLineP { runCmdLine :: s -> (a, s) } + +instance Functor (CmdLineP s) where + fmap = liftM + +instance Applicative (CmdLineP s) where + pure a = CmdLineP $ \s -> (a, s) + (<*>) = ap + +instance Monad (CmdLineP s) where + m >>= k = CmdLineP $ \s -> + let (a, s') = runCmdLine m s + in runCmdLine (k a) s' + + +getCmdLineState :: CmdLineP s s +getCmdLineState = CmdLineP $ \s -> (s,s) +putCmdLineState :: s -> CmdLineP s () +putCmdLineState s = CmdLineP $ \_ -> ((),s) + + +-------------------------------------------------------- +-- Processing arguments +-------------------------------------------------------- + +processArgs :: Monad m + => [Flag m] -- cmdline parser spec + -> [Located String] -- args + -> m ( [Located String], -- spare args + [Err], -- errors + [Warn] ) -- warnings +processArgs spec args = do + (errs, warns, spare) <- runEwM action + return (spare, bagToList errs, bagToList warns) + where + action = process args [] + + -- process :: [Located String] -> [Located String] -> EwM m [Located String] + process [] spare = return (reverse spare) + + process (locArg@(L _ ('-' : arg)) : args) spare = + case findArg spec arg of + Just (rest, opt_kind) -> + case processOneArg opt_kind rest arg args of + Left err -> + let b = process args spare + in (setArg locArg $ addErr err) >> b + + Right (action,rest) -> + let b = process rest spare + in (setArg locArg $ action) >> b + + Nothing -> process args (locArg : spare) + + process (arg : args) spare = process args (arg : spare) + + +processOneArg :: OptKind m -> String -> String -> [Located String] + -> Either String (EwM m (), [Located String]) +processOneArg opt_kind rest arg args + = let dash_arg = '-' : arg + rest_no_eq = dropEq rest + in case opt_kind of + NoArg a -> ASSERT(null rest) Right (a, args) + + HasArg f | notNull rest_no_eq -> Right (f rest_no_eq, args) + | otherwise -> case args of + [] -> missingArgErr dash_arg + (L _ arg1:args1) -> Right (f arg1, args1) + + -- See #9776 + SepArg f -> case args of + [] -> missingArgErr dash_arg + (L _ arg1:args1) -> Right (f arg1, args1) + + -- See #12625 + Prefix f | notNull rest_no_eq -> Right (f rest_no_eq, args) + | otherwise -> missingArgErr dash_arg + + PassFlag f | notNull rest -> unknownFlagErr dash_arg + | otherwise -> Right (f dash_arg, args) + + OptIntSuffix f | null rest -> Right (f Nothing, args) + | Just n <- parseInt rest_no_eq -> Right (f (Just n), args) + | otherwise -> Left ("malformed integer argument in " ++ dash_arg) + + IntSuffix f | Just n <- parseInt rest_no_eq -> Right (f n, args) + | otherwise -> Left ("malformed integer argument in " ++ dash_arg) + + FloatSuffix f | Just n <- parseFloat rest_no_eq -> Right (f n, args) + | otherwise -> Left ("malformed float argument in " ++ dash_arg) + + OptPrefix f -> Right (f rest_no_eq, args) + AnySuffix f -> Right (f dash_arg, args) + +findArg :: [Flag m] -> String -> Maybe (String, OptKind m) +findArg spec arg = + case sortBy (compare `on` (length . fst)) -- prefer longest matching flag + [ (removeSpaces rest, optKind) + | flag <- spec, + let optKind = flagOptKind flag, + Just rest <- [stripPrefix (flagName flag) arg], + arg_ok optKind rest arg ] + of + [] -> Nothing + (one:_) -> Just one + +arg_ok :: OptKind t -> [Char] -> String -> Bool +arg_ok (NoArg _) rest _ = null rest +arg_ok (HasArg _) _ _ = True +arg_ok (SepArg _) rest _ = null rest +arg_ok (Prefix _) _ _ = True -- Missing argument checked for in processOneArg t + -- to improve error message (#12625) +arg_ok (OptIntSuffix _) _ _ = True +arg_ok (IntSuffix _) _ _ = True +arg_ok (FloatSuffix _) _ _ = True +arg_ok (OptPrefix _) _ _ = True +arg_ok (PassFlag _) rest _ = null rest +arg_ok (AnySuffix _) _ _ = True + +-- | Parse an Int +-- +-- Looks for "433" or "=342", with no trailing gubbins +-- * n or =n => Just n +-- * gibberish => Nothing +parseInt :: String -> Maybe Int +parseInt s = case reads s of + ((n,""):_) -> Just n + _ -> Nothing + +parseFloat :: String -> Maybe Float +parseFloat s = case reads s of + ((n,""):_) -> Just n + _ -> Nothing + +-- | Discards a leading equals sign +dropEq :: String -> String +dropEq ('=' : s) = s +dropEq s = s + +unknownFlagErr :: String -> Either String a +unknownFlagErr f = Left ("unrecognised flag: " ++ f) + +missingArgErr :: String -> Either String a +missingArgErr f = Left ("missing argument for flag: " ++ f) + +-------------------------------------------------------- +-- Utils +-------------------------------------------------------- + + +-- See Note [Handling errors when parsing flags] +errorsToGhcException :: [(String, -- Location + String)] -- Error + -> GhcException +errorsToGhcException errs = + UsageError $ intercalate "\n" $ [ l ++ ": " ++ e | (l, e) <- errs ] + +{- Note [Handling errors when parsing commandline flags] + +Parsing of static and mode flags happens before any session is started, i.e., +before the first call to 'GHC.withGhc'. Therefore, to report errors for +invalid usage of these two types of flags, we can not call any function that +needs DynFlags, as there are no DynFlags available yet (unsafeGlobalDynFlags +is not set either). So we always print "on the commandline" as the location, +which is true except for Api users, which is probably ok. + +When reporting errors for invalid usage of dynamic flags we /can/ make use of +DynFlags, and we do so explicitly in DynFlags.parseDynamicFlagsFull. + +Before, we called unsafeGlobalDynFlags when an invalid (combination of) +flag(s) was given on the commandline, resulting in panics (#9963). +-} diff --git a/compiler/main/Constants.hs b/compiler/main/Constants.hs new file mode 100644 --- /dev/null +++ b/compiler/main/Constants.hs @@ -0,0 +1,46 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[Constants]{Info about this compilation} +-} + +module Constants (module Constants) where + +import GhcPrelude + +import Config + +hiVersion :: Integer +hiVersion = read (cProjectVersionInt ++ cProjectPatchLevel) :: Integer + +-- All pretty arbitrary: + +mAX_TUPLE_SIZE :: Int +mAX_TUPLE_SIZE = 62 -- Should really match the number + -- of decls in Data.Tuple + +mAX_CTUPLE_SIZE :: Int -- Constraint tuples +mAX_CTUPLE_SIZE = 62 -- Should match the number of decls in GHC.Classes + +mAX_SUM_SIZE :: Int +mAX_SUM_SIZE = 62 + +-- | Default maximum depth for both class instance search and type family +-- reduction. See also #5395. +mAX_REDUCTION_DEPTH :: Int +mAX_REDUCTION_DEPTH = 200 + +-- | Default maximum constraint-solver iterations +-- Typically there should be very few +mAX_SOLVER_ITERATIONS :: Int +mAX_SOLVER_ITERATIONS = 4 + +wORD64_SIZE :: Int +wORD64_SIZE = 8 + +-- Size of float in bytes. +fLOAT_SIZE :: Int +fLOAT_SIZE = 4 + +tARGET_MAX_CHAR :: Int +tARGET_MAX_CHAR = 0x10ffff diff --git a/compiler/main/DriverPhases.hs b/compiler/main/DriverPhases.hs new file mode 100644 --- /dev/null +++ b/compiler/main/DriverPhases.hs @@ -0,0 +1,372 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- $Id: DriverPhases.hs,v 1.38 2005/05/17 11:01:59 simonmar Exp $ +-- +-- GHC Driver +-- +-- (c) The University of Glasgow 2002 +-- +----------------------------------------------------------------------------- + +module DriverPhases ( + HscSource(..), isHsBootOrSig, isHsigFile, hscSourceString, + Phase(..), + happensBefore, eqPhase, anyHsc, isStopLn, + startPhase, + phaseInputExt, + + isHaskellishSuffix, + isHaskellSrcSuffix, + isBackpackishSuffix, + isObjectSuffix, + isCishSuffix, + isDynLibSuffix, + isHaskellUserSrcSuffix, + isHaskellSigSuffix, + isSourceSuffix, + + isHaskellishTarget, + + isHaskellishFilename, + isHaskellSrcFilename, + isHaskellSigFilename, + isObjectFilename, + isCishFilename, + isDynLibFilename, + isHaskellUserSrcFilename, + isSourceFilename + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import {-# SOURCE #-} DynFlags +import Outputable +import Platform +import System.FilePath +import Binary +import Util + +----------------------------------------------------------------------------- +-- Phases + +{- + Phase of the | Suffix saying | Flag saying | (suffix of) + compilation system | ``start here''| ``stop after''| output file + + literate pre-processor | .lhs | - | - + C pre-processor (opt.) | - | -E | - + Haskell compiler | .hs | -C, -S | .hc, .s + C compiler (opt.) | .hc or .c | -S | .s + assembler | .s or .S | -c | .o + linker | other | - | a.out +-} + +-- Note [HscSource types] +-- ~~~~~~~~~~~~~~~~~~~~~~ +-- There are three types of source file for Haskell code: +-- +-- * HsSrcFile is an ordinary hs file which contains code, +-- +-- * HsBootFile is an hs-boot file, which is used to break +-- recursive module imports (there will always be an +-- HsSrcFile associated with it), and +-- +-- * HsigFile is an hsig file, which contains only type +-- signatures and is used to specify signatures for +-- modules. +-- +-- Syntactically, hs-boot files and hsig files are quite similar: they +-- only include type signatures and must be associated with an +-- actual HsSrcFile. isHsBootOrSig allows us to abstract over code +-- which is indifferent to which. However, there are some important +-- differences, mostly owing to the fact that hsigs are proper +-- modules (you `import Sig` directly) whereas HsBootFiles are +-- temporary placeholders (you `import {-# SOURCE #-} Mod). +-- When we finish compiling the true implementation of an hs-boot, +-- we replace the HomeModInfo with the real HsSrcFile. An HsigFile, on the +-- other hand, is never replaced (in particular, we *cannot* use the +-- HomeModInfo of the original HsSrcFile backing the signature, since it +-- will export too many symbols.) +-- +-- Additionally, while HsSrcFile is the only Haskell file +-- which has *code*, we do generate .o files for HsigFile, because +-- this is how the recompilation checker figures out if a file +-- needs to be recompiled. These are fake object files which +-- should NOT be linked against. + +data HscSource + = HsSrcFile | HsBootFile | HsigFile + deriving( Eq, Ord, Show ) + -- Ord needed for the finite maps we build in CompManager + +instance Binary HscSource where + put_ bh HsSrcFile = putByte bh 0 + put_ bh HsBootFile = putByte bh 1 + put_ bh HsigFile = putByte bh 2 + get bh = do + h <- getByte bh + case h of + 0 -> return HsSrcFile + 1 -> return HsBootFile + _ -> return HsigFile + +hscSourceString :: HscSource -> String +hscSourceString HsSrcFile = "" +hscSourceString HsBootFile = "[boot]" +hscSourceString HsigFile = "[sig]" + +-- See Note [isHsBootOrSig] +isHsBootOrSig :: HscSource -> Bool +isHsBootOrSig HsBootFile = True +isHsBootOrSig HsigFile = True +isHsBootOrSig _ = False + +isHsigFile :: HscSource -> Bool +isHsigFile HsigFile = True +isHsigFile _ = False + +data Phase + = Unlit HscSource + | Cpp HscSource + | HsPp HscSource + | Hsc HscSource + | Ccxx -- Compile C++ + | Cc -- Compile C + | Cobjc -- Compile Objective-C + | Cobjcxx -- Compile Objective-C++ + | HCc -- Haskellised C (as opposed to vanilla C) compilation + | As Bool -- Assembler for regular assembly files (Bool: with-cpp) + | LlvmOpt -- Run LLVM opt tool over llvm assembly + | LlvmLlc -- LLVM bitcode to native assembly + | LlvmMangle -- Fix up TNTC by processing assembly produced by LLVM + | CmmCpp -- pre-process Cmm source + | Cmm -- parse & compile Cmm code + | MergeForeign -- merge in the foreign object files + + -- The final phase is a pseudo-phase that tells the pipeline to stop. + -- There is no runPhase case for it. + | StopLn -- Stop, but linking will follow, so generate .o file + deriving (Eq, Show) + +instance Outputable Phase where + ppr p = text (show p) + +anyHsc :: Phase +anyHsc = Hsc (panic "anyHsc") + +isStopLn :: Phase -> Bool +isStopLn StopLn = True +isStopLn _ = False + +eqPhase :: Phase -> Phase -> Bool +-- Equality of constructors, ignoring the HscSource field +-- NB: the HscSource field can be 'bot'; see anyHsc above +eqPhase (Unlit _) (Unlit _) = True +eqPhase (Cpp _) (Cpp _) = True +eqPhase (HsPp _) (HsPp _) = True +eqPhase (Hsc _) (Hsc _) = True +eqPhase Cc Cc = True +eqPhase Cobjc Cobjc = True +eqPhase HCc HCc = True +eqPhase (As x) (As y) = x == y +eqPhase LlvmOpt LlvmOpt = True +eqPhase LlvmLlc LlvmLlc = True +eqPhase LlvmMangle LlvmMangle = True +eqPhase CmmCpp CmmCpp = True +eqPhase Cmm Cmm = True +eqPhase MergeForeign MergeForeign = True +eqPhase StopLn StopLn = True +eqPhase Ccxx Ccxx = True +eqPhase Cobjcxx Cobjcxx = True +eqPhase _ _ = False + +{- Note [Partial ordering on phases] + +We want to know which phases will occur before which others. This is used for +sanity checking, to ensure that the pipeline will stop at some point (see +DriverPipeline.runPipeline). + +A < B iff A occurs before B in a normal compilation pipeline. + +There is explicitly not a total ordering on phases, because in registerised +builds, the phase `HsC` doesn't happen before nor after any other phase. + +Although we check that a normal user doesn't set the stop_phase to HsC through +use of -C with registerised builds (in Main.checkOptions), it is still +possible for a ghc-api user to do so. So be careful when using the function +happensBefore, and don't think that `not (a <= b)` implies `b < a`. +-} +happensBefore :: DynFlags -> Phase -> Phase -> Bool +happensBefore dflags p1 p2 = p1 `happensBefore'` p2 + where StopLn `happensBefore'` _ = False + x `happensBefore'` y = after_x `eqPhase` y + || after_x `happensBefore'` y + where after_x = nextPhase dflags x + +nextPhase :: DynFlags -> Phase -> Phase +nextPhase dflags p + -- A conservative approximation to the next phase, used in happensBefore + = case p of + Unlit sf -> Cpp sf + Cpp sf -> HsPp sf + HsPp sf -> Hsc sf + Hsc _ -> maybeHCc + LlvmOpt -> LlvmLlc + LlvmLlc -> LlvmMangle + LlvmMangle -> As False + As _ -> MergeForeign + Ccxx -> As False + Cc -> As False + Cobjc -> As False + Cobjcxx -> As False + CmmCpp -> Cmm + Cmm -> maybeHCc + HCc -> As False + MergeForeign -> StopLn + StopLn -> panic "nextPhase: nothing after StopLn" + where maybeHCc = if platformUnregisterised (targetPlatform dflags) + then HCc + else As False + +-- the first compilation phase for a given file is determined +-- by its suffix. +startPhase :: String -> Phase +startPhase "lhs" = Unlit HsSrcFile +startPhase "lhs-boot" = Unlit HsBootFile +startPhase "lhsig" = Unlit HsigFile +startPhase "hs" = Cpp HsSrcFile +startPhase "hs-boot" = Cpp HsBootFile +startPhase "hsig" = Cpp HsigFile +startPhase "hscpp" = HsPp HsSrcFile +startPhase "hspp" = Hsc HsSrcFile +startPhase "hc" = HCc +startPhase "c" = Cc +startPhase "cpp" = Ccxx +startPhase "C" = Cc +startPhase "m" = Cobjc +startPhase "M" = Cobjcxx +startPhase "mm" = Cobjcxx +startPhase "cc" = Ccxx +startPhase "cxx" = Ccxx +startPhase "s" = As False +startPhase "S" = As True +startPhase "ll" = LlvmOpt +startPhase "bc" = LlvmLlc +startPhase "lm_s" = LlvmMangle +startPhase "o" = StopLn +startPhase "cmm" = CmmCpp +startPhase "cmmcpp" = Cmm +startPhase _ = StopLn -- all unknown file types + +-- This is used to determine the extension for the output from the +-- current phase (if it generates a new file). The extension depends +-- on the next phase in the pipeline. +phaseInputExt :: Phase -> String +phaseInputExt (Unlit HsSrcFile) = "lhs" +phaseInputExt (Unlit HsBootFile) = "lhs-boot" +phaseInputExt (Unlit HsigFile) = "lhsig" +phaseInputExt (Cpp _) = "lpp" -- intermediate only +phaseInputExt (HsPp _) = "hscpp" -- intermediate only +phaseInputExt (Hsc _) = "hspp" -- intermediate only + -- NB: as things stand, phaseInputExt (Hsc x) must not evaluate x + -- because runPipeline uses the StopBefore phase to pick the + -- output filename. That could be fixed, but watch out. +phaseInputExt HCc = "hc" +phaseInputExt Ccxx = "cpp" +phaseInputExt Cobjc = "m" +phaseInputExt Cobjcxx = "mm" +phaseInputExt Cc = "c" +phaseInputExt (As True) = "S" +phaseInputExt (As False) = "s" +phaseInputExt LlvmOpt = "ll" +phaseInputExt LlvmLlc = "bc" +phaseInputExt LlvmMangle = "lm_s" +phaseInputExt CmmCpp = "cmmcpp" +phaseInputExt Cmm = "cmm" +phaseInputExt MergeForeign = "o" +phaseInputExt StopLn = "o" + +haskellish_src_suffixes, backpackish_suffixes, haskellish_suffixes, cish_suffixes, + haskellish_user_src_suffixes, haskellish_sig_suffixes + :: [String] +-- When a file with an extension in the haskellish_src_suffixes group is +-- loaded in --make mode, its imports will be loaded too. +haskellish_src_suffixes = haskellish_user_src_suffixes ++ + [ "hspp", "hscpp" ] +haskellish_suffixes = haskellish_src_suffixes ++ + [ "hc", "cmm", "cmmcpp" ] +cish_suffixes = [ "c", "cpp", "C", "cc", "cxx", "s", "S", "ll", "bc", "lm_s", "m", "M", "mm" ] + +-- Will not be deleted as temp files: +haskellish_user_src_suffixes = + haskellish_sig_suffixes ++ [ "hs", "lhs", "hs-boot", "lhs-boot" ] +haskellish_sig_suffixes = [ "hsig", "lhsig" ] +backpackish_suffixes = [ "bkp" ] + +objish_suffixes :: Platform -> [String] +-- Use the appropriate suffix for the system on which +-- the GHC-compiled code will run +objish_suffixes platform = case platformOS platform of + OSMinGW32 -> [ "o", "O", "obj", "OBJ" ] + _ -> [ "o" ] + +dynlib_suffixes :: Platform -> [String] +dynlib_suffixes platform = case platformOS platform of + OSMinGW32 -> ["dll", "DLL"] + OSDarwin -> ["dylib", "so"] + _ -> ["so"] + +isHaskellishSuffix, isBackpackishSuffix, isHaskellSrcSuffix, isCishSuffix, + isHaskellUserSrcSuffix, isHaskellSigSuffix + :: String -> Bool +isHaskellishSuffix s = s `elem` haskellish_suffixes +isBackpackishSuffix s = s `elem` backpackish_suffixes +isHaskellSigSuffix s = s `elem` haskellish_sig_suffixes +isHaskellSrcSuffix s = s `elem` haskellish_src_suffixes +isCishSuffix s = s `elem` cish_suffixes +isHaskellUserSrcSuffix s = s `elem` haskellish_user_src_suffixes + +isObjectSuffix, isDynLibSuffix :: Platform -> String -> Bool +isObjectSuffix platform s = s `elem` objish_suffixes platform +isDynLibSuffix platform s = s `elem` dynlib_suffixes platform + +isSourceSuffix :: String -> Bool +isSourceSuffix suff = isHaskellishSuffix suff + || isCishSuffix suff + || isBackpackishSuffix suff + +-- | When we are given files (modified by -x arguments) we need +-- to determine if they are Haskellish or not to figure out +-- how we should try to compile it. The rules are: +-- +-- 1. If no -x flag was specified, we check to see if +-- the file looks like a module name, has no extension, +-- or has a Haskell source extension. +-- +-- 2. If an -x flag was specified, we just make sure the +-- specified suffix is a Haskell one. +isHaskellishTarget :: (String, Maybe Phase) -> Bool +isHaskellishTarget (f,Nothing) = + looksLikeModuleName f || isHaskellSrcFilename f || not (hasExtension f) +isHaskellishTarget (_,Just phase) = + phase `notElem` [ As True, As False, Cc, Cobjc, Cobjcxx, CmmCpp, Cmm + , StopLn] + +isHaskellishFilename, isHaskellSrcFilename, isCishFilename, + isHaskellUserSrcFilename, isSourceFilename, isHaskellSigFilename + :: FilePath -> Bool +-- takeExtension return .foo, so we drop 1 to get rid of the . +isHaskellishFilename f = isHaskellishSuffix (drop 1 $ takeExtension f) +isHaskellSrcFilename f = isHaskellSrcSuffix (drop 1 $ takeExtension f) +isCishFilename f = isCishSuffix (drop 1 $ takeExtension f) +isHaskellUserSrcFilename f = isHaskellUserSrcSuffix (drop 1 $ takeExtension f) +isSourceFilename f = isSourceSuffix (drop 1 $ takeExtension f) +isHaskellSigFilename f = isHaskellSigSuffix (drop 1 $ takeExtension f) + +isObjectFilename, isDynLibFilename :: Platform -> FilePath -> Bool +isObjectFilename platform f = isObjectSuffix platform (drop 1 $ takeExtension f) +isDynLibFilename platform f = isDynLibSuffix platform (drop 1 $ takeExtension f) + diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs new file mode 100644 --- /dev/null +++ b/compiler/main/DynFlags.hs @@ -0,0 +1,5939 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} + +------------------------------------------------------------------------------- +-- +-- | Dynamic flags +-- +-- Most flags are dynamic flags, which means they can change from compilation +-- to compilation using @OPTIONS_GHC@ pragmas, and in a multi-session GHC each +-- session can be using different dynamic flags. Dynamic flags can also be set +-- at the prompt in GHCi. +-- +-- (c) The University of Glasgow 2005 +-- +------------------------------------------------------------------------------- + +{-# OPTIONS_GHC -fno-cse #-} +-- -fno-cse is needed for GLOBAL_VAR's to behave properly + +module DynFlags ( + -- * Dynamic flags and associated configuration types + DumpFlag(..), + GeneralFlag(..), + WarningFlag(..), WarnReason(..), + Language(..), + PlatformConstants(..), + FatalMessager, LogAction, FlushOut(..), FlushErr(..), + ProfAuto(..), + glasgowExtsFlags, + warningGroups, warningHierarchies, + hasPprDebug, hasNoDebugOutput, hasNoStateHack, hasNoOptCoercion, + dopt, dopt_set, dopt_unset, + gopt, gopt_set, gopt_unset, setGeneralFlag', unSetGeneralFlag', + wopt, wopt_set, wopt_unset, + wopt_fatal, wopt_set_fatal, wopt_unset_fatal, + xopt, xopt_set, xopt_unset, + xopt_set_unlessExplSpec, + lang_set, + useUnicodeSyntax, + useStarIsType, + whenGeneratingDynamicToo, ifGeneratingDynamicToo, + whenCannotGenerateDynamicToo, + dynamicTooMkDynamicDynFlags, + DynFlags(..), + FlagSpec(..), + HasDynFlags(..), ContainsDynFlags(..), + RtsOptsEnabled(..), + HscTarget(..), isObjectTarget, defaultObjectTarget, + targetRetainsAllBindings, + GhcMode(..), isOneShot, + GhcLink(..), isNoLink, + PackageFlag(..), PackageArg(..), ModRenaming(..), + packageFlagsChanged, + IgnorePackageFlag(..), TrustFlag(..), + PackageDBFlag(..), PkgConfRef(..), + Option(..), showOpt, + DynLibLoader(..), + fFlags, fLangFlags, xFlags, + wWarningFlags, + dynFlagDependencies, + tablesNextToCode, mkTablesNextToCode, + makeDynFlagsConsistent, + shouldUseColor, + shouldUseHexWordLiterals, + positionIndependent, + optimisationFlags, + + Way(..), mkBuildTag, wayRTSOnly, addWay', updateWays, + wayGeneralFlags, wayUnsetGeneralFlags, + + thisPackage, thisComponentId, thisUnitIdInsts, + + -- ** Log output + putLogMsg, + + -- ** Safe Haskell + SafeHaskellMode(..), + safeHaskellOn, safeHaskellModeEnabled, + safeImportsOn, safeLanguageOn, safeInferOn, + packageTrustOn, + safeDirectImpsReq, safeImplicitImpsReq, + unsafeFlags, unsafeFlagsForInfer, + + -- ** LLVM Targets + LlvmTarget(..), LlvmTargets, LlvmPasses, LlvmConfig, + + -- ** System tool settings and locations + Settings(..), + targetPlatform, programName, projectVersion, + ghcUsagePath, ghciUsagePath, topDir, tmpDir, rawSettings, + versionedAppDir, + extraGccViaCFlags, systemPackageConfig, + pgm_L, pgm_P, pgm_F, pgm_c, pgm_a, pgm_l, pgm_dll, pgm_T, + pgm_windres, pgm_libtool, pgm_ar, pgm_ranlib, pgm_lo, pgm_lc, + pgm_lcc, pgm_i, opt_L, opt_P, opt_F, opt_c, opt_a, opt_l, opt_i, + opt_P_signature, + opt_windres, opt_lo, opt_lc, opt_lcc, + + -- ** Manipulating DynFlags + addPluginModuleName, + defaultDynFlags, -- Settings -> DynFlags + defaultWays, + interpWays, + interpreterProfiled, interpreterDynamic, + initDynFlags, -- DynFlags -> IO DynFlags + defaultFatalMessager, + defaultLogAction, + defaultLogActionHPrintDoc, + defaultLogActionHPutStrDoc, + defaultFlushOut, + defaultFlushErr, + + getOpts, -- DynFlags -> (DynFlags -> [a]) -> [a] + getVerbFlags, + updOptLevel, + setTmpDir, + setUnitId, + interpretPackageEnv, + canonicalizeHomeModule, + canonicalizeModuleIfHome, + + -- ** Parsing DynFlags + parseDynamicFlagsCmdLine, + parseDynamicFilePragma, + parseDynamicFlagsFull, + + -- ** Available DynFlags + allNonDeprecatedFlags, + flagsAll, + flagsDynamic, + flagsPackage, + flagsForCompletion, + + supportedLanguagesAndExtensions, + languageExtensions, + + -- ** DynFlags C compiler options + picCCOpts, picPOpts, + + -- * Compiler configuration suitable for display to the user + compilerInfo, + + rtsIsProfiled, + dynamicGhc, + +#include "GHCConstantsHaskellExports.hs" + bLOCK_SIZE_W, + wORD_SIZE_IN_BITS, + tAG_MASK, + mAX_PTR_TAG, + tARGET_MIN_INT, tARGET_MAX_INT, tARGET_MAX_WORD, + + unsafeGlobalDynFlags, setUnsafeGlobalDynFlags, + + -- * SSE and AVX + isSseEnabled, + isSse2Enabled, + isSse4_2Enabled, + isBmiEnabled, + isBmi2Enabled, + isAvxEnabled, + isAvx2Enabled, + isAvx512cdEnabled, + isAvx512erEnabled, + isAvx512fEnabled, + isAvx512pfEnabled, + + -- * Linker/compiler information + LinkerInfo(..), + CompilerInfo(..), + + -- * File cleanup + FilesToClean(..), emptyFilesToClean, + + -- * Include specifications + IncludeSpecs(..), addGlobalInclude, addQuoteInclude, flattenIncludes, + + + -- * Make use of the Cmm CFG + CfgWeights(..), backendMaintainsCfg + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import Platform +import PlatformConstants +import Module +import PackageConfig +import {-# SOURCE #-} Plugins +import {-# SOURCE #-} Hooks +import {-# SOURCE #-} PrelNames ( mAIN ) +import {-# SOURCE #-} Packages (PackageState, emptyPackageState) +import DriverPhases ( Phase(..), phaseInputExt ) +import Config +import CmdLineParser hiding (WarnReason(..)) +import qualified CmdLineParser as Cmd +import Constants +import Panic +import qualified PprColour as Col +import Util +import Maybes +import MonadUtils +import qualified Pretty +import SrcLoc +import BasicTypes ( IntWithInf, treatZeroAsInf ) +import FastString +import Fingerprint +import Outputable +import Foreign.C ( CInt(..) ) +import System.IO.Unsafe ( unsafeDupablePerformIO ) +import {-# SOURCE #-} ErrUtils ( Severity(..), MsgDoc, mkLocMessageAnn + , getCaretDiagnostic ) +import Json +import SysTools.Terminal ( stderrSupportsAnsiColors ) +import SysTools.BaseDir ( expandToolDir, expandTopDir ) + +import System.IO.Unsafe ( unsafePerformIO ) +import Data.IORef +import Control.Arrow ((&&&)) +import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.Writer +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Except +import Control.Exception (throwIO) + +import Data.Ord +import Data.Bits +import Data.Char +import Data.Int +import Data.List +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Word +import System.FilePath +import System.Directory +import System.Environment (getEnv, lookupEnv) +import System.IO +import System.IO.Error +import Text.ParserCombinators.ReadP hiding (char) +import Text.ParserCombinators.ReadP as R + +import EnumSet (EnumSet) +import qualified EnumSet + +import GHC.Foreign (withCString, peekCString) +import qualified GHC.LanguageExtensions as LangExt + +#if defined(GHCI) +import Foreign (Ptr) -- needed for 2nd stage +#endif + +-- Note [Updating flag description in the User's Guide] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- If you modify anything in this file please make sure that your changes are +-- described in the User's Guide. Please update the flag description in the +-- users guide (docs/users_guide) whenever you add or change a flag. + +-- Note [Supporting CLI completion] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- The command line interface completion (in for example bash) is an easy way +-- for the developer to learn what flags are available from GHC. +-- GHC helps by separating which flags are available when compiling with GHC, +-- and which flags are available when using GHCi. +-- A flag is assumed to either work in both these modes, or only in one of them. +-- When adding or changing a flag, please consider for which mode the flag will +-- have effect, and annotate it accordingly. For Flags use defFlag, defGhcFlag, +-- defGhciFlag, and for FlagSpec use flagSpec or flagGhciSpec. + +-- Note [Adding a language extension] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- There are a few steps to adding (or removing) a language extension, +-- +-- * Adding the extension to GHC.LanguageExtensions +-- +-- The Extension type in libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs +-- is the canonical list of language extensions known by GHC. +-- +-- * Adding a flag to DynFlags.xFlags +-- +-- This is fairly self-explanatory. The name should be concise, memorable, +-- and consistent with any previous implementations of the similar idea in +-- other Haskell compilers. +-- +-- * Adding the flag to the documentation +-- +-- This is the same as any other flag. See +-- Note [Updating flag description in the User's Guide] +-- +-- * Adding the flag to Cabal +-- +-- The Cabal library has its own list of all language extensions supported +-- by all major compilers. This is the list that user code being uploaded +-- to Hackage is checked against to ensure language extension validity. +-- Consequently, it is very important that this list remains up-to-date. +-- +-- To this end, there is a testsuite test (testsuite/tests/driver/T4437.hs) +-- whose job it is to ensure these GHC's extensions are consistent with +-- Cabal. +-- +-- The recommended workflow is, +-- +-- 1. Temporarily add your new language extension to the +-- expectedGhcOnlyExtensions list in T4437 to ensure the test doesn't +-- break while Cabal is updated. +-- +-- 2. After your GHC change is accepted, submit a Cabal pull request adding +-- your new extension to Cabal's list (found in +-- Cabal/Language/Haskell/Extension.hs). +-- +-- 3. After your Cabal change is accepted, let the GHC developers know so +-- they can update the Cabal submodule and remove the extensions from +-- expectedGhcOnlyExtensions. +-- +-- * Adding the flag to the GHC Wiki +-- +-- There is a change log tracking language extension additions and removals +-- on the GHC wiki: https://gitlab.haskell.org/ghc/ghc/wikis/language-pragma-history +-- +-- See #4437 and #8176. + +-- ----------------------------------------------------------------------------- +-- DynFlags + +data DumpFlag +-- See Note [Updating flag description in the User's Guide] + + -- debugging flags + = Opt_D_dump_cmm + | Opt_D_dump_cmm_from_stg + | Opt_D_dump_cmm_raw + | Opt_D_dump_cmm_verbose + -- All of the cmm subflags (there are a lot!) automatically + -- enabled if you run -ddump-cmm-verbose + -- Each flag corresponds to exact stage of Cmm pipeline. + | Opt_D_dump_cmm_cfg + | Opt_D_dump_cmm_cbe + | Opt_D_dump_cmm_switch + | Opt_D_dump_cmm_proc + | Opt_D_dump_cmm_sp + | Opt_D_dump_cmm_sink + | Opt_D_dump_cmm_caf + | Opt_D_dump_cmm_procmap + | Opt_D_dump_cmm_split + | Opt_D_dump_cmm_info + | Opt_D_dump_cmm_cps + -- end cmm subflags + | Opt_D_dump_cfg_weights -- ^ Dump the cfg used for block layout. + | Opt_D_dump_asm + | Opt_D_dump_asm_native + | Opt_D_dump_asm_liveness + | Opt_D_dump_asm_regalloc + | Opt_D_dump_asm_regalloc_stages + | Opt_D_dump_asm_conflicts + | Opt_D_dump_asm_stats + | Opt_D_dump_asm_expanded + | Opt_D_dump_llvm + | Opt_D_dump_core_stats + | Opt_D_dump_deriv + | Opt_D_dump_ds + | Opt_D_dump_ds_preopt + | Opt_D_dump_foreign + | Opt_D_dump_inlinings + | Opt_D_dump_rule_firings + | Opt_D_dump_rule_rewrites + | Opt_D_dump_simpl_trace + | Opt_D_dump_occur_anal + | Opt_D_dump_parsed + | Opt_D_dump_parsed_ast + | Opt_D_dump_rn + | Opt_D_dump_rn_ast + | Opt_D_dump_shape + | Opt_D_dump_simpl + | Opt_D_dump_simpl_iterations + | Opt_D_dump_spec + | Opt_D_dump_prep + | Opt_D_dump_stg + | Opt_D_dump_call_arity + | Opt_D_dump_exitify + | Opt_D_dump_stranal + | Opt_D_dump_str_signatures + | Opt_D_dump_tc + | Opt_D_dump_tc_ast + | Opt_D_dump_types + | Opt_D_dump_rules + | Opt_D_dump_cse + | Opt_D_dump_worker_wrapper + | Opt_D_dump_rn_trace + | Opt_D_dump_rn_stats + | Opt_D_dump_opt_cmm + | Opt_D_dump_simpl_stats + | Opt_D_dump_cs_trace -- Constraint solver in type checker + | Opt_D_dump_tc_trace + | Opt_D_dump_ec_trace -- Pattern match exhaustiveness checker + | Opt_D_dump_if_trace + | Opt_D_dump_vt_trace + | Opt_D_dump_splices + | Opt_D_th_dec_file + | Opt_D_dump_BCOs + | Opt_D_dump_ticked + | Opt_D_dump_rtti + | Opt_D_source_stats + | Opt_D_verbose_stg2stg + | Opt_D_dump_hi + | Opt_D_dump_hi_diffs + | Opt_D_dump_mod_cycles + | Opt_D_dump_mod_map + | Opt_D_dump_timings + | Opt_D_dump_view_pattern_commoning + | Opt_D_verbose_core2core + | Opt_D_dump_debug + | Opt_D_dump_json + | Opt_D_ppr_debug + | Opt_D_no_debug_output + deriving (Eq, Show, Enum) + + +-- | Enumerates the simple on-or-off dynamic flags +data GeneralFlag +-- See Note [Updating flag description in the User's Guide] + + = Opt_DumpToFile -- ^ Append dump output to files instead of stdout. + | Opt_D_faststring_stats + | Opt_D_dump_minimal_imports + | Opt_DoCoreLinting + | Opt_DoStgLinting + | Opt_DoCmmLinting + | Opt_DoAsmLinting + | Opt_DoAnnotationLinting + | Opt_NoLlvmMangler -- hidden flag + | Opt_FastLlvm -- hidden flag + + | Opt_WarnIsError -- -Werror; makes warnings fatal + | Opt_ShowWarnGroups -- Show the group a warning belongs to + | Opt_HideSourcePaths -- Hide module source/object paths + + | Opt_PrintExplicitForalls + | Opt_PrintExplicitKinds + | Opt_PrintExplicitCoercions + | Opt_PrintExplicitRuntimeReps + | Opt_PrintEqualityRelations + | Opt_PrintUnicodeSyntax + | Opt_PrintExpandedSynonyms + | Opt_PrintPotentialInstances + | Opt_PrintTypecheckerElaboration + + -- optimisation opts + | Opt_CallArity + | Opt_Exitification + | Opt_Strictness + | Opt_LateDmdAnal -- #6087 + | Opt_KillAbsence + | Opt_KillOneShot + | Opt_FullLaziness + | Opt_FloatIn + | Opt_LateSpecialise + | Opt_Specialise + | Opt_SpecialiseAggressively + | Opt_CrossModuleSpecialise + | Opt_StaticArgumentTransformation + | Opt_CSE + | Opt_StgCSE + | Opt_StgLiftLams + | Opt_LiberateCase + | Opt_SpecConstr + | Opt_SpecConstrKeen + | Opt_DoLambdaEtaExpansion + | Opt_IgnoreAsserts + | Opt_DoEtaReduction + | Opt_CaseMerge + | Opt_CaseFolding -- Constant folding through case-expressions + | Opt_UnboxStrictFields + | Opt_UnboxSmallStrictFields + | Opt_DictsCheap + | Opt_EnableRewriteRules -- Apply rewrite rules during simplification + | Opt_RegsGraph -- do graph coloring register allocation + | Opt_RegsIterative -- do iterative coalescing graph coloring register allocation + | Opt_PedanticBottoms -- Be picky about how we treat bottom + | Opt_LlvmTBAA -- Use LLVM TBAA infastructure for improving AA (hidden flag) + | Opt_LlvmFillUndefWithGarbage -- Testing for undef bugs (hidden flag) + | Opt_IrrefutableTuples + | Opt_CmmSink + | Opt_CmmElimCommonBlocks + | Opt_AsmShortcutting + | Opt_OmitYields + | Opt_FunToThunk -- allow WwLib.mkWorkerArgs to remove all value lambdas + | Opt_DictsStrict -- be strict in argument dictionaries + | Opt_DmdTxDictSel -- use a special demand transformer for dictionary selectors + | Opt_Loopification -- See Note [Self-recursive tail calls] + | Opt_CfgBlocklayout -- ^ Use the cfg based block layout algorithm. + | Opt_WeightlessBlocklayout -- ^ Layout based on last instruction per block. + | Opt_CprAnal + | Opt_WorkerWrapper + | Opt_SolveConstantDicts + | Opt_AlignmentSanitisation + | Opt_CatchBottoms + | Opt_NumConstantFolding + + -- PreInlining is on by default. The option is there just to see how + -- bad things get if you turn it off! + | Opt_SimplPreInlining + + -- Interface files + | Opt_IgnoreInterfacePragmas + | Opt_OmitInterfacePragmas + | Opt_ExposeAllUnfoldings + | Opt_WriteInterface -- forces .hi files to be written even with -fno-code + | Opt_WriteHie -- generate .hie files + + -- profiling opts + | Opt_AutoSccsOnIndividualCafs + | Opt_ProfCountEntries + + -- misc opts + | Opt_Pp + | Opt_ForceRecomp + | Opt_IgnoreOptimChanges + | Opt_IgnoreHpcChanges + | Opt_ExcessPrecision + | Opt_EagerBlackHoling + | Opt_NoHsMain + | Opt_SplitSections + | Opt_StgStats + | Opt_HideAllPackages + | Opt_HideAllPluginPackages + | Opt_PrintBindResult + | Opt_Haddock + | Opt_HaddockOptions + | Opt_BreakOnException + | Opt_BreakOnError + | Opt_PrintEvldWithShow + | Opt_PrintBindContents + | Opt_GenManifest + | Opt_EmbedManifest + | Opt_SharedImplib + | Opt_BuildingCabalPackage + | Opt_IgnoreDotGhci + | Opt_GhciSandbox + | Opt_GhciHistory + | Opt_GhciLeakCheck + | Opt_ValidateHie + | Opt_LocalGhciHistory + | Opt_NoIt + | Opt_HelpfulErrors + | Opt_DeferTypeErrors + | Opt_DeferTypedHoles + | Opt_DeferOutOfScopeVariables + | Opt_PIC -- ^ @-fPIC@ + | Opt_PIE -- ^ @-fPIE@ + | Opt_PICExecutable -- ^ @-pie@ + | Opt_ExternalDynamicRefs + | Opt_SccProfilingOn + | Opt_Ticky + | Opt_Ticky_Allocd + | Opt_Ticky_LNE + | Opt_Ticky_Dyn_Thunk + | Opt_RPath + | Opt_RelativeDynlibPaths + | Opt_Hpc + | Opt_FlatCache + | Opt_ExternalInterpreter + | Opt_OptimalApplicativeDo + | Opt_VersionMacros + | Opt_WholeArchiveHsLibs + -- copy all libs into a single folder prior to linking binaries + -- this should elivate the excessive command line limit restrictions + -- on windows, by only requiring a single -L argument instead of + -- one for each dependency. At the time of this writing, gcc + -- forwards all -L flags to the collect2 command without using a + -- response file and as such breaking apart. + | Opt_SingleLibFolder + | Opt_KeepCAFs + + -- output style opts + | Opt_ErrorSpans -- Include full span info in error messages, + -- instead of just the start position. + | Opt_DeferDiagnostics + | Opt_DiagnosticsShowCaret -- Show snippets of offending code + | Opt_PprCaseAsLet + | Opt_PprShowTicks + | Opt_ShowHoleConstraints + -- Options relating to the display of valid hole fits + -- when generating an error message for a typed hole + -- See Note [Valid hole fits include] in TcHoleErrors.hs + | Opt_ShowValidHoleFits + | Opt_SortValidHoleFits + | Opt_SortBySizeHoleFits + | Opt_SortBySubsumHoleFits + | Opt_AbstractRefHoleFits + | Opt_UnclutterValidHoleFits + | Opt_ShowTypeAppOfHoleFits + | Opt_ShowTypeAppVarsOfHoleFits + | Opt_ShowDocsOfHoleFits + | Opt_ShowTypeOfHoleFits + | Opt_ShowProvOfHoleFits + | Opt_ShowMatchesOfHoleFits + + | Opt_ShowLoadedModules + | Opt_HexWordLiterals -- See Note [Print Hexadecimal Literals] + + -- Suppress all coercions, them replacing with '...' + | Opt_SuppressCoercions + | Opt_SuppressVarKinds + -- Suppress module id prefixes on variables. + | Opt_SuppressModulePrefixes + -- Suppress type applications. + | Opt_SuppressTypeApplications + -- Suppress info such as arity and unfoldings on identifiers. + | Opt_SuppressIdInfo + -- Suppress separate type signatures in core, but leave types on + -- lambda bound vars + | Opt_SuppressUnfoldings + -- Suppress the details of even stable unfoldings + | Opt_SuppressTypeSignatures + -- Suppress unique ids on variables. + -- Except for uniques, as some simplifier phases introduce new + -- variables that have otherwise identical names. + | Opt_SuppressUniques + | Opt_SuppressStgExts + | Opt_SuppressTicks -- Replaces Opt_PprShowTicks + | Opt_SuppressTimestamps -- ^ Suppress timestamps in dumps + + -- temporary flags + | Opt_AutoLinkPackages + | Opt_ImplicitImportQualified + + -- keeping stuff + | Opt_KeepHscppFiles + | Opt_KeepHiDiffs + | Opt_KeepHcFiles + | Opt_KeepSFiles + | Opt_KeepTmpFiles + | Opt_KeepRawTokenStream + | Opt_KeepLlvmFiles + | Opt_KeepHiFiles + | Opt_KeepOFiles + + | Opt_BuildDynamicToo + + -- safe haskell flags + | Opt_DistrustAllPackages + | Opt_PackageTrust + | Opt_PluginTrustworthy + + | Opt_G_NoStateHack + | Opt_G_NoOptCoercion + deriving (Eq, Show, Enum) + +-- Check whether a flag should be considered an "optimisation flag" +-- for purposes of recompilation avoidance (see +-- Note [Ignoring some flag changes] in FlagChecker). Being listed here is +-- not a guarantee that the flag has no other effect. We could, and +-- perhaps should, separate out the flags that have some minor impact on +-- program semantics and/or error behavior (e.g., assertions), but +-- then we'd need to go to extra trouble (and an additional flag) +-- to allow users to ignore the optimisation level even though that +-- means ignoring some change. +optimisationFlags :: EnumSet GeneralFlag +optimisationFlags = EnumSet.fromList + [ Opt_CallArity + , Opt_Strictness + , Opt_LateDmdAnal + , Opt_KillAbsence + , Opt_KillOneShot + , Opt_FullLaziness + , Opt_FloatIn + , Opt_LateSpecialise + , Opt_Specialise + , Opt_SpecialiseAggressively + , Opt_CrossModuleSpecialise + , Opt_StaticArgumentTransformation + , Opt_CSE + , Opt_StgCSE + , Opt_StgLiftLams + , Opt_LiberateCase + , Opt_SpecConstr + , Opt_SpecConstrKeen + , Opt_DoLambdaEtaExpansion + , Opt_IgnoreAsserts + , Opt_DoEtaReduction + , Opt_CaseMerge + , Opt_CaseFolding + , Opt_UnboxStrictFields + , Opt_UnboxSmallStrictFields + , Opt_DictsCheap + , Opt_EnableRewriteRules + , Opt_RegsGraph + , Opt_RegsIterative + , Opt_PedanticBottoms + , Opt_LlvmTBAA + , Opt_LlvmFillUndefWithGarbage + , Opt_IrrefutableTuples + , Opt_CmmSink + , Opt_CmmElimCommonBlocks + , Opt_AsmShortcutting + , Opt_OmitYields + , Opt_FunToThunk + , Opt_DictsStrict + , Opt_DmdTxDictSel + , Opt_Loopification + , Opt_CfgBlocklayout + , Opt_WeightlessBlocklayout + , Opt_CprAnal + , Opt_WorkerWrapper + , Opt_SolveConstantDicts + , Opt_CatchBottoms + , Opt_IgnoreAsserts + ] + +-- | Used when outputting warnings: if a reason is given, it is +-- displayed. If a warning isn't controlled by a flag, this is made +-- explicit at the point of use. +data WarnReason + = NoReason + -- | Warning was enabled with the flag + | Reason !WarningFlag + -- | Warning was made an error because of -Werror or -Werror=WarningFlag + | ErrReason !(Maybe WarningFlag) + deriving Show + +-- | Used to differentiate the scope an include needs to apply to. +-- We have to split the include paths to avoid accidentally forcing recursive +-- includes since -I overrides the system search paths. See #14312. +data IncludeSpecs + = IncludeSpecs { includePathsQuote :: [String] + , includePathsGlobal :: [String] + } + deriving Show + +-- | Append to the list of includes a path that shall be included using `-I` +-- when the C compiler is called. These paths override system search paths. +addGlobalInclude :: IncludeSpecs -> [String] -> IncludeSpecs +addGlobalInclude spec paths = let f = includePathsGlobal spec + in spec { includePathsGlobal = f ++ paths } + +-- | Append to the list of includes a path that shall be included using +-- `-iquote` when the C compiler is called. These paths only apply when quoted +-- includes are used. e.g. #include "foo.h" +addQuoteInclude :: IncludeSpecs -> [String] -> IncludeSpecs +addQuoteInclude spec paths = let f = includePathsQuote spec + in spec { includePathsQuote = f ++ paths } + +-- | Concatenate and flatten the list of global and quoted includes returning +-- just a flat list of paths. +flattenIncludes :: IncludeSpecs -> [String] +flattenIncludes specs = includePathsQuote specs ++ includePathsGlobal specs + +instance Outputable WarnReason where + ppr = text . show + +instance ToJson WarnReason where + json NoReason = JSNull + json (Reason wf) = JSString (show wf) + json (ErrReason Nothing) = JSString "Opt_WarnIsError" + json (ErrReason (Just wf)) = JSString (show wf) + +data WarningFlag = +-- See Note [Updating flag description in the User's Guide] + Opt_WarnDuplicateExports + | Opt_WarnDuplicateConstraints + | Opt_WarnRedundantConstraints + | Opt_WarnHiShadows + | Opt_WarnImplicitPrelude + | Opt_WarnIncompletePatterns + | Opt_WarnIncompleteUniPatterns + | Opt_WarnIncompletePatternsRecUpd + | Opt_WarnOverflowedLiterals + | Opt_WarnEmptyEnumerations + | Opt_WarnMissingFields + | Opt_WarnMissingImportList + | Opt_WarnMissingMethods + | Opt_WarnMissingSignatures + | Opt_WarnMissingLocalSignatures + | Opt_WarnNameShadowing + | Opt_WarnOverlappingPatterns + | Opt_WarnTypeDefaults + | Opt_WarnMonomorphism + | Opt_WarnUnusedTopBinds + | Opt_WarnUnusedLocalBinds + | Opt_WarnUnusedPatternBinds + | Opt_WarnUnusedImports + | Opt_WarnUnusedMatches + | Opt_WarnUnusedTypePatterns + | Opt_WarnUnusedForalls + | Opt_WarnUnusedRecordWildcards + | Opt_WarnRedundantRecordWildcards + | Opt_WarnWarningsDeprecations + | Opt_WarnDeprecatedFlags + | Opt_WarnMissingMonadFailInstances -- since 8.0 + | Opt_WarnSemigroup -- since 8.0 + | Opt_WarnDodgyExports + | Opt_WarnDodgyImports + | Opt_WarnOrphans + | Opt_WarnAutoOrphans + | Opt_WarnIdentities + | Opt_WarnTabs + | Opt_WarnUnrecognisedPragmas + | Opt_WarnDodgyForeignImports + | Opt_WarnUnusedDoBind + | Opt_WarnWrongDoBind + | Opt_WarnAlternativeLayoutRuleTransitional + | Opt_WarnUnsafe + | Opt_WarnSafe + | Opt_WarnTrustworthySafe + | Opt_WarnMissedSpecs + | Opt_WarnAllMissedSpecs + | Opt_WarnUnsupportedCallingConventions + | Opt_WarnUnsupportedLlvmVersion + | Opt_WarnMissedExtraSharedLib + | Opt_WarnInlineRuleShadowing + | Opt_WarnTypedHoles + | Opt_WarnPartialTypeSignatures + | Opt_WarnMissingExportedSignatures + | Opt_WarnUntickedPromotedConstructors + | Opt_WarnDerivingTypeable + | Opt_WarnDeferredTypeErrors + | Opt_WarnDeferredOutOfScopeVariables + | Opt_WarnNonCanonicalMonadInstances -- since 8.0 + | Opt_WarnNonCanonicalMonadFailInstances -- since 8.0, removed 8.8 + | Opt_WarnNonCanonicalMonoidInstances -- since 8.0 + | Opt_WarnMissingPatternSynonymSignatures -- since 8.0 + | Opt_WarnUnrecognisedWarningFlags -- since 8.0 + | Opt_WarnSimplifiableClassConstraints -- Since 8.2 + | Opt_WarnCPPUndef -- Since 8.2 + | Opt_WarnUnbangedStrictPatterns -- Since 8.2 + | Opt_WarnMissingHomeModules -- Since 8.2 + | Opt_WarnPartialFields -- Since 8.4 + | Opt_WarnMissingExportList + | Opt_WarnInaccessibleCode + | Opt_WarnStarIsType -- Since 8.6 + | Opt_WarnStarBinder -- Since 8.6 + | Opt_WarnImplicitKindVars -- Since 8.6 + | Opt_WarnSpaceAfterBang + | Opt_WarnMissingDerivingStrategies -- Since 8.8 + deriving (Eq, Show, Enum) + +data Language = Haskell98 | Haskell2010 + deriving (Eq, Enum, Show) + +instance Outputable Language where + ppr = text . show + +-- | The various Safe Haskell modes +data SafeHaskellMode + = Sf_None + | Sf_Unsafe + | Sf_Trustworthy + | Sf_Safe + | Sf_Ignore + deriving (Eq) + +instance Show SafeHaskellMode where + show Sf_None = "None" + show Sf_Unsafe = "Unsafe" + show Sf_Trustworthy = "Trustworthy" + show Sf_Safe = "Safe" + show Sf_Ignore = "Ignore" + +instance Outputable SafeHaskellMode where + ppr = text . show + +-- | Contains not only a collection of 'GeneralFlag's but also a plethora of +-- information relating to the compilation of a single file or GHC session +data DynFlags = DynFlags { + ghcMode :: GhcMode, + ghcLink :: GhcLink, + hscTarget :: HscTarget, + settings :: Settings, + integerLibrary :: IntegerLibrary, + -- ^ IntegerGMP or IntegerSimple. Set at configure time, but may be overriden + -- by GHC-API users. See Note [The integer library] in PrelNames + llvmTargets :: LlvmTargets, + llvmPasses :: LlvmPasses, + verbosity :: Int, -- ^ Verbosity level: see Note [Verbosity levels] + optLevel :: Int, -- ^ Optimisation level + debugLevel :: Int, -- ^ How much debug information to produce + simplPhases :: Int, -- ^ Number of simplifier phases + maxSimplIterations :: Int, -- ^ Max simplifier iterations + maxPmCheckIterations :: Int, -- ^ Max no iterations for pm checking + ruleCheck :: Maybe String, + inlineCheck :: Maybe String, -- ^ A prefix to report inlining decisions about + strictnessBefore :: [Int], -- ^ Additional demand analysis + + parMakeCount :: Maybe Int, -- ^ The number of modules to compile in parallel + -- in --make mode, where Nothing ==> compile as + -- many in parallel as there are CPUs. + + enableTimeStats :: Bool, -- ^ Enable RTS timing statistics? + ghcHeapSize :: Maybe Int, -- ^ The heap size to set. + + maxRelevantBinds :: Maybe Int, -- ^ Maximum number of bindings from the type envt + -- to show in type error messages + maxValidHoleFits :: Maybe Int, -- ^ Maximum number of hole fits to show + -- in typed hole error messages + maxRefHoleFits :: Maybe Int, -- ^ Maximum number of refinement hole + -- fits to show in typed hole error + -- messages + refLevelHoleFits :: Maybe Int, -- ^ Maximum level of refinement for + -- refinement hole fits in typed hole + -- error messages + maxUncoveredPatterns :: Int, -- ^ Maximum number of unmatched patterns to show + -- in non-exhaustiveness warnings + simplTickFactor :: Int, -- ^ Multiplier for simplifier ticks + specConstrThreshold :: Maybe Int, -- ^ Threshold for SpecConstr + specConstrCount :: Maybe Int, -- ^ Max number of specialisations for any one function + specConstrRecursive :: Int, -- ^ Max number of specialisations for recursive types + -- Not optional; otherwise ForceSpecConstr can diverge. + binBlobThreshold :: Word, -- ^ Binary literals (e.g. strings) whose size is above + -- this threshold will be dumped in a binary file + -- by the assembler code generator (0 to disable) + liberateCaseThreshold :: Maybe Int, -- ^ Threshold for LiberateCase + floatLamArgs :: Maybe Int, -- ^ Arg count for lambda floating + -- See CoreMonad.FloatOutSwitches + + liftLamsRecArgs :: Maybe Int, -- ^ Maximum number of arguments after lambda lifting a + -- recursive function. + liftLamsNonRecArgs :: Maybe Int, -- ^ Maximum number of arguments after lambda lifting a + -- non-recursive function. + liftLamsKnown :: Bool, -- ^ Lambda lift even when this turns a known call + -- into an unknown call. + + cmmProcAlignment :: Maybe Int, -- ^ Align Cmm functions at this boundary or use default. + + historySize :: Int, -- ^ Simplification history size + + importPaths :: [FilePath], + mainModIs :: Module, + mainFunIs :: Maybe String, + reductionDepth :: IntWithInf, -- ^ Typechecker maximum stack depth + solverIterations :: IntWithInf, -- ^ Number of iterations in the constraints solver + -- Typically only 1 is needed + + thisInstalledUnitId :: InstalledUnitId, + thisComponentId_ :: Maybe ComponentId, + thisUnitIdInsts_ :: Maybe [(ModuleName, Module)], + + -- ways + ways :: [Way], -- ^ Way flags from the command line + buildTag :: String, -- ^ The global \"way\" (e.g. \"p\" for prof) + + -- For object splitting + splitInfo :: Maybe (String,Int), + + -- paths etc. + objectDir :: Maybe String, + dylibInstallName :: Maybe String, + hiDir :: Maybe String, + hieDir :: Maybe String, + stubDir :: Maybe String, + dumpDir :: Maybe String, + + objectSuf :: String, + hcSuf :: String, + hiSuf :: String, + hieSuf :: String, + + canGenerateDynamicToo :: IORef Bool, + dynObjectSuf :: String, + dynHiSuf :: String, + + outputFile :: Maybe String, + dynOutputFile :: Maybe String, + outputHi :: Maybe String, + dynLibLoader :: DynLibLoader, + + -- | This is set by 'DriverPipeline.runPipeline' based on where + -- its output is going. + dumpPrefix :: Maybe FilePath, + + -- | Override the 'dumpPrefix' set by 'DriverPipeline.runPipeline'. + -- Set by @-ddump-file-prefix@ + dumpPrefixForce :: Maybe FilePath, + + ldInputs :: [Option], + + includePaths :: IncludeSpecs, + libraryPaths :: [String], + frameworkPaths :: [String], -- used on darwin only + cmdlineFrameworks :: [String], -- ditto + + rtsOpts :: Maybe String, + rtsOptsEnabled :: RtsOptsEnabled, + rtsOptsSuggestions :: Bool, + + hpcDir :: String, -- ^ Path to store the .mix files + + -- Plugins + pluginModNames :: [ModuleName], + pluginModNameOpts :: [(ModuleName,String)], + frontendPluginOpts :: [String], + -- ^ the @-ffrontend-opt@ flags given on the command line, in *reverse* + -- order that they're specified on the command line. + cachedPlugins :: [LoadedPlugin], + -- ^ plugins dynamically loaded after processing arguments. What will be + -- loaded here is directed by pluginModNames. Arguments are loaded from + -- pluginModNameOpts. The purpose of this field is to cache the plugins so + -- they don't have to be loaded each time they are needed. See + -- 'DynamicLoading.initializePlugins'. + staticPlugins :: [StaticPlugin], + -- ^ staic plugins which do not need dynamic loading. These plugins are + -- intended to be added by GHC API users directly to this list. + -- + -- To add dynamically loaded plugins through the GHC API see + -- 'addPluginModuleName' instead. + + -- GHC API hooks + hooks :: Hooks, + + -- For ghc -M + depMakefile :: FilePath, + depIncludePkgDeps :: Bool, + depExcludeMods :: [ModuleName], + depSuffixes :: [String], + + -- Package flags + packageDBFlags :: [PackageDBFlag], + -- ^ The @-package-db@ flags given on the command line, In + -- *reverse* order that they're specified on the command line. + -- This is intended to be applied with the list of "initial" + -- package databases derived from @GHC_PACKAGE_PATH@; see + -- 'getPackageConfRefs'. + + ignorePackageFlags :: [IgnorePackageFlag], + -- ^ The @-ignore-package@ flags from the command line. + -- In *reverse* order that they're specified on the command line. + packageFlags :: [PackageFlag], + -- ^ The @-package@ and @-hide-package@ flags from the command-line. + -- In *reverse* order that they're specified on the command line. + pluginPackageFlags :: [PackageFlag], + -- ^ The @-plugin-package-id@ flags from command line. + -- In *reverse* order that they're specified on the command line. + trustFlags :: [TrustFlag], + -- ^ The @-trust@ and @-distrust@ flags. + -- In *reverse* order that they're specified on the command line. + packageEnv :: Maybe FilePath, + -- ^ Filepath to the package environment file (if overriding default) + + -- Package state + -- NB. do not modify this field, it is calculated by + -- Packages.initPackages + pkgDatabase :: Maybe [(FilePath, [PackageConfig])], + pkgState :: PackageState, + + -- Temporary files + -- These have to be IORefs, because the defaultCleanupHandler needs to + -- know what to clean when an exception happens + filesToClean :: IORef FilesToClean, + dirsToClean :: IORef (Map FilePath FilePath), + -- The next available suffix to uniquely name a temp file, updated atomically + nextTempSuffix :: IORef Int, + + -- Names of files which were generated from -ddump-to-file; used to + -- track which ones we need to truncate because it's our first run + -- through + generatedDumps :: IORef (Set FilePath), + + -- hsc dynamic flags + dumpFlags :: EnumSet DumpFlag, + generalFlags :: EnumSet GeneralFlag, + warningFlags :: EnumSet WarningFlag, + fatalWarningFlags :: EnumSet WarningFlag, + -- Don't change this without updating extensionFlags: + language :: Maybe Language, + -- | Safe Haskell mode + safeHaskell :: SafeHaskellMode, + safeInfer :: Bool, + safeInferred :: Bool, + -- We store the location of where some extension and flags were turned on so + -- we can produce accurate error messages when Safe Haskell fails due to + -- them. + thOnLoc :: SrcSpan, + newDerivOnLoc :: SrcSpan, + overlapInstLoc :: SrcSpan, + incoherentOnLoc :: SrcSpan, + pkgTrustOnLoc :: SrcSpan, + warnSafeOnLoc :: SrcSpan, + warnUnsafeOnLoc :: SrcSpan, + trustworthyOnLoc :: SrcSpan, + -- Don't change this without updating extensionFlags: + -- Here we collect the settings of the language extensions + -- from the command line, the ghci config file and + -- from interactive :set / :seti commands. + extensions :: [OnOff LangExt.Extension], + -- extensionFlags should always be equal to + -- flattenExtensionFlags language extensions + -- LangExt.Extension is defined in libraries/ghc-boot so that it can be used + -- by template-haskell + extensionFlags :: EnumSet LangExt.Extension, + + -- Unfolding control + -- See Note [Discounts and thresholds] in CoreUnfold + ufCreationThreshold :: Int, + ufUseThreshold :: Int, + ufFunAppDiscount :: Int, + ufDictDiscount :: Int, + ufKeenessFactor :: Float, + ufDearOp :: Int, + ufVeryAggressive :: Bool, + + maxWorkerArgs :: Int, + + ghciHistSize :: Int, + + -- | MsgDoc output action: use "ErrUtils" instead of this if you can + log_action :: LogAction, + flushOut :: FlushOut, + flushErr :: FlushErr, + + ghcVersionFile :: Maybe FilePath, + haddockOptions :: Maybe String, + + -- | GHCi scripts specified by -ghci-script, in reverse order + ghciScripts :: [String], + + -- Output style options + pprUserLength :: Int, + pprCols :: Int, + + useUnicode :: Bool, + useColor :: OverridingBool, + canUseColor :: Bool, + colScheme :: Col.Scheme, + + -- | what kind of {-# SCC #-} to add automatically + profAuto :: ProfAuto, + + interactivePrint :: Maybe String, + + nextWrapperNum :: IORef (ModuleEnv Int), + + -- | Machine dependent flags (-m stuff) + sseVersion :: Maybe SseVersion, + bmiVersion :: Maybe BmiVersion, + avx :: Bool, + avx2 :: Bool, + avx512cd :: Bool, -- Enable AVX-512 Conflict Detection Instructions. + avx512er :: Bool, -- Enable AVX-512 Exponential and Reciprocal Instructions. + avx512f :: Bool, -- Enable AVX-512 instructions. + avx512pf :: Bool, -- Enable AVX-512 PreFetch Instructions. + + -- | Run-time linker information (what options we need, etc.) + rtldInfo :: IORef (Maybe LinkerInfo), + + -- | Run-time compiler information + rtccInfo :: IORef (Maybe CompilerInfo), + + -- Constants used to control the amount of optimization done. + + -- | Max size, in bytes, of inline array allocations. + maxInlineAllocSize :: Int, + + -- | Only inline memcpy if it generates no more than this many + -- pseudo (roughly: Cmm) instructions. + maxInlineMemcpyInsns :: Int, + + -- | Only inline memset if it generates no more than this many + -- pseudo (roughly: Cmm) instructions. + maxInlineMemsetInsns :: Int, + + -- | Reverse the order of error messages in GHC/GHCi + reverseErrors :: Bool, + + -- | Limit the maximum number of errors to show + maxErrors :: Maybe Int, + + -- | Unique supply configuration for testing build determinism + initialUnique :: Int, + uniqueIncrement :: Int, + + -- | Temporary: CFG Edge weights for fast iterations + cfgWeightInfo :: CfgWeights +} + +-- | Edge weights to use when generating a CFG from CMM +data CfgWeights + = CFGWeights + { uncondWeight :: Int + , condBranchWeight :: Int + , switchWeight :: Int + , callWeight :: Int + , likelyCondWeight :: Int + , unlikelyCondWeight :: Int + , infoTablePenalty :: Int + , backEdgeBonus :: Int + } + +defaultCfgWeights :: CfgWeights +defaultCfgWeights + = CFGWeights + { uncondWeight = 1000 + , condBranchWeight = 800 + , switchWeight = 1 + , callWeight = -10 + , likelyCondWeight = 900 + , unlikelyCondWeight = 300 + , infoTablePenalty = 300 + , backEdgeBonus = 400 + } + +parseCfgWeights :: String -> CfgWeights -> CfgWeights +parseCfgWeights s oldWeights = + foldl' (\cfg (n,v) -> update n v cfg) oldWeights assignments + where + assignments = map assignment $ settings s + update "uncondWeight" n w = + w {uncondWeight = n} + update "condBranchWeight" n w = + w {condBranchWeight = n} + update "switchWeight" n w = + w {switchWeight = n} + update "callWeight" n w = + w {callWeight = n} + update "likelyCondWeight" n w = + w {likelyCondWeight = n} + update "unlikelyCondWeight" n w = + w {unlikelyCondWeight = n} + update "infoTablePenalty" n w = + w {infoTablePenalty = n} + update "backEdgeBonus" n w = + w {backEdgeBonus = n} + update other _ _ + = panic $ other ++ + " is not a cfg weight parameter. " ++ + exampleString + settings s + | (s1,rest) <- break (== ',') s + , null rest + = [s1] + | (s1,rest) <- break (== ',') s + = [s1] ++ settings (drop 1 rest) + | otherwise = panic $ "Invalid cfg parameters." ++ exampleString + assignment as + | (name, _:val) <- break (== '=') as + = (name,read val) + | otherwise + = panic $ "Invalid cfg parameters." ++ exampleString + exampleString = "Example parameters: uncondWeight=1000," ++ + "condBranchWeight=800,switchWeight=0,callWeight=300" ++ + ",likelyCondWeight=900,unlikelyCondWeight=300" ++ + ",infoTablePenalty=300,backEdgeBonus=400" + +backendMaintainsCfg :: DynFlags -> Bool +backendMaintainsCfg dflags = case (platformArch $ targetPlatform dflags) of + -- ArchX86 -- Should work but not tested so disabled currently. + ArchX86_64 -> True + _otherwise -> False + +class HasDynFlags m where + getDynFlags :: m DynFlags + +{- It would be desirable to have the more generalised + + instance (MonadTrans t, Monad m, HasDynFlags m) => HasDynFlags (t m) where + getDynFlags = lift getDynFlags + +instance definition. However, that definition would overlap with the +`HasDynFlags (GhcT m)` instance. Instead we define instances for a +couple of common Monad transformers explicitly. -} + +instance (Monoid a, Monad m, HasDynFlags m) => HasDynFlags (WriterT a m) where + getDynFlags = lift getDynFlags + +instance (Monad m, HasDynFlags m) => HasDynFlags (ReaderT a m) where + getDynFlags = lift getDynFlags + +instance (Monad m, HasDynFlags m) => HasDynFlags (MaybeT m) where + getDynFlags = lift getDynFlags + +instance (Monad m, HasDynFlags m) => HasDynFlags (ExceptT e m) where + getDynFlags = lift getDynFlags + +class ContainsDynFlags t where + extractDynFlags :: t -> DynFlags + +data ProfAuto + = NoProfAuto -- ^ no SCC annotations added + | ProfAutoAll -- ^ top-level and nested functions are annotated + | ProfAutoTop -- ^ top-level functions annotated only + | ProfAutoExports -- ^ exported functions annotated only + | ProfAutoCalls -- ^ annotate call-sites + deriving (Eq,Enum) + +data LlvmTarget = LlvmTarget + { lDataLayout :: String + , lCPU :: String + , lAttributes :: [String] + } + +type LlvmTargets = [(String, LlvmTarget)] +type LlvmPasses = [(Int, String)] +type LlvmConfig = (LlvmTargets, LlvmPasses) + +data Settings = Settings { + sTargetPlatform :: Platform, -- Filled in by SysTools + sGhcUsagePath :: FilePath, -- ditto + sGhciUsagePath :: FilePath, -- ditto + sToolDir :: Maybe FilePath, -- ditto + sTopDir :: FilePath, -- ditto + sTmpDir :: String, -- no trailing '/' + sProgramName :: String, + sProjectVersion :: String, + -- You shouldn't need to look things up in rawSettings directly. + -- They should have their own fields instead. + sRawSettings :: [(String, String)], + sExtraGccViaCFlags :: [String], + sSystemPackageConfig :: FilePath, + sLdSupportsCompactUnwind :: Bool, + sLdSupportsBuildId :: Bool, + sLdSupportsFilelist :: Bool, + sLdIsGnuLd :: Bool, + sGccSupportsNoPie :: Bool, + -- commands for particular phases + sPgm_L :: String, + sPgm_P :: (String,[Option]), + sPgm_F :: String, + sPgm_c :: (String,[Option]), + sPgm_a :: (String,[Option]), + sPgm_l :: (String,[Option]), + sPgm_dll :: (String,[Option]), + sPgm_T :: String, + sPgm_windres :: String, + sPgm_libtool :: String, + sPgm_ar :: String, + sPgm_ranlib :: String, + sPgm_lo :: (String,[Option]), -- LLVM: opt llvm optimiser + sPgm_lc :: (String,[Option]), -- LLVM: llc static compiler + sPgm_lcc :: (String,[Option]), -- LLVM: c compiler + sPgm_i :: String, + -- options for particular phases + sOpt_L :: [String], + sOpt_P :: [String], + sOpt_P_fingerprint :: Fingerprint, -- cached Fingerprint of sOpt_P + -- See Note [Repeated -optP hashing] + sOpt_F :: [String], + sOpt_c :: [String], + sOpt_a :: [String], + sOpt_l :: [String], + sOpt_windres :: [String], + sOpt_lo :: [String], -- LLVM: llvm optimiser + sOpt_lc :: [String], -- LLVM: llc static compiler + sOpt_lcc :: [String], -- LLVM: c compiler + sOpt_i :: [String], -- iserv options + + sPlatformConstants :: PlatformConstants + } + +targetPlatform :: DynFlags -> Platform +targetPlatform dflags = sTargetPlatform (settings dflags) +programName :: DynFlags -> String +programName dflags = sProgramName (settings dflags) +projectVersion :: DynFlags -> String +projectVersion dflags = sProjectVersion (settings dflags) +ghcUsagePath :: DynFlags -> FilePath +ghcUsagePath dflags = sGhcUsagePath (settings dflags) +ghciUsagePath :: DynFlags -> FilePath +ghciUsagePath dflags = sGhciUsagePath (settings dflags) +toolDir :: DynFlags -> Maybe FilePath +toolDir dflags = sToolDir (settings dflags) +topDir :: DynFlags -> FilePath +topDir dflags = sTopDir (settings dflags) +tmpDir :: DynFlags -> String +tmpDir dflags = sTmpDir (settings dflags) +rawSettings :: DynFlags -> [(String, String)] +rawSettings dflags = sRawSettings (settings dflags) +extraGccViaCFlags :: DynFlags -> [String] +extraGccViaCFlags dflags = sExtraGccViaCFlags (settings dflags) +systemPackageConfig :: DynFlags -> FilePath +systemPackageConfig dflags = sSystemPackageConfig (settings dflags) +pgm_L :: DynFlags -> String +pgm_L dflags = sPgm_L (settings dflags) +pgm_P :: DynFlags -> (String,[Option]) +pgm_P dflags = sPgm_P (settings dflags) +pgm_F :: DynFlags -> String +pgm_F dflags = sPgm_F (settings dflags) +pgm_c :: DynFlags -> (String,[Option]) +pgm_c dflags = sPgm_c (settings dflags) +pgm_a :: DynFlags -> (String,[Option]) +pgm_a dflags = sPgm_a (settings dflags) +pgm_l :: DynFlags -> (String,[Option]) +pgm_l dflags = sPgm_l (settings dflags) +pgm_dll :: DynFlags -> (String,[Option]) +pgm_dll dflags = sPgm_dll (settings dflags) +pgm_T :: DynFlags -> String +pgm_T dflags = sPgm_T (settings dflags) +pgm_windres :: DynFlags -> String +pgm_windres dflags = sPgm_windres (settings dflags) +pgm_libtool :: DynFlags -> String +pgm_libtool dflags = sPgm_libtool (settings dflags) +pgm_lcc :: DynFlags -> (String,[Option]) +pgm_lcc dflags = sPgm_lcc (settings dflags) +pgm_ar :: DynFlags -> String +pgm_ar dflags = sPgm_ar (settings dflags) +pgm_ranlib :: DynFlags -> String +pgm_ranlib dflags = sPgm_ranlib (settings dflags) +pgm_lo :: DynFlags -> (String,[Option]) +pgm_lo dflags = sPgm_lo (settings dflags) +pgm_lc :: DynFlags -> (String,[Option]) +pgm_lc dflags = sPgm_lc (settings dflags) +pgm_i :: DynFlags -> String +pgm_i dflags = sPgm_i (settings dflags) +opt_L :: DynFlags -> [String] +opt_L dflags = sOpt_L (settings dflags) +opt_P :: DynFlags -> [String] +opt_P dflags = concatMap (wayOptP (targetPlatform dflags)) (ways dflags) + ++ sOpt_P (settings dflags) + +-- This function packages everything that's needed to fingerprint opt_P +-- flags. See Note [Repeated -optP hashing]. +opt_P_signature :: DynFlags -> ([String], Fingerprint) +opt_P_signature dflags = + ( concatMap (wayOptP (targetPlatform dflags)) (ways dflags) + , sOpt_P_fingerprint (settings dflags)) + +opt_F :: DynFlags -> [String] +opt_F dflags = sOpt_F (settings dflags) +opt_c :: DynFlags -> [String] +opt_c dflags = concatMap (wayOptc (targetPlatform dflags)) (ways dflags) + ++ sOpt_c (settings dflags) +opt_a :: DynFlags -> [String] +opt_a dflags = sOpt_a (settings dflags) +opt_l :: DynFlags -> [String] +opt_l dflags = concatMap (wayOptl (targetPlatform dflags)) (ways dflags) + ++ sOpt_l (settings dflags) +opt_windres :: DynFlags -> [String] +opt_windres dflags = sOpt_windres (settings dflags) +opt_lcc :: DynFlags -> [String] +opt_lcc dflags = sOpt_lcc (settings dflags) +opt_lo :: DynFlags -> [String] +opt_lo dflags = sOpt_lo (settings dflags) +opt_lc :: DynFlags -> [String] +opt_lc dflags = sOpt_lc (settings dflags) +opt_i :: DynFlags -> [String] +opt_i dflags = sOpt_i (settings dflags) + +-- | The directory for this version of ghc in the user's app directory +-- (typically something like @~/.ghc/x86_64-linux-7.6.3@) +-- +versionedAppDir :: DynFlags -> MaybeT IO FilePath +versionedAppDir dflags = do + -- Make sure we handle the case the HOME isn't set (see #11678) + appdir <- tryMaybeT $ getAppUserDataDirectory (programName dflags) + return $ appdir versionedFilePath dflags + +-- | A filepath like @x86_64-linux-7.6.3@ with the platform string to use when +-- constructing platform-version-dependent files that need to co-exist. +-- +versionedFilePath :: DynFlags -> FilePath +versionedFilePath dflags = TARGET_ARCH + ++ '-':TARGET_OS + ++ '-':projectVersion dflags + -- NB: This functionality is reimplemented in Cabal, so if you + -- change it, be sure to update Cabal. + +-- | The target code type of the compilation (if any). +-- +-- Whenever you change the target, also make sure to set 'ghcLink' to +-- something sensible. +-- +-- 'HscNothing' can be used to avoid generating any output, however, note +-- that: +-- +-- * If a program uses Template Haskell the typechecker may need to run code +-- from an imported module. To facilitate this, code generation is enabled +-- for modules imported by modules that use template haskell. +-- See Note [-fno-code mode]. +-- +data HscTarget + = HscC -- ^ Generate C code. + | HscAsm -- ^ Generate assembly using the native code generator. + | HscLlvm -- ^ Generate assembly using the llvm code generator. + | HscInterpreted -- ^ Generate bytecode. (Requires 'LinkInMemory') + | HscNothing -- ^ Don't generate any code. See notes above. + deriving (Eq, Show) + +-- | Will this target result in an object file on the disk? +isObjectTarget :: HscTarget -> Bool +isObjectTarget HscC = True +isObjectTarget HscAsm = True +isObjectTarget HscLlvm = True +isObjectTarget _ = False + +-- | Does this target retain *all* top-level bindings for a module, +-- rather than just the exported bindings, in the TypeEnv and compiled +-- code (if any)? In interpreted mode we do this, so that GHCi can +-- call functions inside a module. In HscNothing mode we also do it, +-- so that Haddock can get access to the GlobalRdrEnv for a module +-- after typechecking it. +targetRetainsAllBindings :: HscTarget -> Bool +targetRetainsAllBindings HscInterpreted = True +targetRetainsAllBindings HscNothing = True +targetRetainsAllBindings _ = False + +-- | The 'GhcMode' tells us whether we're doing multi-module +-- compilation (controlled via the "GHC" API) or one-shot +-- (single-module) compilation. This makes a difference primarily to +-- the "Finder": in one-shot mode we look for interface files for +-- imported modules, but in multi-module mode we look for source files +-- in order to check whether they need to be recompiled. +data GhcMode + = CompManager -- ^ @\-\-make@, GHCi, etc. + | OneShot -- ^ @ghc -c Foo.hs@ + | MkDepend -- ^ @ghc -M@, see "Finder" for why we need this + deriving Eq + +instance Outputable GhcMode where + ppr CompManager = text "CompManager" + ppr OneShot = text "OneShot" + ppr MkDepend = text "MkDepend" + +isOneShot :: GhcMode -> Bool +isOneShot OneShot = True +isOneShot _other = False + +-- | What to do in the link step, if there is one. +data GhcLink + = NoLink -- ^ Don't link at all + | LinkBinary -- ^ Link object code into a binary + | LinkInMemory -- ^ Use the in-memory dynamic linker (works for both + -- bytecode and object code). + | LinkDynLib -- ^ Link objects into a dynamic lib (DLL on Windows, DSO on ELF platforms) + | LinkStaticLib -- ^ Link objects into a static lib + deriving (Eq, Show) + +isNoLink :: GhcLink -> Bool +isNoLink NoLink = True +isNoLink _ = False + +-- | We accept flags which make packages visible, but how they select +-- the package varies; this data type reflects what selection criterion +-- is used. +data PackageArg = + PackageArg String -- ^ @-package@, by 'PackageName' + | UnitIdArg UnitId -- ^ @-package-id@, by 'UnitId' + deriving (Eq, Show) +instance Outputable PackageArg where + ppr (PackageArg pn) = text "package" <+> text pn + ppr (UnitIdArg uid) = text "unit" <+> ppr uid + +-- | Represents the renaming that may be associated with an exposed +-- package, e.g. the @rns@ part of @-package "foo (rns)"@. +-- +-- Here are some example parsings of the package flags (where +-- a string literal is punned to be a 'ModuleName': +-- +-- * @-package foo@ is @ModRenaming True []@ +-- * @-package foo ()@ is @ModRenaming False []@ +-- * @-package foo (A)@ is @ModRenaming False [("A", "A")]@ +-- * @-package foo (A as B)@ is @ModRenaming False [("A", "B")]@ +-- * @-package foo with (A as B)@ is @ModRenaming True [("A", "B")]@ +data ModRenaming = ModRenaming { + modRenamingWithImplicit :: Bool, -- ^ Bring all exposed modules into scope? + modRenamings :: [(ModuleName, ModuleName)] -- ^ Bring module @m@ into scope + -- under name @n@. + } deriving (Eq) +instance Outputable ModRenaming where + ppr (ModRenaming b rns) = ppr b <+> parens (ppr rns) + +-- | Flags for manipulating the set of non-broken packages. +newtype IgnorePackageFlag = IgnorePackage String -- ^ @-ignore-package@ + deriving (Eq) + +-- | Flags for manipulating package trust. +data TrustFlag + = TrustPackage String -- ^ @-trust@ + | DistrustPackage String -- ^ @-distrust@ + deriving (Eq) + +-- | Flags for manipulating packages visibility. +data PackageFlag + = ExposePackage String PackageArg ModRenaming -- ^ @-package@, @-package-id@ + | HidePackage String -- ^ @-hide-package@ + deriving (Eq) -- NB: equality instance is used by packageFlagsChanged + +data PackageDBFlag + = PackageDB PkgConfRef + | NoUserPackageDB + | NoGlobalPackageDB + | ClearPackageDBs + deriving (Eq) + +packageFlagsChanged :: DynFlags -> DynFlags -> Bool +packageFlagsChanged idflags1 idflags0 = + packageFlags idflags1 /= packageFlags idflags0 || + ignorePackageFlags idflags1 /= ignorePackageFlags idflags0 || + pluginPackageFlags idflags1 /= pluginPackageFlags idflags0 || + trustFlags idflags1 /= trustFlags idflags0 || + packageDBFlags idflags1 /= packageDBFlags idflags0 || + packageGFlags idflags1 /= packageGFlags idflags0 + where + packageGFlags dflags = map (`gopt` dflags) + [ Opt_HideAllPackages + , Opt_HideAllPluginPackages + , Opt_AutoLinkPackages ] + +instance Outputable PackageFlag where + ppr (ExposePackage n arg rn) = text n <> braces (ppr arg <+> ppr rn) + ppr (HidePackage str) = text "-hide-package" <+> text str + +defaultHscTarget :: Platform -> HscTarget +defaultHscTarget = defaultObjectTarget + +-- | The 'HscTarget' value corresponding to the default way to create +-- object files on the current platform. +defaultObjectTarget :: Platform -> HscTarget +defaultObjectTarget platform + | platformUnregisterised platform = HscC + | cGhcWithNativeCodeGen == "YES" = HscAsm + | otherwise = HscLlvm + +tablesNextToCode :: DynFlags -> Bool +tablesNextToCode dflags + = mkTablesNextToCode (platformUnregisterised (targetPlatform dflags)) + +-- Determines whether we will be compiling +-- info tables that reside just before the entry code, or with an +-- indirection to the entry code. See TABLES_NEXT_TO_CODE in +-- includes/rts/storage/InfoTables.h. +mkTablesNextToCode :: Bool -> Bool +mkTablesNextToCode unregisterised + = not unregisterised && cGhcEnableTablesNextToCode == "YES" + +data DynLibLoader + = Deployable + | SystemDependent + deriving Eq + +data RtsOptsEnabled + = RtsOptsNone | RtsOptsIgnore | RtsOptsIgnoreAll | RtsOptsSafeOnly + | RtsOptsAll + deriving (Show) + +shouldUseColor :: DynFlags -> Bool +shouldUseColor dflags = overrideWith (canUseColor dflags) (useColor dflags) + +shouldUseHexWordLiterals :: DynFlags -> Bool +shouldUseHexWordLiterals dflags = + Opt_HexWordLiterals `EnumSet.member` generalFlags dflags + +-- | Are we building with @-fPIE@ or @-fPIC@ enabled? +positionIndependent :: DynFlags -> Bool +positionIndependent dflags = gopt Opt_PIC dflags || gopt Opt_PIE dflags + +----------------------------------------------------------------------------- +-- Ways + +-- The central concept of a "way" is that all objects in a given +-- program must be compiled in the same "way". Certain options change +-- parameters of the virtual machine, eg. profiling adds an extra word +-- to the object header, so profiling objects cannot be linked with +-- non-profiling objects. + +-- After parsing the command-line options, we determine which "way" we +-- are building - this might be a combination way, eg. profiling+threaded. + +-- We then find the "build-tag" associated with this way, and this +-- becomes the suffix used to find .hi files and libraries used in +-- this compilation. + +data Way + = WayCustom String -- for GHC API clients building custom variants + | WayThreaded + | WayDebug + | WayProf + | WayEventLog + | WayDyn + deriving (Eq, Ord, Show) + +allowed_combination :: [Way] -> Bool +allowed_combination way = and [ x `allowedWith` y + | x <- way, y <- way, x < y ] + where + -- Note ordering in these tests: the left argument is + -- <= the right argument, according to the Ord instance + -- on Way above. + + -- dyn is allowed with everything + _ `allowedWith` WayDyn = True + WayDyn `allowedWith` _ = True + + -- debug is allowed with everything + _ `allowedWith` WayDebug = True + WayDebug `allowedWith` _ = True + + (WayCustom {}) `allowedWith` _ = True + WayThreaded `allowedWith` WayProf = True + WayThreaded `allowedWith` WayEventLog = True + WayProf `allowedWith` WayEventLog = True + _ `allowedWith` _ = False + +mkBuildTag :: [Way] -> String +mkBuildTag ways = concat (intersperse "_" (map wayTag ways)) + +wayTag :: Way -> String +wayTag (WayCustom xs) = xs +wayTag WayThreaded = "thr" +wayTag WayDebug = "debug" +wayTag WayDyn = "dyn" +wayTag WayProf = "p" +wayTag WayEventLog = "l" + +wayRTSOnly :: Way -> Bool +wayRTSOnly (WayCustom {}) = False +wayRTSOnly WayThreaded = True +wayRTSOnly WayDebug = True +wayRTSOnly WayDyn = False +wayRTSOnly WayProf = False +wayRTSOnly WayEventLog = True + +wayDesc :: Way -> String +wayDesc (WayCustom xs) = xs +wayDesc WayThreaded = "Threaded" +wayDesc WayDebug = "Debug" +wayDesc WayDyn = "Dynamic" +wayDesc WayProf = "Profiling" +wayDesc WayEventLog = "RTS Event Logging" + +-- Turn these flags on when enabling this way +wayGeneralFlags :: Platform -> Way -> [GeneralFlag] +wayGeneralFlags _ (WayCustom {}) = [] +wayGeneralFlags _ WayThreaded = [] +wayGeneralFlags _ WayDebug = [] +wayGeneralFlags _ WayDyn = [Opt_PIC, Opt_ExternalDynamicRefs] + -- We could get away without adding -fPIC when compiling the + -- modules of a program that is to be linked with -dynamic; the + -- program itself does not need to be position-independent, only + -- the libraries need to be. HOWEVER, GHCi links objects into a + -- .so before loading the .so using the system linker. Since only + -- PIC objects can be linked into a .so, we have to compile even + -- modules of the main program with -fPIC when using -dynamic. +wayGeneralFlags _ WayProf = [Opt_SccProfilingOn] +wayGeneralFlags _ WayEventLog = [] + +-- Turn these flags off when enabling this way +wayUnsetGeneralFlags :: Platform -> Way -> [GeneralFlag] +wayUnsetGeneralFlags _ (WayCustom {}) = [] +wayUnsetGeneralFlags _ WayThreaded = [] +wayUnsetGeneralFlags _ WayDebug = [] +wayUnsetGeneralFlags _ WayDyn = [-- There's no point splitting + -- when we're going to be dynamically + -- linking. Plus it breaks compilation + -- on OSX x86. + Opt_SplitSections] +wayUnsetGeneralFlags _ WayProf = [] +wayUnsetGeneralFlags _ WayEventLog = [] + +wayOptc :: Platform -> Way -> [String] +wayOptc _ (WayCustom {}) = [] +wayOptc platform WayThreaded = case platformOS platform of + OSOpenBSD -> ["-pthread"] + OSNetBSD -> ["-pthread"] + _ -> [] +wayOptc _ WayDebug = [] +wayOptc _ WayDyn = [] +wayOptc _ WayProf = ["-DPROFILING"] +wayOptc _ WayEventLog = ["-DTRACING"] + +wayOptl :: Platform -> Way -> [String] +wayOptl _ (WayCustom {}) = [] +wayOptl platform WayThreaded = + case platformOS platform of + OSFreeBSD -> ["-pthread"] + OSOpenBSD -> ["-pthread"] + OSNetBSD -> ["-pthread"] + _ -> [] +wayOptl _ WayDebug = [] +wayOptl _ WayDyn = [] +wayOptl _ WayProf = [] +wayOptl _ WayEventLog = [] + +wayOptP :: Platform -> Way -> [String] +wayOptP _ (WayCustom {}) = [] +wayOptP _ WayThreaded = [] +wayOptP _ WayDebug = [] +wayOptP _ WayDyn = [] +wayOptP _ WayProf = ["-DPROFILING"] +wayOptP _ WayEventLog = ["-DTRACING"] + +whenGeneratingDynamicToo :: MonadIO m => DynFlags -> m () -> m () +whenGeneratingDynamicToo dflags f = ifGeneratingDynamicToo dflags f (return ()) + +ifGeneratingDynamicToo :: MonadIO m => DynFlags -> m a -> m a -> m a +ifGeneratingDynamicToo dflags f g = generateDynamicTooConditional dflags f g g + +whenCannotGenerateDynamicToo :: MonadIO m => DynFlags -> m () -> m () +whenCannotGenerateDynamicToo dflags f + = ifCannotGenerateDynamicToo dflags f (return ()) + +ifCannotGenerateDynamicToo :: MonadIO m => DynFlags -> m a -> m a -> m a +ifCannotGenerateDynamicToo dflags f g + = generateDynamicTooConditional dflags g f g + +generateDynamicTooConditional :: MonadIO m + => DynFlags -> m a -> m a -> m a -> m a +generateDynamicTooConditional dflags canGen cannotGen notTryingToGen + = if gopt Opt_BuildDynamicToo dflags + then do let ref = canGenerateDynamicToo dflags + b <- liftIO $ readIORef ref + if b then canGen else cannotGen + else notTryingToGen + +dynamicTooMkDynamicDynFlags :: DynFlags -> DynFlags +dynamicTooMkDynamicDynFlags dflags0 + = let dflags1 = addWay' WayDyn dflags0 + dflags2 = dflags1 { + outputFile = dynOutputFile dflags1, + hiSuf = dynHiSuf dflags1, + objectSuf = dynObjectSuf dflags1 + } + dflags3 = updateWays dflags2 + dflags4 = gopt_unset dflags3 Opt_BuildDynamicToo + in dflags4 + +----------------------------------------------------------------------------- + +-- | Used by 'GHC.runGhc' to partially initialize a new 'DynFlags' value +initDynFlags :: DynFlags -> IO DynFlags +initDynFlags dflags = do + let -- We can't build with dynamic-too on Windows, as labels before + -- the fork point are different depending on whether we are + -- building dynamically or not. + platformCanGenerateDynamicToo + = platformOS (targetPlatform dflags) /= OSMinGW32 + refCanGenerateDynamicToo <- newIORef platformCanGenerateDynamicToo + refNextTempSuffix <- newIORef 0 + refFilesToClean <- newIORef emptyFilesToClean + refDirsToClean <- newIORef Map.empty + refGeneratedDumps <- newIORef Set.empty + refRtldInfo <- newIORef Nothing + refRtccInfo <- newIORef Nothing + wrapperNum <- newIORef emptyModuleEnv + canUseUnicode <- do let enc = localeEncoding + str = "‘’" + (withCString enc str $ \cstr -> + do str' <- peekCString enc cstr + return (str == str')) + `catchIOError` \_ -> return False + canUseColor <- stderrSupportsAnsiColors + maybeGhcColorsEnv <- lookupEnv "GHC_COLORS" + maybeGhcColoursEnv <- lookupEnv "GHC_COLOURS" + let adjustCols (Just env) = Col.parseScheme env + adjustCols Nothing = id + let (useColor', colScheme') = + (adjustCols maybeGhcColoursEnv . adjustCols maybeGhcColorsEnv) + (useColor dflags, colScheme dflags) + return dflags{ + canGenerateDynamicToo = refCanGenerateDynamicToo, + nextTempSuffix = refNextTempSuffix, + filesToClean = refFilesToClean, + dirsToClean = refDirsToClean, + generatedDumps = refGeneratedDumps, + nextWrapperNum = wrapperNum, + useUnicode = canUseUnicode, + useColor = useColor', + canUseColor = canUseColor, + colScheme = colScheme', + rtldInfo = refRtldInfo, + rtccInfo = refRtccInfo + } + +-- | The normal 'DynFlags'. Note that they are not suitable for use in this form +-- and must be fully initialized by 'GHC.runGhc' first. +defaultDynFlags :: Settings -> LlvmConfig -> DynFlags +defaultDynFlags mySettings (myLlvmTargets, myLlvmPasses) = +-- See Note [Updating flag description in the User's Guide] + DynFlags { + ghcMode = CompManager, + ghcLink = LinkBinary, + hscTarget = defaultHscTarget (sTargetPlatform mySettings), + integerLibrary = cIntegerLibraryType, + verbosity = 0, + optLevel = 0, + debugLevel = 0, + simplPhases = 2, + maxSimplIterations = 4, + maxPmCheckIterations = 2000000, + ruleCheck = Nothing, + inlineCheck = Nothing, + binBlobThreshold = 500000, -- 500K is a good default (see #16190) + maxRelevantBinds = Just 6, + maxValidHoleFits = Just 6, + maxRefHoleFits = Just 6, + refLevelHoleFits = Nothing, + maxUncoveredPatterns = 4, + simplTickFactor = 100, + specConstrThreshold = Just 2000, + specConstrCount = Just 3, + specConstrRecursive = 3, + liberateCaseThreshold = Just 2000, + floatLamArgs = Just 0, -- Default: float only if no fvs + liftLamsRecArgs = Just 5, -- Default: the number of available argument hardware registers on x86_64 + liftLamsNonRecArgs = Just 5, -- Default: the number of available argument hardware registers on x86_64 + liftLamsKnown = False, -- Default: don't turn known calls into unknown ones + cmmProcAlignment = Nothing, + + historySize = 20, + strictnessBefore = [], + + parMakeCount = Just 1, + + enableTimeStats = False, + ghcHeapSize = Nothing, + + importPaths = ["."], + mainModIs = mAIN, + mainFunIs = Nothing, + reductionDepth = treatZeroAsInf mAX_REDUCTION_DEPTH, + solverIterations = treatZeroAsInf mAX_SOLVER_ITERATIONS, + + thisInstalledUnitId = toInstalledUnitId mainUnitId, + thisUnitIdInsts_ = Nothing, + thisComponentId_ = Nothing, + + objectDir = Nothing, + dylibInstallName = Nothing, + hiDir = Nothing, + hieDir = Nothing, + stubDir = Nothing, + dumpDir = Nothing, + + objectSuf = phaseInputExt StopLn, + hcSuf = phaseInputExt HCc, + hiSuf = "hi", + hieSuf = "hie", + + canGenerateDynamicToo = panic "defaultDynFlags: No canGenerateDynamicToo", + dynObjectSuf = "dyn_" ++ phaseInputExt StopLn, + dynHiSuf = "dyn_hi", + + pluginModNames = [], + pluginModNameOpts = [], + frontendPluginOpts = [], + cachedPlugins = [], + staticPlugins = [], + hooks = emptyHooks, + + outputFile = Nothing, + dynOutputFile = Nothing, + outputHi = Nothing, + dynLibLoader = SystemDependent, + dumpPrefix = Nothing, + dumpPrefixForce = Nothing, + ldInputs = [], + includePaths = IncludeSpecs [] [], + libraryPaths = [], + frameworkPaths = [], + cmdlineFrameworks = [], + rtsOpts = Nothing, + rtsOptsEnabled = RtsOptsSafeOnly, + rtsOptsSuggestions = True, + + hpcDir = ".hpc", + + packageDBFlags = [], + packageFlags = [], + pluginPackageFlags = [], + ignorePackageFlags = [], + trustFlags = [], + packageEnv = Nothing, + pkgDatabase = Nothing, + -- This gets filled in with GHC.setSessionDynFlags + pkgState = emptyPackageState, + ways = defaultWays mySettings, + buildTag = mkBuildTag (defaultWays mySettings), + splitInfo = Nothing, + settings = mySettings, + llvmTargets = myLlvmTargets, + llvmPasses = myLlvmPasses, + + -- ghc -M values + depMakefile = "Makefile", + depIncludePkgDeps = False, + depExcludeMods = [], + depSuffixes = [], + -- end of ghc -M values + nextTempSuffix = panic "defaultDynFlags: No nextTempSuffix", + filesToClean = panic "defaultDynFlags: No filesToClean", + dirsToClean = panic "defaultDynFlags: No dirsToClean", + generatedDumps = panic "defaultDynFlags: No generatedDumps", + ghcVersionFile = Nothing, + haddockOptions = Nothing, + dumpFlags = EnumSet.empty, + generalFlags = EnumSet.fromList (defaultFlags mySettings), + warningFlags = EnumSet.fromList standardWarnings, + fatalWarningFlags = EnumSet.empty, + ghciScripts = [], + language = Nothing, + safeHaskell = Sf_None, + safeInfer = True, + safeInferred = True, + thOnLoc = noSrcSpan, + newDerivOnLoc = noSrcSpan, + overlapInstLoc = noSrcSpan, + incoherentOnLoc = noSrcSpan, + pkgTrustOnLoc = noSrcSpan, + warnSafeOnLoc = noSrcSpan, + warnUnsafeOnLoc = noSrcSpan, + trustworthyOnLoc = noSrcSpan, + extensions = [], + extensionFlags = flattenExtensionFlags Nothing [], + + -- The ufCreationThreshold threshold must be reasonably high to + -- take account of possible discounts. + -- E.g. 450 is not enough in 'fulsom' for Interval.sqr to inline + -- into Csg.calc (The unfolding for sqr never makes it into the + -- interface file.) + ufCreationThreshold = 750, + ufUseThreshold = 60, + ufFunAppDiscount = 60, + -- Be fairly keen to inline a function if that means + -- we'll be able to pick the right method from a dictionary + ufDictDiscount = 30, + ufKeenessFactor = 1.5, + ufDearOp = 40, + ufVeryAggressive = False, + + maxWorkerArgs = 10, + + ghciHistSize = 50, -- keep a log of length 50 by default + + -- Logging + + log_action = defaultLogAction, + + flushOut = defaultFlushOut, + flushErr = defaultFlushErr, + pprUserLength = 5, + pprCols = 100, + useUnicode = False, + useColor = Auto, + canUseColor = False, + colScheme = Col.defaultScheme, + profAuto = NoProfAuto, + interactivePrint = Nothing, + nextWrapperNum = panic "defaultDynFlags: No nextWrapperNum", + sseVersion = Nothing, + bmiVersion = Nothing, + avx = False, + avx2 = False, + avx512cd = False, + avx512er = False, + avx512f = False, + avx512pf = False, + rtldInfo = panic "defaultDynFlags: no rtldInfo", + rtccInfo = panic "defaultDynFlags: no rtccInfo", + + maxInlineAllocSize = 128, + maxInlineMemcpyInsns = 32, + maxInlineMemsetInsns = 32, + + initialUnique = 0, + uniqueIncrement = 1, + + reverseErrors = False, + maxErrors = Nothing, + cfgWeightInfo = defaultCfgWeights + } + +defaultWays :: Settings -> [Way] +defaultWays settings = if pc_DYNAMIC_BY_DEFAULT (sPlatformConstants settings) + then [WayDyn] + else [] + +interpWays :: [Way] +interpWays + | dynamicGhc = [WayDyn] + | rtsIsProfiled = [WayProf] + | otherwise = [] + +interpreterProfiled :: DynFlags -> Bool +interpreterProfiled dflags + | gopt Opt_ExternalInterpreter dflags = gopt Opt_SccProfilingOn dflags + | otherwise = rtsIsProfiled + +interpreterDynamic :: DynFlags -> Bool +interpreterDynamic dflags + | gopt Opt_ExternalInterpreter dflags = WayDyn `elem` ways dflags + | otherwise = dynamicGhc + +-------------------------------------------------------------------------- +-- +-- Note [JSON Error Messages] +-- +-- When the user requests the compiler output to be dumped as json +-- we used to collect them all in an IORef and then print them at the end. +-- This doesn't work very well with GHCi. (See #14078) So instead we now +-- use the simpler method of just outputting a JSON document inplace to +-- stdout. +-- +-- Before the compiler calls log_action, it has already turned the `ErrMsg` +-- into a formatted message. This means that we lose some possible +-- information to provide to the user but refactoring log_action is quite +-- invasive as it is called in many places. So, for now I left it alone +-- and we can refine its behaviour as users request different output. + +type FatalMessager = String -> IO () + +type LogAction = DynFlags + -> WarnReason + -> Severity + -> SrcSpan + -> PprStyle + -> MsgDoc + -> IO () + +defaultFatalMessager :: FatalMessager +defaultFatalMessager = hPutStrLn stderr + + +-- See Note [JSON Error Messages] +-- +jsonLogAction :: LogAction +jsonLogAction dflags reason severity srcSpan _style msg + = do + defaultLogActionHPutStrDoc dflags stdout (doc $$ text "") + (mkCodeStyle CStyle) + where + doc = renderJSON $ + JSObject [ ( "span", json srcSpan ) + , ( "doc" , JSString (showSDoc dflags msg) ) + , ( "severity", json severity ) + , ( "reason" , json reason ) + ] + + +defaultLogAction :: LogAction +defaultLogAction dflags reason severity srcSpan style msg + = case severity of + SevOutput -> printOut msg style + SevDump -> printOut (msg $$ blankLine) style + SevInteractive -> putStrSDoc msg style + SevInfo -> printErrs msg style + SevFatal -> printErrs msg style + SevWarning -> printWarns + SevError -> printWarns + where + printOut = defaultLogActionHPrintDoc dflags stdout + printErrs = defaultLogActionHPrintDoc dflags stderr + putStrSDoc = defaultLogActionHPutStrDoc dflags stdout + -- Pretty print the warning flag, if any (#10752) + message = mkLocMessageAnn flagMsg severity srcSpan msg + + printWarns = do + hPutChar stderr '\n' + caretDiagnostic <- + if gopt Opt_DiagnosticsShowCaret dflags + then getCaretDiagnostic severity srcSpan + else pure empty + printErrs (message $+$ caretDiagnostic) + (setStyleColoured True style) + -- careful (#2302): printErrs prints in UTF-8, + -- whereas converting to string first and using + -- hPutStr would just emit the low 8 bits of + -- each unicode char. + + flagMsg = + case reason of + NoReason -> Nothing + Reason wflag -> do + spec <- flagSpecOf wflag + return ("-W" ++ flagSpecName spec ++ warnFlagGrp wflag) + ErrReason Nothing -> + return "-Werror" + ErrReason (Just wflag) -> do + spec <- flagSpecOf wflag + return $ + "-W" ++ flagSpecName spec ++ warnFlagGrp wflag ++ + ", -Werror=" ++ flagSpecName spec + + warnFlagGrp flag + | gopt Opt_ShowWarnGroups dflags = + case smallestGroups flag of + [] -> "" + groups -> " (in " ++ intercalate ", " (map ("-W"++) groups) ++ ")" + | otherwise = "" + +-- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline. +defaultLogActionHPrintDoc :: DynFlags -> Handle -> SDoc -> PprStyle -> IO () +defaultLogActionHPrintDoc dflags h d sty + = defaultLogActionHPutStrDoc dflags h (d $$ text "") sty + +defaultLogActionHPutStrDoc :: DynFlags -> Handle -> SDoc -> PprStyle -> IO () +defaultLogActionHPutStrDoc dflags h d sty + -- Don't add a newline at the end, so that successive + -- calls to this log-action can output all on the same line + = printSDoc Pretty.PageMode dflags h sty d + +newtype FlushOut = FlushOut (IO ()) + +defaultFlushOut :: FlushOut +defaultFlushOut = FlushOut $ hFlush stdout + +newtype FlushErr = FlushErr (IO ()) + +defaultFlushErr :: FlushErr +defaultFlushErr = FlushErr $ hFlush stderr + +{- +Note [Verbosity levels] +~~~~~~~~~~~~~~~~~~~~~~~ + 0 | print errors & warnings only + 1 | minimal verbosity: print "compiling M ... done." for each module. + 2 | equivalent to -dshow-passes + 3 | equivalent to existing "ghc -v" + 4 | "ghc -v -ddump-most" + 5 | "ghc -v -ddump-all" +-} + +data OnOff a = On a + | Off a + deriving (Eq, Show) + +instance Outputable a => Outputable (OnOff a) where + ppr (On x) = text "On" <+> ppr x + ppr (Off x) = text "Off" <+> ppr x + +-- OnOffs accumulate in reverse order, so we use foldr in order to +-- process them in the right order +flattenExtensionFlags :: Maybe Language -> [OnOff LangExt.Extension] -> EnumSet LangExt.Extension +flattenExtensionFlags ml = foldr f defaultExtensionFlags + where f (On f) flags = EnumSet.insert f flags + f (Off f) flags = EnumSet.delete f flags + defaultExtensionFlags = EnumSet.fromList (languageExtensions ml) + +languageExtensions :: Maybe Language -> [LangExt.Extension] + +languageExtensions Nothing + -- Nothing => the default case + = LangExt.NondecreasingIndentation -- This has been on by default for some time + : delete LangExt.DatatypeContexts -- The Haskell' committee decided to + -- remove datatype contexts from the + -- language: + -- http://www.haskell.org/pipermail/haskell-prime/2011-January/003335.html + (languageExtensions (Just Haskell2010)) + + -- NB: MonoPatBinds is no longer the default + +languageExtensions (Just Haskell98) + = [LangExt.ImplicitPrelude, + -- See Note [When is StarIsType enabled] + LangExt.StarIsType, + LangExt.MonomorphismRestriction, + LangExt.NPlusKPatterns, + LangExt.DatatypeContexts, + LangExt.TraditionalRecordSyntax, + LangExt.NondecreasingIndentation + -- strictly speaking non-standard, but we always had this + -- on implicitly before the option was added in 7.1, and + -- turning it off breaks code, so we're keeping it on for + -- backwards compatibility. Cabal uses -XHaskell98 by + -- default unless you specify another language. + ] + +languageExtensions (Just Haskell2010) + = [LangExt.ImplicitPrelude, + -- See Note [When is StarIsType enabled] + LangExt.StarIsType, + LangExt.MonomorphismRestriction, + LangExt.DatatypeContexts, + LangExt.TraditionalRecordSyntax, + LangExt.EmptyDataDecls, + LangExt.ForeignFunctionInterface, + LangExt.PatternGuards, + LangExt.DoAndIfThenElse, + LangExt.RelaxedPolyRec] + +hasPprDebug :: DynFlags -> Bool +hasPprDebug = dopt Opt_D_ppr_debug + +hasNoDebugOutput :: DynFlags -> Bool +hasNoDebugOutput = dopt Opt_D_no_debug_output + +hasNoStateHack :: DynFlags -> Bool +hasNoStateHack = gopt Opt_G_NoStateHack + +hasNoOptCoercion :: DynFlags -> Bool +hasNoOptCoercion = gopt Opt_G_NoOptCoercion + + +-- | Test whether a 'DumpFlag' is set +dopt :: DumpFlag -> DynFlags -> Bool +dopt f dflags = (f `EnumSet.member` dumpFlags dflags) + || (verbosity dflags >= 4 && enableIfVerbose f) + where enableIfVerbose Opt_D_dump_tc_trace = False + enableIfVerbose Opt_D_dump_rn_trace = False + enableIfVerbose Opt_D_dump_cs_trace = False + enableIfVerbose Opt_D_dump_if_trace = False + enableIfVerbose Opt_D_dump_vt_trace = False + enableIfVerbose Opt_D_dump_tc = False + enableIfVerbose Opt_D_dump_rn = False + enableIfVerbose Opt_D_dump_shape = False + enableIfVerbose Opt_D_dump_rn_stats = False + enableIfVerbose Opt_D_dump_hi_diffs = False + enableIfVerbose Opt_D_verbose_core2core = False + enableIfVerbose Opt_D_verbose_stg2stg = False + enableIfVerbose Opt_D_dump_splices = False + enableIfVerbose Opt_D_th_dec_file = False + enableIfVerbose Opt_D_dump_rule_firings = False + enableIfVerbose Opt_D_dump_rule_rewrites = False + enableIfVerbose Opt_D_dump_simpl_trace = False + enableIfVerbose Opt_D_dump_rtti = False + enableIfVerbose Opt_D_dump_inlinings = False + enableIfVerbose Opt_D_dump_core_stats = False + enableIfVerbose Opt_D_dump_asm_stats = False + enableIfVerbose Opt_D_dump_types = False + enableIfVerbose Opt_D_dump_simpl_iterations = False + enableIfVerbose Opt_D_dump_ticked = False + enableIfVerbose Opt_D_dump_view_pattern_commoning = False + enableIfVerbose Opt_D_dump_mod_cycles = False + enableIfVerbose Opt_D_dump_mod_map = False + enableIfVerbose Opt_D_dump_ec_trace = False + enableIfVerbose _ = True + +-- | Set a 'DumpFlag' +dopt_set :: DynFlags -> DumpFlag -> DynFlags +dopt_set dfs f = dfs{ dumpFlags = EnumSet.insert f (dumpFlags dfs) } + +-- | Unset a 'DumpFlag' +dopt_unset :: DynFlags -> DumpFlag -> DynFlags +dopt_unset dfs f = dfs{ dumpFlags = EnumSet.delete f (dumpFlags dfs) } + +-- | Test whether a 'GeneralFlag' is set +gopt :: GeneralFlag -> DynFlags -> Bool +gopt f dflags = f `EnumSet.member` generalFlags dflags + +-- | Set a 'GeneralFlag' +gopt_set :: DynFlags -> GeneralFlag -> DynFlags +gopt_set dfs f = dfs{ generalFlags = EnumSet.insert f (generalFlags dfs) } + +-- | Unset a 'GeneralFlag' +gopt_unset :: DynFlags -> GeneralFlag -> DynFlags +gopt_unset dfs f = dfs{ generalFlags = EnumSet.delete f (generalFlags dfs) } + +-- | Test whether a 'WarningFlag' is set +wopt :: WarningFlag -> DynFlags -> Bool +wopt f dflags = f `EnumSet.member` warningFlags dflags + +-- | Set a 'WarningFlag' +wopt_set :: DynFlags -> WarningFlag -> DynFlags +wopt_set dfs f = dfs{ warningFlags = EnumSet.insert f (warningFlags dfs) } + +-- | Unset a 'WarningFlag' +wopt_unset :: DynFlags -> WarningFlag -> DynFlags +wopt_unset dfs f = dfs{ warningFlags = EnumSet.delete f (warningFlags dfs) } + +-- | Test whether a 'WarningFlag' is set as fatal +wopt_fatal :: WarningFlag -> DynFlags -> Bool +wopt_fatal f dflags = f `EnumSet.member` fatalWarningFlags dflags + +-- | Mark a 'WarningFlag' as fatal (do not set the flag) +wopt_set_fatal :: DynFlags -> WarningFlag -> DynFlags +wopt_set_fatal dfs f + = dfs { fatalWarningFlags = EnumSet.insert f (fatalWarningFlags dfs) } + +-- | Mark a 'WarningFlag' as not fatal +wopt_unset_fatal :: DynFlags -> WarningFlag -> DynFlags +wopt_unset_fatal dfs f + = dfs { fatalWarningFlags = EnumSet.delete f (fatalWarningFlags dfs) } + +-- | Test whether a 'LangExt.Extension' is set +xopt :: LangExt.Extension -> DynFlags -> Bool +xopt f dflags = f `EnumSet.member` extensionFlags dflags + +-- | Set a 'LangExt.Extension' +xopt_set :: DynFlags -> LangExt.Extension -> DynFlags +xopt_set dfs f + = let onoffs = On f : extensions dfs + in dfs { extensions = onoffs, + extensionFlags = flattenExtensionFlags (language dfs) onoffs } + +-- | Unset a 'LangExt.Extension' +xopt_unset :: DynFlags -> LangExt.Extension -> DynFlags +xopt_unset dfs f + = let onoffs = Off f : extensions dfs + in dfs { extensions = onoffs, + extensionFlags = flattenExtensionFlags (language dfs) onoffs } + +-- | Set or unset a 'LangExt.Extension', unless it has been explicitly +-- set or unset before. +xopt_set_unlessExplSpec + :: LangExt.Extension + -> (DynFlags -> LangExt.Extension -> DynFlags) + -> DynFlags -> DynFlags +xopt_set_unlessExplSpec ext setUnset dflags = + let referedExts = stripOnOff <$> extensions dflags + stripOnOff (On x) = x + stripOnOff (Off x) = x + in + if ext `elem` referedExts then dflags else setUnset dflags ext + +lang_set :: DynFlags -> Maybe Language -> DynFlags +lang_set dflags lang = + dflags { + language = lang, + extensionFlags = flattenExtensionFlags lang (extensions dflags) + } + +-- | An internal helper to check whether to use unicode syntax for output. +-- +-- Note: You should very likely be using 'Outputable.unicodeSyntax' instead +-- of this function. +useUnicodeSyntax :: DynFlags -> Bool +useUnicodeSyntax = gopt Opt_PrintUnicodeSyntax + +useStarIsType :: DynFlags -> Bool +useStarIsType = xopt LangExt.StarIsType + +-- | Set the Haskell language standard to use +setLanguage :: Language -> DynP () +setLanguage l = upd (`lang_set` Just l) + +-- | Some modules have dependencies on others through the DynFlags rather than textual imports +dynFlagDependencies :: DynFlags -> [ModuleName] +dynFlagDependencies = pluginModNames + +-- | Is the -fpackage-trust mode on +packageTrustOn :: DynFlags -> Bool +packageTrustOn = gopt Opt_PackageTrust + +-- | Is Safe Haskell on in some way (including inference mode) +safeHaskellOn :: DynFlags -> Bool +safeHaskellOn dflags = safeHaskellModeEnabled dflags || safeInferOn dflags + +safeHaskellModeEnabled :: DynFlags -> Bool +safeHaskellModeEnabled dflags = safeHaskell dflags `elem` [Sf_Unsafe, Sf_Trustworthy + , Sf_Safe ] + + +-- | Is the Safe Haskell safe language in use +safeLanguageOn :: DynFlags -> Bool +safeLanguageOn dflags = safeHaskell dflags == Sf_Safe + +-- | Is the Safe Haskell safe inference mode active +safeInferOn :: DynFlags -> Bool +safeInferOn = safeInfer + +-- | Test if Safe Imports are on in some form +safeImportsOn :: DynFlags -> Bool +safeImportsOn dflags = safeHaskell dflags == Sf_Unsafe || + safeHaskell dflags == Sf_Trustworthy || + safeHaskell dflags == Sf_Safe + +-- | Set a 'Safe Haskell' flag +setSafeHaskell :: SafeHaskellMode -> DynP () +setSafeHaskell s = updM f + where f dfs = do + let sf = safeHaskell dfs + safeM <- combineSafeFlags sf s + case s of + Sf_Safe -> return $ dfs { safeHaskell = safeM, safeInfer = False } + -- leave safe inferrence on in Trustworthy mode so we can warn + -- if it could have been inferred safe. + Sf_Trustworthy -> do + l <- getCurLoc + return $ dfs { safeHaskell = safeM, trustworthyOnLoc = l } + -- leave safe inference on in Unsafe mode as well. + _ -> return $ dfs { safeHaskell = safeM } + +-- | Are all direct imports required to be safe for this Safe Haskell mode? +-- Direct imports are when the code explicitly imports a module +safeDirectImpsReq :: DynFlags -> Bool +safeDirectImpsReq d = safeLanguageOn d + +-- | Are all implicit imports required to be safe for this Safe Haskell mode? +-- Implicit imports are things in the prelude. e.g System.IO when print is used. +safeImplicitImpsReq :: DynFlags -> Bool +safeImplicitImpsReq d = safeLanguageOn d + +-- | Combine two Safe Haskell modes correctly. Used for dealing with multiple flags. +-- This makes Safe Haskell very much a monoid but for now I prefer this as I don't +-- want to export this functionality from the module but do want to export the +-- type constructors. +combineSafeFlags :: SafeHaskellMode -> SafeHaskellMode -> DynP SafeHaskellMode +combineSafeFlags a b | a == Sf_None = return b + | b == Sf_None = return a + | a == Sf_Ignore || b == Sf_Ignore = return Sf_Ignore + | a == b = return a + | otherwise = addErr errm >> pure a + where errm = "Incompatible Safe Haskell flags! (" + ++ show a ++ ", " ++ show b ++ ")" + +-- | A list of unsafe flags under Safe Haskell. Tuple elements are: +-- * name of the flag +-- * function to get srcspan that enabled the flag +-- * function to test if the flag is on +-- * function to turn the flag off +unsafeFlags, unsafeFlagsForInfer + :: [(String, DynFlags -> SrcSpan, DynFlags -> Bool, DynFlags -> DynFlags)] +unsafeFlags = [ ("-XGeneralizedNewtypeDeriving", newDerivOnLoc, + xopt LangExt.GeneralizedNewtypeDeriving, + flip xopt_unset LangExt.GeneralizedNewtypeDeriving) + , ("-XTemplateHaskell", thOnLoc, + xopt LangExt.TemplateHaskell, + flip xopt_unset LangExt.TemplateHaskell) + ] +unsafeFlagsForInfer = unsafeFlags + + +-- | Retrieve the options corresponding to a particular @opt_*@ field in the correct order +getOpts :: DynFlags -- ^ 'DynFlags' to retrieve the options from + -> (DynFlags -> [a]) -- ^ Relevant record accessor: one of the @opt_*@ accessors + -> [a] -- ^ Correctly ordered extracted options +getOpts dflags opts = reverse (opts dflags) + -- We add to the options from the front, so we need to reverse the list + +-- | Gets the verbosity flag for the current verbosity level. This is fed to +-- other tools, so GHC-specific verbosity flags like @-ddump-most@ are not included +getVerbFlags :: DynFlags -> [String] +getVerbFlags dflags + | verbosity dflags >= 4 = ["-v"] + | otherwise = [] + +setObjectDir, setHiDir, setHieDir, setStubDir, setDumpDir, setOutputDir, + setDynObjectSuf, setDynHiSuf, + setDylibInstallName, + setObjectSuf, setHiSuf, setHieSuf, setHcSuf, parseDynLibLoaderMode, + setPgmP, addOptl, addOptc, addOptP, + addCmdlineFramework, addHaddockOpts, addGhciScript, + setInteractivePrint + :: String -> DynFlags -> DynFlags +setOutputFile, setDynOutputFile, setOutputHi, setDumpPrefixForce + :: Maybe String -> DynFlags -> DynFlags + +setObjectDir f d = d { objectDir = Just f} +setHiDir f d = d { hiDir = Just f} +setHieDir f d = d { hieDir = Just f} +setStubDir f d = d { stubDir = Just f + , includePaths = addGlobalInclude (includePaths d) [f] } + -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file + -- \#included from the .hc file when compiling via C (i.e. unregisterised + -- builds). +setDumpDir f d = d { dumpDir = Just f} +setOutputDir f = setObjectDir f + . setHieDir f + . setHiDir f + . setStubDir f + . setDumpDir f +setDylibInstallName f d = d { dylibInstallName = Just f} + +setObjectSuf f d = d { objectSuf = f} +setDynObjectSuf f d = d { dynObjectSuf = f} +setHiSuf f d = d { hiSuf = f} +setHieSuf f d = d { hieSuf = f} +setDynHiSuf f d = d { dynHiSuf = f} +setHcSuf f d = d { hcSuf = f} + +setOutputFile f d = d { outputFile = f} +setDynOutputFile f d = d { dynOutputFile = f} +setOutputHi f d = d { outputHi = f} + +setJsonLogAction :: DynFlags -> DynFlags +setJsonLogAction d = d { log_action = jsonLogAction } + +thisComponentId :: DynFlags -> ComponentId +thisComponentId dflags = + case thisComponentId_ dflags of + Just cid -> cid + Nothing -> + case thisUnitIdInsts_ dflags of + Just _ -> + throwGhcException $ CmdLineError ("Use of -instantiated-with requires -this-component-id") + Nothing -> ComponentId (unitIdFS (thisPackage dflags)) + +thisUnitIdInsts :: DynFlags -> [(ModuleName, Module)] +thisUnitIdInsts dflags = + case thisUnitIdInsts_ dflags of + Just insts -> insts + Nothing -> [] + +thisPackage :: DynFlags -> UnitId +thisPackage dflags = + case thisUnitIdInsts_ dflags of + Nothing -> default_uid + Just insts + | all (\(x,y) -> mkHoleModule x == y) insts + -> newUnitId (thisComponentId dflags) insts + | otherwise + -> default_uid + where + default_uid = DefiniteUnitId (DefUnitId (thisInstalledUnitId dflags)) + +parseUnitIdInsts :: String -> [(ModuleName, Module)] +parseUnitIdInsts str = case filter ((=="").snd) (readP_to_S parse str) of + [(r, "")] -> r + _ -> throwGhcException $ CmdLineError ("Can't parse -instantiated-with: " ++ str) + where parse = sepBy parseEntry (R.char ',') + parseEntry = do + n <- parseModuleName + _ <- R.char '=' + m <- parseModuleId + return (n, m) + +setUnitIdInsts :: String -> DynFlags -> DynFlags +setUnitIdInsts s d = + d { thisUnitIdInsts_ = Just (parseUnitIdInsts s) } + +setComponentId :: String -> DynFlags -> DynFlags +setComponentId s d = + d { thisComponentId_ = Just (ComponentId (fsLit s)) } + +addPluginModuleName :: String -> DynFlags -> DynFlags +addPluginModuleName name d = d { pluginModNames = (mkModuleName name) : (pluginModNames d) } + +clearPluginModuleNames :: DynFlags -> DynFlags +clearPluginModuleNames d = + d { pluginModNames = [] + , pluginModNameOpts = [] + , cachedPlugins = [] } + +addPluginModuleNameOption :: String -> DynFlags -> DynFlags +addPluginModuleNameOption optflag d = d { pluginModNameOpts = (mkModuleName m, option) : (pluginModNameOpts d) } + where (m, rest) = break (== ':') optflag + option = case rest of + [] -> "" -- should probably signal an error + (_:plug_opt) -> plug_opt -- ignore the ':' from break + +addFrontendPluginOption :: String -> DynFlags -> DynFlags +addFrontendPluginOption s d = d { frontendPluginOpts = s : frontendPluginOpts d } + +parseDynLibLoaderMode f d = + case splitAt 8 f of + ("deploy", "") -> d { dynLibLoader = Deployable } + ("sysdep", "") -> d { dynLibLoader = SystemDependent } + _ -> throwGhcException (CmdLineError ("Unknown dynlib loader: " ++ f)) + +setDumpPrefixForce f d = d { dumpPrefixForce = f} + +-- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"] +-- Config.hs should really use Option. +setPgmP f = let (pgm:args) = words f in alterSettings (\s -> s { sPgm_P = (pgm, map Option args)}) +addOptl f = alterSettings (\s -> s { sOpt_l = f : sOpt_l s}) +addOptc f = alterSettings (\s -> s { sOpt_c = f : sOpt_c s}) +addOptP f = alterSettings (\s -> s { sOpt_P = f : sOpt_P s + , sOpt_P_fingerprint = fingerprintStrings (f : sOpt_P s) + }) + -- See Note [Repeated -optP hashing] + where + fingerprintStrings ss = fingerprintFingerprints $ map fingerprintString ss + + +setDepMakefile :: FilePath -> DynFlags -> DynFlags +setDepMakefile f d = d { depMakefile = f } + +setDepIncludePkgDeps :: Bool -> DynFlags -> DynFlags +setDepIncludePkgDeps b d = d { depIncludePkgDeps = b } + +addDepExcludeMod :: String -> DynFlags -> DynFlags +addDepExcludeMod m d + = d { depExcludeMods = mkModuleName m : depExcludeMods d } + +addDepSuffix :: FilePath -> DynFlags -> DynFlags +addDepSuffix s d = d { depSuffixes = s : depSuffixes d } + +addCmdlineFramework f d = d { cmdlineFrameworks = f : cmdlineFrameworks d} + +addGhcVersionFile :: FilePath -> DynFlags -> DynFlags +addGhcVersionFile f d = d { ghcVersionFile = Just f } + +addHaddockOpts f d = d { haddockOptions = Just f} + +addGhciScript f d = d { ghciScripts = f : ghciScripts d} + +setInteractivePrint f d = d { interactivePrint = Just f} + +-- ----------------------------------------------------------------------------- +-- Command-line options + +-- | When invoking external tools as part of the compilation pipeline, we +-- pass these a sequence of options on the command-line. Rather than +-- just using a list of Strings, we use a type that allows us to distinguish +-- between filepaths and 'other stuff'. The reason for this is that +-- this type gives us a handle on transforming filenames, and filenames only, +-- to whatever format they're expected to be on a particular platform. +data Option + = FileOption -- an entry that _contains_ filename(s) / filepaths. + String -- a non-filepath prefix that shouldn't be + -- transformed (e.g., "/out=") + String -- the filepath/filename portion + | Option String + deriving ( Eq ) + +showOpt :: Option -> String +showOpt (FileOption pre f) = pre ++ f +showOpt (Option s) = s + +----------------------------------------------------------------------------- +-- Setting the optimisation level + +updOptLevel :: Int -> DynFlags -> DynFlags +-- ^ Sets the 'DynFlags' to be appropriate to the optimisation level +updOptLevel n dfs + = dfs2{ optLevel = final_n } + where + final_n = max 0 (min 2 n) -- Clamp to 0 <= n <= 2 + dfs1 = foldr (flip gopt_unset) dfs remove_gopts + dfs2 = foldr (flip gopt_set) dfs1 extra_gopts + + extra_gopts = [ f | (ns,f) <- optLevelFlags, final_n `elem` ns ] + remove_gopts = [ f | (ns,f) <- optLevelFlags, final_n `notElem` ns ] + +{- ********************************************************************** +%* * + DynFlags parser +%* * +%********************************************************************* -} + +-- ----------------------------------------------------------------------------- +-- Parsing the dynamic flags. + + +-- | Parse dynamic flags from a list of command line arguments. Returns the +-- the parsed 'DynFlags', the left-over arguments, and a list of warnings. +-- Throws a 'UsageError' if errors occurred during parsing (such as unknown +-- flags or missing arguments). +parseDynamicFlagsCmdLine :: MonadIO m => DynFlags -> [Located String] + -> m (DynFlags, [Located String], [Warn]) + -- ^ Updated 'DynFlags', left-over arguments, and + -- list of warnings. +parseDynamicFlagsCmdLine = parseDynamicFlagsFull flagsAll True + + +-- | Like 'parseDynamicFlagsCmdLine' but does not allow the package flags +-- (-package, -hide-package, -ignore-package, -hide-all-packages, -package-db). +-- Used to parse flags set in a modules pragma. +parseDynamicFilePragma :: MonadIO m => DynFlags -> [Located String] + -> m (DynFlags, [Located String], [Warn]) + -- ^ Updated 'DynFlags', left-over arguments, and + -- list of warnings. +parseDynamicFilePragma = parseDynamicFlagsFull flagsDynamic False + + +-- | Parses the dynamically set flags for GHC. This is the most general form of +-- the dynamic flag parser that the other methods simply wrap. It allows +-- saying which flags are valid flags and indicating if we are parsing +-- arguments from the command line or from a file pragma. +parseDynamicFlagsFull :: MonadIO m + => [Flag (CmdLineP DynFlags)] -- ^ valid flags to match against + -> Bool -- ^ are the arguments from the command line? + -> DynFlags -- ^ current dynamic flags + -> [Located String] -- ^ arguments to parse + -> m (DynFlags, [Located String], [Warn]) +parseDynamicFlagsFull activeFlags cmdline dflags0 args = do + let ((leftover, errs, warns), dflags1) + = runCmdLine (processArgs activeFlags args) dflags0 + + -- See Note [Handling errors when parsing commandline flags] + unless (null errs) $ liftIO $ throwGhcExceptionIO $ errorsToGhcException $ + map ((showPpr dflags0 . getLoc &&& unLoc) . errMsg) $ errs + + -- check for disabled flags in safe haskell + let (dflags2, sh_warns) = safeFlagCheck cmdline dflags1 + dflags3 = updateWays dflags2 + theWays = ways dflags3 + + unless (allowed_combination theWays) $ liftIO $ + throwGhcExceptionIO (CmdLineError ("combination not supported: " ++ + intercalate "/" (map wayDesc theWays))) + + let chooseOutput + | isJust (outputFile dflags3) -- Only iff user specified -o ... + , not (isJust (dynOutputFile dflags3)) -- but not -dyno + = return $ dflags3 { dynOutputFile = Just $ dynOut (fromJust $ outputFile dflags3) } + | otherwise + = return dflags3 + where + dynOut = flip addExtension (dynObjectSuf dflags3) . dropExtension + dflags4 <- ifGeneratingDynamicToo dflags3 chooseOutput (return dflags3) + + let (dflags5, consistency_warnings) = makeDynFlagsConsistent dflags4 + + -- Set timer stats & heap size + when (enableTimeStats dflags5) $ liftIO enableTimingStats + case (ghcHeapSize dflags5) of + Just x -> liftIO (setHeapSize x) + _ -> return () + + liftIO $ setUnsafeGlobalDynFlags dflags5 + + let warns' = map (Warn Cmd.NoReason) (consistency_warnings ++ sh_warns) + + return (dflags5, leftover, warns' ++ warns) + +-- | Write an error or warning to the 'LogOutput'. +putLogMsg :: DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle + -> MsgDoc -> IO () +putLogMsg dflags = log_action dflags dflags + +updateWays :: DynFlags -> DynFlags +updateWays dflags + = let theWays = sort $ nub $ ways dflags + in dflags { + ways = theWays, + buildTag = mkBuildTag (filter (not . wayRTSOnly) theWays) + } + +-- | Check (and potentially disable) any extensions that aren't allowed +-- in safe mode. +-- +-- The bool is to indicate if we are parsing command line flags (false means +-- file pragma). This allows us to generate better warnings. +safeFlagCheck :: Bool -> DynFlags -> (DynFlags, [Located String]) +safeFlagCheck _ dflags | safeLanguageOn dflags = (dflagsUnset, warns) + where + -- Handle illegal flags under safe language. + (dflagsUnset, warns) = foldl' check_method (dflags, []) unsafeFlags + + check_method (df, warns) (str,loc,test,fix) + | test df = (fix df, warns ++ safeFailure (loc df) str) + | otherwise = (df, warns) + + safeFailure loc str + = [L loc $ str ++ " is not allowed in Safe Haskell; ignoring " + ++ str] + +safeFlagCheck cmdl dflags = + case (safeInferOn dflags) of + True | safeFlags -> (dflags', warn) + True -> (dflags' { safeInferred = False }, warn) + False -> (dflags', warn) + + where + -- dynflags and warn for when -fpackage-trust by itself with no safe + -- haskell flag + (dflags', warn) + | not (safeHaskellModeEnabled dflags) && not cmdl && packageTrustOn dflags + = (gopt_unset dflags Opt_PackageTrust, pkgWarnMsg) + | otherwise = (dflags, []) + + pkgWarnMsg = [L (pkgTrustOnLoc dflags') $ + "-fpackage-trust ignored;" ++ + " must be specified with a Safe Haskell flag"] + + -- Have we inferred Unsafe? See Note [HscMain . Safe Haskell Inference] + safeFlags = all (\(_,_,t,_) -> not $ t dflags) unsafeFlagsForInfer + + +{- ********************************************************************** +%* * + DynFlags specifications +%* * +%********************************************************************* -} + +-- | All dynamic flags option strings without the deprecated ones. +-- These are the user facing strings for enabling and disabling options. +allNonDeprecatedFlags :: [String] +allNonDeprecatedFlags = allFlagsDeps False + +-- | All flags with possibility to filter deprecated ones +allFlagsDeps :: Bool -> [String] +allFlagsDeps keepDeprecated = [ '-':flagName flag + | (deprecated, flag) <- flagsAllDeps + , keepDeprecated || not (isDeprecated deprecated)] + where isDeprecated Deprecated = True + isDeprecated _ = False + +{- + - Below we export user facing symbols for GHC dynamic flags for use with the + - GHC API. + -} + +-- All dynamic flags present in GHC. +flagsAll :: [Flag (CmdLineP DynFlags)] +flagsAll = map snd flagsAllDeps + +-- All dynamic flags present in GHC with deprecation information. +flagsAllDeps :: [(Deprecation, Flag (CmdLineP DynFlags))] +flagsAllDeps = package_flags_deps ++ dynamic_flags_deps + + +-- All dynamic flags, minus package flags, present in GHC. +flagsDynamic :: [Flag (CmdLineP DynFlags)] +flagsDynamic = map snd dynamic_flags_deps + +-- ALl package flags present in GHC. +flagsPackage :: [Flag (CmdLineP DynFlags)] +flagsPackage = map snd package_flags_deps + +----------------Helpers to make flags and keep deprecation information---------- + +type FlagMaker m = String -> OptKind m -> Flag m +type DynFlagMaker = FlagMaker (CmdLineP DynFlags) +data Deprecation = NotDeprecated | Deprecated deriving (Eq, Ord) + +-- Make a non-deprecated flag +make_ord_flag :: DynFlagMaker -> String -> OptKind (CmdLineP DynFlags) + -> (Deprecation, Flag (CmdLineP DynFlags)) +make_ord_flag fm name kind = (NotDeprecated, fm name kind) + +-- Make a deprecated flag +make_dep_flag :: DynFlagMaker -> String -> OptKind (CmdLineP DynFlags) -> String + -> (Deprecation, Flag (CmdLineP DynFlags)) +make_dep_flag fm name kind message = (Deprecated, + fm name $ add_dep_message kind message) + +add_dep_message :: OptKind (CmdLineP DynFlags) -> String + -> OptKind (CmdLineP DynFlags) +add_dep_message (NoArg f) message = NoArg $ f >> deprecate message +add_dep_message (HasArg f) message = HasArg $ \s -> f s >> deprecate message +add_dep_message (SepArg f) message = SepArg $ \s -> f s >> deprecate message +add_dep_message (Prefix f) message = Prefix $ \s -> f s >> deprecate message +add_dep_message (OptPrefix f) message = + OptPrefix $ \s -> f s >> deprecate message +add_dep_message (OptIntSuffix f) message = + OptIntSuffix $ \oi -> f oi >> deprecate message +add_dep_message (IntSuffix f) message = + IntSuffix $ \i -> f i >> deprecate message +add_dep_message (FloatSuffix f) message = + FloatSuffix $ \fl -> f fl >> deprecate message +add_dep_message (PassFlag f) message = + PassFlag $ \s -> f s >> deprecate message +add_dep_message (AnySuffix f) message = + AnySuffix $ \s -> f s >> deprecate message + +----------------------- The main flags themselves ------------------------------ +-- See Note [Updating flag description in the User's Guide] +-- See Note [Supporting CLI completion] +dynamic_flags_deps :: [(Deprecation, Flag (CmdLineP DynFlags))] +dynamic_flags_deps = [ + make_dep_flag defFlag "n" (NoArg $ return ()) + "The -n flag is deprecated and no longer has any effect" + , make_ord_flag defFlag "cpp" (NoArg (setExtensionFlag LangExt.Cpp)) + , make_ord_flag defFlag "F" (NoArg (setGeneralFlag Opt_Pp)) + , (Deprecated, defFlag "#include" + (HasArg (\_s -> + deprecate ("-#include and INCLUDE pragmas are " ++ + "deprecated: They no longer have any effect")))) + , make_ord_flag defFlag "v" (OptIntSuffix setVerbosity) + + , make_ord_flag defGhcFlag "j" (OptIntSuffix + (\n -> case n of + Just n + | n > 0 -> upd (\d -> d { parMakeCount = Just n }) + | otherwise -> addErr "Syntax: -j[n] where n > 0" + Nothing -> upd (\d -> d { parMakeCount = Nothing }))) + -- When the number of parallel builds + -- is omitted, it is the same + -- as specifing that the number of + -- parallel builds is equal to the + -- result of getNumProcessors + , make_ord_flag defFlag "instantiated-with" (sepArg setUnitIdInsts) + , make_ord_flag defFlag "this-component-id" (sepArg setComponentId) + + -- RTS options ------------------------------------------------------------- + , make_ord_flag defFlag "H" (HasArg (\s -> upd (\d -> + d { ghcHeapSize = Just $ fromIntegral (decodeSize s)}))) + + , make_ord_flag defFlag "Rghc-timing" (NoArg (upd (\d -> + d { enableTimeStats = True }))) + + ------- ways --------------------------------------------------------------- + , make_ord_flag defGhcFlag "prof" (NoArg (addWay WayProf)) + , make_ord_flag defGhcFlag "eventlog" (NoArg (addWay WayEventLog)) + , make_dep_flag defGhcFlag "smp" + (NoArg $ addWay WayThreaded) "Use -threaded instead" + , make_ord_flag defGhcFlag "debug" (NoArg (addWay WayDebug)) + , make_ord_flag defGhcFlag "threaded" (NoArg (addWay WayThreaded)) + + , make_ord_flag defGhcFlag "ticky" + (NoArg (setGeneralFlag Opt_Ticky >> addWay WayDebug)) + + -- -ticky enables ticky-ticky code generation, and also implies -debug which + -- is required to get the RTS ticky support. + + ----- Linker -------------------------------------------------------- + , make_ord_flag defGhcFlag "static" (NoArg removeWayDyn) + , make_ord_flag defGhcFlag "dynamic" (NoArg (addWay WayDyn)) + , make_ord_flag defGhcFlag "rdynamic" $ noArg $ +#if defined(linux_HOST_OS) + addOptl "-rdynamic" +#elif defined (mingw32_HOST_OS) + addOptl "-Wl,--export-all-symbols" +#else + -- ignored for compat w/ gcc: + id +#endif + , make_ord_flag defGhcFlag "relative-dynlib-paths" + (NoArg (setGeneralFlag Opt_RelativeDynlibPaths)) + , make_ord_flag defGhcFlag "copy-libs-when-linking" + (NoArg (setGeneralFlag Opt_SingleLibFolder)) + , make_ord_flag defGhcFlag "pie" (NoArg (setGeneralFlag Opt_PICExecutable)) + , make_ord_flag defGhcFlag "no-pie" (NoArg (unSetGeneralFlag Opt_PICExecutable)) + + ------- Specific phases -------------------------------------------- + -- need to appear before -pgmL to be parsed as LLVM flags. + , make_ord_flag defFlag "pgmlo" + (hasArg (\f -> alterSettings (\s -> s { sPgm_lo = (f,[])}))) + , make_ord_flag defFlag "pgmlc" + (hasArg (\f -> alterSettings (\s -> s { sPgm_lc = (f,[])}))) + , make_ord_flag defFlag "pgmi" + (hasArg (\f -> alterSettings (\s -> s { sPgm_i = f}))) + , make_ord_flag defFlag "pgmL" + (hasArg (\f -> alterSettings (\s -> s { sPgm_L = f}))) + , make_ord_flag defFlag "pgmP" + (hasArg setPgmP) + , make_ord_flag defFlag "pgmF" + (hasArg (\f -> alterSettings (\s -> s { sPgm_F = f}))) + , make_ord_flag defFlag "pgmc" + (hasArg (\f -> alterSettings (\s -> s { sPgm_c = (f,[]), + -- Don't pass -no-pie with -pgmc + -- (see #15319) + sGccSupportsNoPie = False}))) + , make_ord_flag defFlag "pgms" + (HasArg (\_ -> addWarn "Object splitting was removed in GHC 8.8")) + , make_ord_flag defFlag "pgma" + (hasArg (\f -> alterSettings (\s -> s { sPgm_a = (f,[])}))) + , make_ord_flag defFlag "pgml" + (hasArg (\f -> alterSettings (\s -> s { sPgm_l = (f,[])}))) + , make_ord_flag defFlag "pgmdll" + (hasArg (\f -> alterSettings (\s -> s { sPgm_dll = (f,[])}))) + , make_ord_flag defFlag "pgmwindres" + (hasArg (\f -> alterSettings (\s -> s { sPgm_windres = f}))) + , make_ord_flag defFlag "pgmlibtool" + (hasArg (\f -> alterSettings (\s -> s { sPgm_libtool = f}))) + , make_ord_flag defFlag "pgmar" + (hasArg (\f -> alterSettings (\s -> s { sPgm_ar = f}))) + , make_ord_flag defFlag "pgmranlib" + (hasArg (\f -> alterSettings (\s -> s { sPgm_ranlib = f}))) + + + -- need to appear before -optl/-opta to be parsed as LLVM flags. + , make_ord_flag defFlag "optlo" + (hasArg (\f -> alterSettings (\s -> s { sOpt_lo = f : sOpt_lo s}))) + , make_ord_flag defFlag "optlc" + (hasArg (\f -> alterSettings (\s -> s { sOpt_lc = f : sOpt_lc s}))) + , make_ord_flag defFlag "opti" + (hasArg (\f -> alterSettings (\s -> s { sOpt_i = f : sOpt_i s}))) + , make_ord_flag defFlag "optL" + (hasArg (\f -> alterSettings (\s -> s { sOpt_L = f : sOpt_L s}))) + , make_ord_flag defFlag "optP" + (hasArg addOptP) + , make_ord_flag defFlag "optF" + (hasArg (\f -> alterSettings (\s -> s { sOpt_F = f : sOpt_F s}))) + , make_ord_flag defFlag "optc" + (hasArg addOptc) + , make_ord_flag defFlag "opta" + (hasArg (\f -> alterSettings (\s -> s { sOpt_a = f : sOpt_a s}))) + , make_ord_flag defFlag "optl" + (hasArg addOptl) + , make_ord_flag defFlag "optwindres" + (hasArg (\f -> + alterSettings (\s -> s { sOpt_windres = f : sOpt_windres s}))) + + , make_ord_flag defGhcFlag "split-objs" + (NoArg $ addWarn "ignoring -split-objs") + + , make_ord_flag defGhcFlag "split-sections" + (noArgM (\dflags -> do + if platformHasSubsectionsViaSymbols (targetPlatform dflags) + then do addErr $ + "-split-sections is not useful on this platform " ++ + "since it always uses subsections via symbols." + return dflags + else return (gopt_set dflags Opt_SplitSections))) + + -------- ghc -M ----------------------------------------------------- + , make_ord_flag defGhcFlag "dep-suffix" (hasArg addDepSuffix) + , make_ord_flag defGhcFlag "dep-makefile" (hasArg setDepMakefile) + , make_ord_flag defGhcFlag "include-pkg-deps" + (noArg (setDepIncludePkgDeps True)) + , make_ord_flag defGhcFlag "exclude-module" (hasArg addDepExcludeMod) + + -------- Linking ---------------------------------------------------- + , make_ord_flag defGhcFlag "no-link" + (noArg (\d -> d { ghcLink=NoLink })) + , make_ord_flag defGhcFlag "shared" + (noArg (\d -> d { ghcLink=LinkDynLib })) + , make_ord_flag defGhcFlag "staticlib" + (noArg (\d -> d { ghcLink=LinkStaticLib })) + , make_ord_flag defGhcFlag "dynload" (hasArg parseDynLibLoaderMode) + , make_ord_flag defGhcFlag "dylib-install-name" (hasArg setDylibInstallName) + + ------- Libraries --------------------------------------------------- + , make_ord_flag defFlag "L" (Prefix addLibraryPath) + , make_ord_flag defFlag "l" (hasArg (addLdInputs . Option . ("-l" ++))) + + ------- Frameworks -------------------------------------------------- + -- -framework-path should really be -F ... + , make_ord_flag defFlag "framework-path" (HasArg addFrameworkPath) + , make_ord_flag defFlag "framework" (hasArg addCmdlineFramework) + + ------- Output Redirection ------------------------------------------ + , make_ord_flag defGhcFlag "odir" (hasArg setObjectDir) + , make_ord_flag defGhcFlag "o" (sepArg (setOutputFile . Just)) + , make_ord_flag defGhcFlag "dyno" + (sepArg (setDynOutputFile . Just)) + , make_ord_flag defGhcFlag "ohi" + (hasArg (setOutputHi . Just )) + , make_ord_flag defGhcFlag "osuf" (hasArg setObjectSuf) + , make_ord_flag defGhcFlag "dynosuf" (hasArg setDynObjectSuf) + , make_ord_flag defGhcFlag "hcsuf" (hasArg setHcSuf) + , make_ord_flag defGhcFlag "hisuf" (hasArg setHiSuf) + , make_ord_flag defGhcFlag "hiesuf" (hasArg setHieSuf) + , make_ord_flag defGhcFlag "dynhisuf" (hasArg setDynHiSuf) + , make_ord_flag defGhcFlag "hidir" (hasArg setHiDir) + , make_ord_flag defGhcFlag "hiedir" (hasArg setHieDir) + , make_ord_flag defGhcFlag "tmpdir" (hasArg setTmpDir) + , make_ord_flag defGhcFlag "stubdir" (hasArg setStubDir) + , make_ord_flag defGhcFlag "dumpdir" (hasArg setDumpDir) + , make_ord_flag defGhcFlag "outputdir" (hasArg setOutputDir) + , make_ord_flag defGhcFlag "ddump-file-prefix" + (hasArg (setDumpPrefixForce . Just)) + + , make_ord_flag defGhcFlag "dynamic-too" + (NoArg (setGeneralFlag Opt_BuildDynamicToo)) + + ------- Keeping temporary files ------------------------------------- + -- These can be singular (think ghc -c) or plural (think ghc --make) + , make_ord_flag defGhcFlag "keep-hc-file" + (NoArg (setGeneralFlag Opt_KeepHcFiles)) + , make_ord_flag defGhcFlag "keep-hc-files" + (NoArg (setGeneralFlag Opt_KeepHcFiles)) + , make_ord_flag defGhcFlag "keep-hscpp-file" + (NoArg (setGeneralFlag Opt_KeepHscppFiles)) + , make_ord_flag defGhcFlag "keep-hscpp-files" + (NoArg (setGeneralFlag Opt_KeepHscppFiles)) + , make_ord_flag defGhcFlag "keep-s-file" + (NoArg (setGeneralFlag Opt_KeepSFiles)) + , make_ord_flag defGhcFlag "keep-s-files" + (NoArg (setGeneralFlag Opt_KeepSFiles)) + , make_ord_flag defGhcFlag "keep-llvm-file" + (NoArg $ setObjTarget HscLlvm >> setGeneralFlag Opt_KeepLlvmFiles) + , make_ord_flag defGhcFlag "keep-llvm-files" + (NoArg $ setObjTarget HscLlvm >> setGeneralFlag Opt_KeepLlvmFiles) + -- This only makes sense as plural + , make_ord_flag defGhcFlag "keep-tmp-files" + (NoArg (setGeneralFlag Opt_KeepTmpFiles)) + , make_ord_flag defGhcFlag "keep-hi-file" + (NoArg (setGeneralFlag Opt_KeepHiFiles)) + , make_ord_flag defGhcFlag "no-keep-hi-file" + (NoArg (unSetGeneralFlag Opt_KeepHiFiles)) + , make_ord_flag defGhcFlag "keep-hi-files" + (NoArg (setGeneralFlag Opt_KeepHiFiles)) + , make_ord_flag defGhcFlag "no-keep-hi-files" + (NoArg (unSetGeneralFlag Opt_KeepHiFiles)) + , make_ord_flag defGhcFlag "keep-o-file" + (NoArg (setGeneralFlag Opt_KeepOFiles)) + , make_ord_flag defGhcFlag "no-keep-o-file" + (NoArg (unSetGeneralFlag Opt_KeepOFiles)) + , make_ord_flag defGhcFlag "keep-o-files" + (NoArg (setGeneralFlag Opt_KeepOFiles)) + , make_ord_flag defGhcFlag "no-keep-o-files" + (NoArg (unSetGeneralFlag Opt_KeepOFiles)) + + ------- Miscellaneous ---------------------------------------------- + , make_ord_flag defGhcFlag "no-auto-link-packages" + (NoArg (unSetGeneralFlag Opt_AutoLinkPackages)) + , make_ord_flag defGhcFlag "no-hs-main" + (NoArg (setGeneralFlag Opt_NoHsMain)) + , make_ord_flag defGhcFlag "fno-state-hack" + (NoArg (setGeneralFlag Opt_G_NoStateHack)) + , make_ord_flag defGhcFlag "fno-opt-coercion" + (NoArg (setGeneralFlag Opt_G_NoOptCoercion)) + , make_ord_flag defGhcFlag "with-rtsopts" + (HasArg setRtsOpts) + , make_ord_flag defGhcFlag "rtsopts" + (NoArg (setRtsOptsEnabled RtsOptsAll)) + , make_ord_flag defGhcFlag "rtsopts=all" + (NoArg (setRtsOptsEnabled RtsOptsAll)) + , make_ord_flag defGhcFlag "rtsopts=some" + (NoArg (setRtsOptsEnabled RtsOptsSafeOnly)) + , make_ord_flag defGhcFlag "rtsopts=none" + (NoArg (setRtsOptsEnabled RtsOptsNone)) + , make_ord_flag defGhcFlag "rtsopts=ignore" + (NoArg (setRtsOptsEnabled RtsOptsIgnore)) + , make_ord_flag defGhcFlag "rtsopts=ignoreAll" + (NoArg (setRtsOptsEnabled RtsOptsIgnoreAll)) + , make_ord_flag defGhcFlag "no-rtsopts" + (NoArg (setRtsOptsEnabled RtsOptsNone)) + , make_ord_flag defGhcFlag "no-rtsopts-suggestions" + (noArg (\d -> d {rtsOptsSuggestions = False})) + , make_ord_flag defGhcFlag "dhex-word-literals" + (NoArg (setGeneralFlag Opt_HexWordLiterals)) + + , make_ord_flag defGhcFlag "ghcversion-file" (hasArg addGhcVersionFile) + , make_ord_flag defGhcFlag "main-is" (SepArg setMainIs) + , make_ord_flag defGhcFlag "haddock" (NoArg (setGeneralFlag Opt_Haddock)) + , make_ord_flag defGhcFlag "haddock-opts" (hasArg addHaddockOpts) + , make_ord_flag defGhcFlag "hpcdir" (SepArg setOptHpcDir) + , make_ord_flag defGhciFlag "ghci-script" (hasArg addGhciScript) + , make_ord_flag defGhciFlag "interactive-print" (hasArg setInteractivePrint) + , make_ord_flag defGhcFlag "ticky-allocd" + (NoArg (setGeneralFlag Opt_Ticky_Allocd)) + , make_ord_flag defGhcFlag "ticky-LNE" + (NoArg (setGeneralFlag Opt_Ticky_LNE)) + , make_ord_flag defGhcFlag "ticky-dyn-thunk" + (NoArg (setGeneralFlag Opt_Ticky_Dyn_Thunk)) + ------- recompilation checker -------------------------------------- + , make_dep_flag defGhcFlag "recomp" + (NoArg $ unSetGeneralFlag Opt_ForceRecomp) + "Use -fno-force-recomp instead" + , make_dep_flag defGhcFlag "no-recomp" + (NoArg $ setGeneralFlag Opt_ForceRecomp) "Use -fforce-recomp instead" + , make_ord_flag defFlag "fmax-errors" + (intSuffix (\n d -> d { maxErrors = Just (max 1 n) })) + , make_ord_flag defFlag "fno-max-errors" + (noArg (\d -> d { maxErrors = Nothing })) + , make_ord_flag defFlag "freverse-errors" + (noArg (\d -> d {reverseErrors = True} )) + , make_ord_flag defFlag "fno-reverse-errors" + (noArg (\d -> d {reverseErrors = False} )) + + ------ HsCpp opts --------------------------------------------------- + , make_ord_flag defFlag "D" (AnySuffix (upd . addOptP)) + , make_ord_flag defFlag "U" (AnySuffix (upd . addOptP)) + + ------- Include/Import Paths ---------------------------------------- + , make_ord_flag defFlag "I" (Prefix addIncludePath) + , make_ord_flag defFlag "i" (OptPrefix addImportPath) + + ------ Output style options ----------------------------------------- + , make_ord_flag defFlag "dppr-user-length" (intSuffix (\n d -> + d { pprUserLength = n })) + , make_ord_flag defFlag "dppr-cols" (intSuffix (\n d -> + d { pprCols = n })) + , make_ord_flag defFlag "fdiagnostics-color=auto" + (NoArg (upd (\d -> d { useColor = Auto }))) + , make_ord_flag defFlag "fdiagnostics-color=always" + (NoArg (upd (\d -> d { useColor = Always }))) + , make_ord_flag defFlag "fdiagnostics-color=never" + (NoArg (upd (\d -> d { useColor = Never }))) + + -- Suppress all that is suppressable in core dumps. + -- Except for uniques, as some simplifier phases introduce new variables that + -- have otherwise identical names. + , make_ord_flag defGhcFlag "dsuppress-all" + (NoArg $ do setGeneralFlag Opt_SuppressCoercions + setGeneralFlag Opt_SuppressVarKinds + setGeneralFlag Opt_SuppressModulePrefixes + setGeneralFlag Opt_SuppressTypeApplications + setGeneralFlag Opt_SuppressIdInfo + setGeneralFlag Opt_SuppressTicks + setGeneralFlag Opt_SuppressStgExts + setGeneralFlag Opt_SuppressTypeSignatures + setGeneralFlag Opt_SuppressTimestamps) + + ------ Debugging ---------------------------------------------------- + , make_ord_flag defGhcFlag "dstg-stats" + (NoArg (setGeneralFlag Opt_StgStats)) + + , make_ord_flag defGhcFlag "ddump-cmm" + (setDumpFlag Opt_D_dump_cmm) + , make_ord_flag defGhcFlag "ddump-cmm-from-stg" + (setDumpFlag Opt_D_dump_cmm_from_stg) + , make_ord_flag defGhcFlag "ddump-cmm-raw" + (setDumpFlag Opt_D_dump_cmm_raw) + , make_ord_flag defGhcFlag "ddump-cmm-verbose" + (setDumpFlag Opt_D_dump_cmm_verbose) + , make_ord_flag defGhcFlag "ddump-cmm-cfg" + (setDumpFlag Opt_D_dump_cmm_cfg) + , make_ord_flag defGhcFlag "ddump-cmm-cbe" + (setDumpFlag Opt_D_dump_cmm_cbe) + , make_ord_flag defGhcFlag "ddump-cmm-switch" + (setDumpFlag Opt_D_dump_cmm_switch) + , make_ord_flag defGhcFlag "ddump-cmm-proc" + (setDumpFlag Opt_D_dump_cmm_proc) + , make_ord_flag defGhcFlag "ddump-cmm-sp" + (setDumpFlag Opt_D_dump_cmm_sp) + , make_ord_flag defGhcFlag "ddump-cmm-sink" + (setDumpFlag Opt_D_dump_cmm_sink) + , make_ord_flag defGhcFlag "ddump-cmm-caf" + (setDumpFlag Opt_D_dump_cmm_caf) + , make_ord_flag defGhcFlag "ddump-cmm-procmap" + (setDumpFlag Opt_D_dump_cmm_procmap) + , make_ord_flag defGhcFlag "ddump-cmm-split" + (setDumpFlag Opt_D_dump_cmm_split) + , make_ord_flag defGhcFlag "ddump-cmm-info" + (setDumpFlag Opt_D_dump_cmm_info) + , make_ord_flag defGhcFlag "ddump-cmm-cps" + (setDumpFlag Opt_D_dump_cmm_cps) + , make_ord_flag defGhcFlag "ddump-cfg-weights" + (setDumpFlag Opt_D_dump_cfg_weights) + , make_ord_flag defGhcFlag "ddump-core-stats" + (setDumpFlag Opt_D_dump_core_stats) + , make_ord_flag defGhcFlag "ddump-asm" + (setDumpFlag Opt_D_dump_asm) + , make_ord_flag defGhcFlag "ddump-asm-native" + (setDumpFlag Opt_D_dump_asm_native) + , make_ord_flag defGhcFlag "ddump-asm-liveness" + (setDumpFlag Opt_D_dump_asm_liveness) + , make_ord_flag defGhcFlag "ddump-asm-regalloc" + (setDumpFlag Opt_D_dump_asm_regalloc) + , make_ord_flag defGhcFlag "ddump-asm-conflicts" + (setDumpFlag Opt_D_dump_asm_conflicts) + , make_ord_flag defGhcFlag "ddump-asm-regalloc-stages" + (setDumpFlag Opt_D_dump_asm_regalloc_stages) + , make_ord_flag defGhcFlag "ddump-asm-stats" + (setDumpFlag Opt_D_dump_asm_stats) + , make_ord_flag defGhcFlag "ddump-asm-expanded" + (setDumpFlag Opt_D_dump_asm_expanded) + , make_ord_flag defGhcFlag "ddump-llvm" + (NoArg $ setObjTarget HscLlvm >> setDumpFlag' Opt_D_dump_llvm) + , make_ord_flag defGhcFlag "ddump-deriv" + (setDumpFlag Opt_D_dump_deriv) + , make_ord_flag defGhcFlag "ddump-ds" + (setDumpFlag Opt_D_dump_ds) + , make_ord_flag defGhcFlag "ddump-ds-preopt" + (setDumpFlag Opt_D_dump_ds_preopt) + , make_ord_flag defGhcFlag "ddump-foreign" + (setDumpFlag Opt_D_dump_foreign) + , make_ord_flag defGhcFlag "ddump-inlinings" + (setDumpFlag Opt_D_dump_inlinings) + , make_ord_flag defGhcFlag "ddump-rule-firings" + (setDumpFlag Opt_D_dump_rule_firings) + , make_ord_flag defGhcFlag "ddump-rule-rewrites" + (setDumpFlag Opt_D_dump_rule_rewrites) + , make_ord_flag defGhcFlag "ddump-simpl-trace" + (setDumpFlag Opt_D_dump_simpl_trace) + , make_ord_flag defGhcFlag "ddump-occur-anal" + (setDumpFlag Opt_D_dump_occur_anal) + , make_ord_flag defGhcFlag "ddump-parsed" + (setDumpFlag Opt_D_dump_parsed) + , make_ord_flag defGhcFlag "ddump-parsed-ast" + (setDumpFlag Opt_D_dump_parsed_ast) + , make_ord_flag defGhcFlag "ddump-rn" + (setDumpFlag Opt_D_dump_rn) + , make_ord_flag defGhcFlag "ddump-rn-ast" + (setDumpFlag Opt_D_dump_rn_ast) + , make_ord_flag defGhcFlag "ddump-simpl" + (setDumpFlag Opt_D_dump_simpl) + , make_ord_flag defGhcFlag "ddump-simpl-iterations" + (setDumpFlag Opt_D_dump_simpl_iterations) + , make_ord_flag defGhcFlag "ddump-spec" + (setDumpFlag Opt_D_dump_spec) + , make_ord_flag defGhcFlag "ddump-prep" + (setDumpFlag Opt_D_dump_prep) + , make_ord_flag defGhcFlag "ddump-stg" + (setDumpFlag Opt_D_dump_stg) + , make_ord_flag defGhcFlag "ddump-call-arity" + (setDumpFlag Opt_D_dump_call_arity) + , make_ord_flag defGhcFlag "ddump-exitify" + (setDumpFlag Opt_D_dump_exitify) + , make_ord_flag defGhcFlag "ddump-stranal" + (setDumpFlag Opt_D_dump_stranal) + , make_ord_flag defGhcFlag "ddump-str-signatures" + (setDumpFlag Opt_D_dump_str_signatures) + , make_ord_flag defGhcFlag "ddump-tc" + (setDumpFlag Opt_D_dump_tc) + , make_ord_flag defGhcFlag "ddump-tc-ast" + (setDumpFlag Opt_D_dump_tc_ast) + , make_ord_flag defGhcFlag "ddump-types" + (setDumpFlag Opt_D_dump_types) + , make_ord_flag defGhcFlag "ddump-rules" + (setDumpFlag Opt_D_dump_rules) + , make_ord_flag defGhcFlag "ddump-cse" + (setDumpFlag Opt_D_dump_cse) + , make_ord_flag defGhcFlag "ddump-worker-wrapper" + (setDumpFlag Opt_D_dump_worker_wrapper) + , make_ord_flag defGhcFlag "ddump-rn-trace" + (setDumpFlag Opt_D_dump_rn_trace) + , make_ord_flag defGhcFlag "ddump-shape" + (setDumpFlag Opt_D_dump_shape) + , make_ord_flag defGhcFlag "ddump-if-trace" + (setDumpFlag Opt_D_dump_if_trace) + , make_ord_flag defGhcFlag "ddump-cs-trace" + (setDumpFlag Opt_D_dump_cs_trace) + , make_ord_flag defGhcFlag "ddump-tc-trace" + (NoArg (do setDumpFlag' Opt_D_dump_tc_trace + setDumpFlag' Opt_D_dump_cs_trace)) + , make_ord_flag defGhcFlag "ddump-ec-trace" + (setDumpFlag Opt_D_dump_ec_trace) + , make_ord_flag defGhcFlag "ddump-vt-trace" + (setDumpFlag Opt_D_dump_vt_trace) + , make_ord_flag defGhcFlag "ddump-splices" + (setDumpFlag Opt_D_dump_splices) + , make_ord_flag defGhcFlag "dth-dec-file" + (setDumpFlag Opt_D_th_dec_file) + + , make_ord_flag defGhcFlag "ddump-rn-stats" + (setDumpFlag Opt_D_dump_rn_stats) + , make_ord_flag defGhcFlag "ddump-opt-cmm" + (setDumpFlag Opt_D_dump_opt_cmm) + , make_ord_flag defGhcFlag "ddump-simpl-stats" + (setDumpFlag Opt_D_dump_simpl_stats) + , make_ord_flag defGhcFlag "ddump-bcos" + (setDumpFlag Opt_D_dump_BCOs) + , make_ord_flag defGhcFlag "dsource-stats" + (setDumpFlag Opt_D_source_stats) + , make_ord_flag defGhcFlag "dverbose-core2core" + (NoArg $ setVerbosity (Just 2) >> setVerboseCore2Core) + , make_ord_flag defGhcFlag "dverbose-stg2stg" + (setDumpFlag Opt_D_verbose_stg2stg) + , make_ord_flag defGhcFlag "ddump-hi" + (setDumpFlag Opt_D_dump_hi) + , make_ord_flag defGhcFlag "ddump-minimal-imports" + (NoArg (setGeneralFlag Opt_D_dump_minimal_imports)) + , make_ord_flag defGhcFlag "ddump-hpc" + (setDumpFlag Opt_D_dump_ticked) -- back compat + , make_ord_flag defGhcFlag "ddump-ticked" + (setDumpFlag Opt_D_dump_ticked) + , make_ord_flag defGhcFlag "ddump-mod-cycles" + (setDumpFlag Opt_D_dump_mod_cycles) + , make_ord_flag defGhcFlag "ddump-mod-map" + (setDumpFlag Opt_D_dump_mod_map) + , make_ord_flag defGhcFlag "ddump-timings" + (setDumpFlag Opt_D_dump_timings) + , make_ord_flag defGhcFlag "ddump-view-pattern-commoning" + (setDumpFlag Opt_D_dump_view_pattern_commoning) + , make_ord_flag defGhcFlag "ddump-to-file" + (NoArg (setGeneralFlag Opt_DumpToFile)) + , make_ord_flag defGhcFlag "ddump-hi-diffs" + (setDumpFlag Opt_D_dump_hi_diffs) + , make_ord_flag defGhcFlag "ddump-rtti" + (setDumpFlag Opt_D_dump_rtti) + , make_ord_flag defGhcFlag "dcore-lint" + (NoArg (setGeneralFlag Opt_DoCoreLinting)) + , make_ord_flag defGhcFlag "dstg-lint" + (NoArg (setGeneralFlag Opt_DoStgLinting)) + , make_ord_flag defGhcFlag "dcmm-lint" + (NoArg (setGeneralFlag Opt_DoCmmLinting)) + , make_ord_flag defGhcFlag "dasm-lint" + (NoArg (setGeneralFlag Opt_DoAsmLinting)) + , make_ord_flag defGhcFlag "dannot-lint" + (NoArg (setGeneralFlag Opt_DoAnnotationLinting)) + , make_ord_flag defGhcFlag "dshow-passes" + (NoArg $ forceRecompile >> (setVerbosity $ Just 2)) + , make_ord_flag defGhcFlag "dfaststring-stats" + (NoArg (setGeneralFlag Opt_D_faststring_stats)) + , make_ord_flag defGhcFlag "dno-llvm-mangler" + (NoArg (setGeneralFlag Opt_NoLlvmMangler)) -- hidden flag + , make_ord_flag defGhcFlag "fast-llvm" + (NoArg (setGeneralFlag Opt_FastLlvm)) -- hidden flag + , make_ord_flag defGhcFlag "ddump-debug" + (setDumpFlag Opt_D_dump_debug) + , make_ord_flag defGhcFlag "ddump-json" + (noArg (flip dopt_set Opt_D_dump_json . setJsonLogAction ) ) + , make_ord_flag defGhcFlag "dppr-debug" + (setDumpFlag Opt_D_ppr_debug) + , make_ord_flag defGhcFlag "ddebug-output" + (noArg (flip dopt_unset Opt_D_no_debug_output)) + , make_ord_flag defGhcFlag "dno-debug-output" + (setDumpFlag Opt_D_no_debug_output) + + ------ Machine dependent (-m) stuff --------------------------- + + , make_ord_flag defGhcFlag "msse" (noArg (\d -> + d { sseVersion = Just SSE1 })) + , make_ord_flag defGhcFlag "msse2" (noArg (\d -> + d { sseVersion = Just SSE2 })) + , make_ord_flag defGhcFlag "msse3" (noArg (\d -> + d { sseVersion = Just SSE3 })) + , make_ord_flag defGhcFlag "msse4" (noArg (\d -> + d { sseVersion = Just SSE4 })) + , make_ord_flag defGhcFlag "msse4.2" (noArg (\d -> + d { sseVersion = Just SSE42 })) + , make_ord_flag defGhcFlag "mbmi" (noArg (\d -> + d { bmiVersion = Just BMI1 })) + , make_ord_flag defGhcFlag "mbmi2" (noArg (\d -> + d { bmiVersion = Just BMI2 })) + , make_ord_flag defGhcFlag "mavx" (noArg (\d -> d { avx = True })) + , make_ord_flag defGhcFlag "mavx2" (noArg (\d -> d { avx2 = True })) + , make_ord_flag defGhcFlag "mavx512cd" (noArg (\d -> + d { avx512cd = True })) + , make_ord_flag defGhcFlag "mavx512er" (noArg (\d -> + d { avx512er = True })) + , make_ord_flag defGhcFlag "mavx512f" (noArg (\d -> d { avx512f = True })) + , make_ord_flag defGhcFlag "mavx512pf" (noArg (\d -> + d { avx512pf = True })) + + ------ Warning opts ------------------------------------------------- + , make_ord_flag defFlag "W" (NoArg (mapM_ setWarningFlag minusWOpts)) + , make_ord_flag defFlag "Werror" + (NoArg (do { setGeneralFlag Opt_WarnIsError + ; mapM_ setFatalWarningFlag minusWeverythingOpts })) + , make_ord_flag defFlag "Wwarn" + (NoArg (do { unSetGeneralFlag Opt_WarnIsError + ; mapM_ unSetFatalWarningFlag minusWeverythingOpts })) + -- Opt_WarnIsError is still needed to pass -Werror + -- to CPP; see runCpp in SysTools + , make_dep_flag defFlag "Wnot" (NoArg (upd (\d -> + d {warningFlags = EnumSet.empty}))) + "Use -w or -Wno-everything instead" + , make_ord_flag defFlag "w" (NoArg (upd (\d -> + d {warningFlags = EnumSet.empty}))) + + -- New-style uniform warning sets + -- + -- Note that -Weverything > -Wall > -Wextra > -Wdefault > -Wno-everything + , make_ord_flag defFlag "Weverything" (NoArg (mapM_ + setWarningFlag minusWeverythingOpts)) + , make_ord_flag defFlag "Wno-everything" + (NoArg (upd (\d -> d {warningFlags = EnumSet.empty}))) + + , make_ord_flag defFlag "Wall" (NoArg (mapM_ + setWarningFlag minusWallOpts)) + , make_ord_flag defFlag "Wno-all" (NoArg (mapM_ + unSetWarningFlag minusWallOpts)) + + , make_ord_flag defFlag "Wextra" (NoArg (mapM_ + setWarningFlag minusWOpts)) + , make_ord_flag defFlag "Wno-extra" (NoArg (mapM_ + unSetWarningFlag minusWOpts)) + + , make_ord_flag defFlag "Wdefault" (NoArg (mapM_ + setWarningFlag standardWarnings)) + , make_ord_flag defFlag "Wno-default" (NoArg (mapM_ + unSetWarningFlag standardWarnings)) + + , make_ord_flag defFlag "Wcompat" (NoArg (mapM_ + setWarningFlag minusWcompatOpts)) + , make_ord_flag defFlag "Wno-compat" (NoArg (mapM_ + unSetWarningFlag minusWcompatOpts)) + + ------ Plugin flags ------------------------------------------------ + , make_ord_flag defGhcFlag "fplugin-opt" (hasArg addPluginModuleNameOption) + , make_ord_flag defGhcFlag "fplugin-trustworthy" + (NoArg (setGeneralFlag Opt_PluginTrustworthy)) + , make_ord_flag defGhcFlag "fplugin" (hasArg addPluginModuleName) + , make_ord_flag defGhcFlag "fclear-plugins" (noArg clearPluginModuleNames) + , make_ord_flag defGhcFlag "ffrontend-opt" (hasArg addFrontendPluginOption) + + ------ Optimisation flags ------------------------------------------ + , make_dep_flag defGhcFlag "Onot" (noArgM $ setOptLevel 0 ) + "Use -O0 instead" + , make_ord_flag defGhcFlag "O" (optIntSuffixM (\mb_n -> + setOptLevel (mb_n `orElse` 1))) + -- If the number is missing, use 1 + + , make_ord_flag defFlag "fbinary-blob-threshold" + (intSuffix (\n d -> d { binBlobThreshold = fromIntegral n })) + + , make_ord_flag defFlag "fmax-relevant-binds" + (intSuffix (\n d -> d { maxRelevantBinds = Just n })) + , make_ord_flag defFlag "fno-max-relevant-binds" + (noArg (\d -> d { maxRelevantBinds = Nothing })) + + , make_ord_flag defFlag "fmax-valid-hole-fits" + (intSuffix (\n d -> d { maxValidHoleFits = Just n })) + , make_ord_flag defFlag "fno-max-valid-hole-fits" + (noArg (\d -> d { maxValidHoleFits = Nothing })) + , make_ord_flag defFlag "fmax-refinement-hole-fits" + (intSuffix (\n d -> d { maxRefHoleFits = Just n })) + , make_ord_flag defFlag "fno-max-refinement-hole-fits" + (noArg (\d -> d { maxRefHoleFits = Nothing })) + , make_ord_flag defFlag "frefinement-level-hole-fits" + (intSuffix (\n d -> d { refLevelHoleFits = Just n })) + , make_ord_flag defFlag "fno-refinement-level-hole-fits" + (noArg (\d -> d { refLevelHoleFits = Nothing })) + + , make_dep_flag defGhcFlag "fllvm-pass-vectors-in-regs" + (noArg id) + "vectors registers are now passed in registers by default." + , make_ord_flag defFlag "fmax-uncovered-patterns" + (intSuffix (\n d -> d { maxUncoveredPatterns = n })) + , make_ord_flag defFlag "fsimplifier-phases" + (intSuffix (\n d -> d { simplPhases = n })) + , make_ord_flag defFlag "fmax-simplifier-iterations" + (intSuffix (\n d -> d { maxSimplIterations = n })) + , make_ord_flag defFlag "fmax-pmcheck-iterations" + (intSuffix (\n d -> d{ maxPmCheckIterations = n })) + , make_ord_flag defFlag "fsimpl-tick-factor" + (intSuffix (\n d -> d { simplTickFactor = n })) + , make_ord_flag defFlag "fspec-constr-threshold" + (intSuffix (\n d -> d { specConstrThreshold = Just n })) + , make_ord_flag defFlag "fno-spec-constr-threshold" + (noArg (\d -> d { specConstrThreshold = Nothing })) + , make_ord_flag defFlag "fspec-constr-count" + (intSuffix (\n d -> d { specConstrCount = Just n })) + , make_ord_flag defFlag "fno-spec-constr-count" + (noArg (\d -> d { specConstrCount = Nothing })) + , make_ord_flag defFlag "fspec-constr-recursive" + (intSuffix (\n d -> d { specConstrRecursive = n })) + , make_ord_flag defFlag "fliberate-case-threshold" + (intSuffix (\n d -> d { liberateCaseThreshold = Just n })) + , make_ord_flag defFlag "fno-liberate-case-threshold" + (noArg (\d -> d { liberateCaseThreshold = Nothing })) + , make_ord_flag defFlag "drule-check" + (sepArg (\s d -> d { ruleCheck = Just s })) + , make_ord_flag defFlag "dinline-check" + (sepArg (\s d -> d { inlineCheck = Just s })) + , make_ord_flag defFlag "freduction-depth" + (intSuffix (\n d -> d { reductionDepth = treatZeroAsInf n })) + , make_ord_flag defFlag "fconstraint-solver-iterations" + (intSuffix (\n d -> d { solverIterations = treatZeroAsInf n })) + , (Deprecated, defFlag "fcontext-stack" + (intSuffixM (\n d -> + do { deprecate $ "use -freduction-depth=" ++ show n ++ " instead" + ; return $ d { reductionDepth = treatZeroAsInf n } }))) + , (Deprecated, defFlag "ftype-function-depth" + (intSuffixM (\n d -> + do { deprecate $ "use -freduction-depth=" ++ show n ++ " instead" + ; return $ d { reductionDepth = treatZeroAsInf n } }))) + , make_ord_flag defFlag "fstrictness-before" + (intSuffix (\n d -> d { strictnessBefore = n : strictnessBefore d })) + , make_ord_flag defFlag "ffloat-lam-args" + (intSuffix (\n d -> d { floatLamArgs = Just n })) + , make_ord_flag defFlag "ffloat-all-lams" + (noArg (\d -> d { floatLamArgs = Nothing })) + , make_ord_flag defFlag "fstg-lift-lams-rec-args" + (intSuffix (\n d -> d { liftLamsRecArgs = Just n })) + , make_ord_flag defFlag "fstg-lift-lams-rec-args-any" + (noArg (\d -> d { liftLamsRecArgs = Nothing })) + , make_ord_flag defFlag "fstg-lift-lams-non-rec-args" + (intSuffix (\n d -> d { liftLamsRecArgs = Just n })) + , make_ord_flag defFlag "fstg-lift-lams-non-rec-args-any" + (noArg (\d -> d { liftLamsRecArgs = Nothing })) + , make_ord_flag defFlag "fstg-lift-lams-known" + (noArg (\d -> d { liftLamsKnown = True })) + , make_ord_flag defFlag "fno-stg-lift-lams-known" + (noArg (\d -> d { liftLamsKnown = False })) + , make_ord_flag defFlag "fproc-alignment" + (intSuffix (\n d -> d { cmmProcAlignment = Just n })) + , make_ord_flag defFlag "fblock-layout-weights" + (HasArg (\s -> + upd (\d -> d { cfgWeightInfo = + parseCfgWeights s (cfgWeightInfo d)}))) + , make_ord_flag defFlag "fhistory-size" + (intSuffix (\n d -> d { historySize = n })) + , make_ord_flag defFlag "funfolding-creation-threshold" + (intSuffix (\n d -> d {ufCreationThreshold = n})) + , make_ord_flag defFlag "funfolding-use-threshold" + (intSuffix (\n d -> d {ufUseThreshold = n})) + , make_ord_flag defFlag "funfolding-fun-discount" + (intSuffix (\n d -> d {ufFunAppDiscount = n})) + , make_ord_flag defFlag "funfolding-dict-discount" + (intSuffix (\n d -> d {ufDictDiscount = n})) + , make_ord_flag defFlag "funfolding-keeness-factor" + (floatSuffix (\n d -> d {ufKeenessFactor = n})) + , make_ord_flag defFlag "fmax-worker-args" + (intSuffix (\n d -> d {maxWorkerArgs = n})) + , make_ord_flag defGhciFlag "fghci-hist-size" + (intSuffix (\n d -> d {ghciHistSize = n})) + , make_ord_flag defGhcFlag "fmax-inline-alloc-size" + (intSuffix (\n d -> d { maxInlineAllocSize = n })) + , make_ord_flag defGhcFlag "fmax-inline-memcpy-insns" + (intSuffix (\n d -> d { maxInlineMemcpyInsns = n })) + , make_ord_flag defGhcFlag "fmax-inline-memset-insns" + (intSuffix (\n d -> d { maxInlineMemsetInsns = n })) + , make_ord_flag defGhcFlag "dinitial-unique" + (intSuffix (\n d -> d { initialUnique = n })) + , make_ord_flag defGhcFlag "dunique-increment" + (intSuffix (\n d -> d { uniqueIncrement = n })) + + ------ Profiling ---------------------------------------------------- + + -- OLD profiling flags + , make_dep_flag defGhcFlag "auto-all" + (noArg (\d -> d { profAuto = ProfAutoAll } )) + "Use -fprof-auto instead" + , make_dep_flag defGhcFlag "no-auto-all" + (noArg (\d -> d { profAuto = NoProfAuto } )) + "Use -fno-prof-auto instead" + , make_dep_flag defGhcFlag "auto" + (noArg (\d -> d { profAuto = ProfAutoExports } )) + "Use -fprof-auto-exported instead" + , make_dep_flag defGhcFlag "no-auto" + (noArg (\d -> d { profAuto = NoProfAuto } )) + "Use -fno-prof-auto instead" + , make_dep_flag defGhcFlag "caf-all" + (NoArg (setGeneralFlag Opt_AutoSccsOnIndividualCafs)) + "Use -fprof-cafs instead" + , make_dep_flag defGhcFlag "no-caf-all" + (NoArg (unSetGeneralFlag Opt_AutoSccsOnIndividualCafs)) + "Use -fno-prof-cafs instead" + + -- NEW profiling flags + , make_ord_flag defGhcFlag "fprof-auto" + (noArg (\d -> d { profAuto = ProfAutoAll } )) + , make_ord_flag defGhcFlag "fprof-auto-top" + (noArg (\d -> d { profAuto = ProfAutoTop } )) + , make_ord_flag defGhcFlag "fprof-auto-exported" + (noArg (\d -> d { profAuto = ProfAutoExports } )) + , make_ord_flag defGhcFlag "fprof-auto-calls" + (noArg (\d -> d { profAuto = ProfAutoCalls } )) + , make_ord_flag defGhcFlag "fno-prof-auto" + (noArg (\d -> d { profAuto = NoProfAuto } )) + + ------ Compiler flags ----------------------------------------------- + + , make_ord_flag defGhcFlag "fasm" (NoArg (setObjTarget HscAsm)) + , make_ord_flag defGhcFlag "fvia-c" (NoArg + (deprecate $ "The -fvia-c flag does nothing; " ++ + "it will be removed in a future GHC release")) + , make_ord_flag defGhcFlag "fvia-C" (NoArg + (deprecate $ "The -fvia-C flag does nothing; " ++ + "it will be removed in a future GHC release")) + , make_ord_flag defGhcFlag "fllvm" (NoArg (setObjTarget HscLlvm)) + + , make_ord_flag defFlag "fno-code" (NoArg ((upd $ \d -> + d { ghcLink=NoLink }) >> setTarget HscNothing)) + , make_ord_flag defFlag "fbyte-code" (NoArg (setTarget HscInterpreted)) + , make_ord_flag defFlag "fobject-code" (NoArg (setTargetWithPlatform + defaultHscTarget)) + , make_dep_flag defFlag "fglasgow-exts" + (NoArg enableGlasgowExts) "Use individual extensions instead" + , make_dep_flag defFlag "fno-glasgow-exts" + (NoArg disableGlasgowExts) "Use individual extensions instead" + , make_ord_flag defFlag "Wunused-binds" (NoArg enableUnusedBinds) + , make_ord_flag defFlag "Wno-unused-binds" (NoArg disableUnusedBinds) + , make_ord_flag defHiddenFlag "fwarn-unused-binds" (NoArg enableUnusedBinds) + , make_ord_flag defHiddenFlag "fno-warn-unused-binds" (NoArg + disableUnusedBinds) + + ------ Safe Haskell flags ------------------------------------------- + , make_ord_flag defFlag "fpackage-trust" (NoArg setPackageTrust) + , make_ord_flag defFlag "fno-safe-infer" (noArg (\d -> + d { safeInfer = False })) + , make_ord_flag defFlag "fno-safe-haskell" (NoArg (setSafeHaskell Sf_Ignore)) + , make_ord_flag defGhcFlag "fPIC" (NoArg (setGeneralFlag Opt_PIC)) + , make_ord_flag defGhcFlag "fno-PIC" (NoArg (unSetGeneralFlag Opt_PIC)) + , make_ord_flag defGhcFlag "fPIE" (NoArg (setGeneralFlag Opt_PIC)) + , make_ord_flag defGhcFlag "fno-PIE" (NoArg (unSetGeneralFlag Opt_PIC)) + + ------ Debugging flags ---------------------------------------------- + , make_ord_flag defGhcFlag "g" (OptIntSuffix setDebugLevel) + ] + ++ map (mkFlag turnOn "" setGeneralFlag ) negatableFlagsDeps + ++ map (mkFlag turnOff "no-" unSetGeneralFlag ) negatableFlagsDeps + ++ map (mkFlag turnOn "d" setGeneralFlag ) dFlagsDeps + ++ map (mkFlag turnOff "dno-" unSetGeneralFlag ) dFlagsDeps + ++ map (mkFlag turnOn "f" setGeneralFlag ) fFlagsDeps + ++ map (mkFlag turnOff "fno-" unSetGeneralFlag ) fFlagsDeps + ++ map (mkFlag turnOn "W" setWarningFlag ) wWarningFlagsDeps + ++ map (mkFlag turnOff "Wno-" unSetWarningFlag ) wWarningFlagsDeps + ++ map (mkFlag turnOn "Werror=" setWErrorFlag ) wWarningFlagsDeps + ++ map (mkFlag turnOn "Wwarn=" unSetFatalWarningFlag ) + wWarningFlagsDeps + ++ map (mkFlag turnOn "Wno-error=" unSetFatalWarningFlag ) + wWarningFlagsDeps + ++ map (mkFlag turnOn "fwarn-" setWarningFlag . hideFlag) + wWarningFlagsDeps + ++ map (mkFlag turnOff "fno-warn-" unSetWarningFlag . hideFlag) + wWarningFlagsDeps + ++ [ (NotDeprecated, unrecognisedWarning "W"), + (Deprecated, unrecognisedWarning "fwarn-"), + (Deprecated, unrecognisedWarning "fno-warn-") ] + ++ [ make_ord_flag defFlag "Werror=compat" + (NoArg (mapM_ setWErrorFlag minusWcompatOpts)) + , make_ord_flag defFlag "Wno-error=compat" + (NoArg (mapM_ unSetFatalWarningFlag minusWcompatOpts)) + , make_ord_flag defFlag "Wwarn=compat" + (NoArg (mapM_ unSetFatalWarningFlag minusWcompatOpts)) ] + ++ map (mkFlag turnOn "f" setExtensionFlag ) fLangFlagsDeps + ++ map (mkFlag turnOff "fno-" unSetExtensionFlag) fLangFlagsDeps + ++ map (mkFlag turnOn "X" setExtensionFlag ) xFlagsDeps + ++ map (mkFlag turnOff "XNo" unSetExtensionFlag) xFlagsDeps + ++ map (mkFlag turnOn "X" setLanguage ) languageFlagsDeps + ++ map (mkFlag turnOn "X" setSafeHaskell ) safeHaskellFlagsDeps + ++ [ make_dep_flag defFlag "XGenerics" + (NoArg $ return ()) + ("it does nothing; look into -XDefaultSignatures " ++ + "and -XDeriveGeneric for generic programming support.") + , make_dep_flag defFlag "XNoGenerics" + (NoArg $ return ()) + ("it does nothing; look into -XDefaultSignatures and " ++ + "-XDeriveGeneric for generic programming support.") ] + +-- | This is where we handle unrecognised warning flags. We only issue a warning +-- if -Wunrecognised-warning-flags is set. See #11429 for context. +unrecognisedWarning :: String -> Flag (CmdLineP DynFlags) +unrecognisedWarning prefix = defHiddenFlag prefix (Prefix action) + where + action :: String -> EwM (CmdLineP DynFlags) () + action flag = do + f <- wopt Opt_WarnUnrecognisedWarningFlags <$> liftEwM getCmdLineState + when f $ addFlagWarn Cmd.ReasonUnrecognisedFlag $ + "unrecognised warning flag: -" ++ prefix ++ flag + +-- See Note [Supporting CLI completion] +package_flags_deps :: [(Deprecation, Flag (CmdLineP DynFlags))] +package_flags_deps = [ + ------- Packages ---------------------------------------------------- + make_ord_flag defFlag "package-db" + (HasArg (addPkgConfRef . PkgConfFile)) + , make_ord_flag defFlag "clear-package-db" (NoArg clearPkgConf) + , make_ord_flag defFlag "no-global-package-db" (NoArg removeGlobalPkgConf) + , make_ord_flag defFlag "no-user-package-db" (NoArg removeUserPkgConf) + , make_ord_flag defFlag "global-package-db" + (NoArg (addPkgConfRef GlobalPkgConf)) + , make_ord_flag defFlag "user-package-db" + (NoArg (addPkgConfRef UserPkgConf)) + -- backwards compat with GHC<=7.4 : + , make_dep_flag defFlag "package-conf" + (HasArg $ addPkgConfRef . PkgConfFile) "Use -package-db instead" + , make_dep_flag defFlag "no-user-package-conf" + (NoArg removeUserPkgConf) "Use -no-user-package-db instead" + , make_ord_flag defGhcFlag "package-name" (HasArg $ \name -> do + upd (setUnitId name)) + -- TODO: Since we JUST deprecated + -- -this-package-key, let's keep this + -- undeprecated for another cycle. + -- Deprecate this eventually. + -- deprecate "Use -this-unit-id instead") + , make_dep_flag defGhcFlag "this-package-key" (HasArg $ upd . setUnitId) + "Use -this-unit-id instead" + , make_ord_flag defGhcFlag "this-unit-id" (hasArg setUnitId) + , make_ord_flag defFlag "package" (HasArg exposePackage) + , make_ord_flag defFlag "plugin-package-id" (HasArg exposePluginPackageId) + , make_ord_flag defFlag "plugin-package" (HasArg exposePluginPackage) + , make_ord_flag defFlag "package-id" (HasArg exposePackageId) + , make_ord_flag defFlag "hide-package" (HasArg hidePackage) + , make_ord_flag defFlag "hide-all-packages" + (NoArg (setGeneralFlag Opt_HideAllPackages)) + , make_ord_flag defFlag "hide-all-plugin-packages" + (NoArg (setGeneralFlag Opt_HideAllPluginPackages)) + , make_ord_flag defFlag "package-env" (HasArg setPackageEnv) + , make_ord_flag defFlag "ignore-package" (HasArg ignorePackage) + , make_dep_flag defFlag "syslib" (HasArg exposePackage) "Use -package instead" + , make_ord_flag defFlag "distrust-all-packages" + (NoArg (setGeneralFlag Opt_DistrustAllPackages)) + , make_ord_flag defFlag "trust" (HasArg trustPackage) + , make_ord_flag defFlag "distrust" (HasArg distrustPackage) + ] + where + setPackageEnv env = upd $ \s -> s { packageEnv = Just env } + +-- | Make a list of flags for shell completion. +-- Filter all available flags into two groups, for interactive GHC vs all other. +flagsForCompletion :: Bool -> [String] +flagsForCompletion isInteractive + = [ '-':flagName flag + | flag <- flagsAll + , modeFilter (flagGhcMode flag) + ] + where + modeFilter AllModes = True + modeFilter OnlyGhci = isInteractive + modeFilter OnlyGhc = not isInteractive + modeFilter HiddenFlag = False + +type TurnOnFlag = Bool -- True <=> we are turning the flag on + -- False <=> we are turning the flag off +turnOn :: TurnOnFlag; turnOn = True +turnOff :: TurnOnFlag; turnOff = False + +data FlagSpec flag + = FlagSpec + { flagSpecName :: String -- ^ Flag in string form + , flagSpecFlag :: flag -- ^ Flag in internal form + , flagSpecAction :: (TurnOnFlag -> DynP ()) + -- ^ Extra action to run when the flag is found + -- Typically, emit a warning or error + , flagSpecGhcMode :: GhcFlagMode + -- ^ In which ghc mode the flag has effect + } + +-- | Define a new flag. +flagSpec :: String -> flag -> (Deprecation, FlagSpec flag) +flagSpec name flag = flagSpec' name flag nop + +-- | Define a new flag with an effect. +flagSpec' :: String -> flag -> (TurnOnFlag -> DynP ()) + -> (Deprecation, FlagSpec flag) +flagSpec' name flag act = (NotDeprecated, FlagSpec name flag act AllModes) + +-- | Define a new deprecated flag with an effect. +depFlagSpecOp :: String -> flag -> (TurnOnFlag -> DynP ()) -> String + -> (Deprecation, FlagSpec flag) +depFlagSpecOp name flag act dep = + (Deprecated, snd (flagSpec' name flag (\f -> act f >> deprecate dep))) + +-- | Define a new deprecated flag. +depFlagSpec :: String -> flag -> String + -> (Deprecation, FlagSpec flag) +depFlagSpec name flag dep = depFlagSpecOp name flag nop dep + +-- | Define a new deprecated flag with an effect where the deprecation message +-- depends on the flag value +depFlagSpecOp' :: String + -> flag + -> (TurnOnFlag -> DynP ()) + -> (TurnOnFlag -> String) + -> (Deprecation, FlagSpec flag) +depFlagSpecOp' name flag act dep = + (Deprecated, FlagSpec name flag (\f -> act f >> (deprecate $ dep f)) + AllModes) + +-- | Define a new deprecated flag where the deprecation message +-- depends on the flag value +depFlagSpec' :: String + -> flag + -> (TurnOnFlag -> String) + -> (Deprecation, FlagSpec flag) +depFlagSpec' name flag dep = depFlagSpecOp' name flag nop dep + + +-- | Define a new deprecated flag where the deprecation message +-- is shown depending on the flag value +depFlagSpecCond :: String + -> flag + -> (TurnOnFlag -> Bool) + -> String + -> (Deprecation, FlagSpec flag) +depFlagSpecCond name flag cond dep = + (Deprecated, FlagSpec name flag (\f -> when (cond f) $ deprecate dep) + AllModes) + +-- | Define a new flag for GHCi. +flagGhciSpec :: String -> flag -> (Deprecation, FlagSpec flag) +flagGhciSpec name flag = flagGhciSpec' name flag nop + +-- | Define a new flag for GHCi with an effect. +flagGhciSpec' :: String -> flag -> (TurnOnFlag -> DynP ()) + -> (Deprecation, FlagSpec flag) +flagGhciSpec' name flag act = (NotDeprecated, FlagSpec name flag act OnlyGhci) + +-- | Define a new flag invisible to CLI completion. +flagHiddenSpec :: String -> flag -> (Deprecation, FlagSpec flag) +flagHiddenSpec name flag = flagHiddenSpec' name flag nop + +-- | Define a new flag invisible to CLI completion with an effect. +flagHiddenSpec' :: String -> flag -> (TurnOnFlag -> DynP ()) + -> (Deprecation, FlagSpec flag) +flagHiddenSpec' name flag act = (NotDeprecated, FlagSpec name flag act + HiddenFlag) + +-- | Hide a 'FlagSpec' from being displayed in @--show-options@. +-- +-- This is for example useful for flags that are obsolete, but should not +-- (yet) be deprecated for compatibility reasons. +hideFlag :: (Deprecation, FlagSpec a) -> (Deprecation, FlagSpec a) +hideFlag (dep, fs) = (dep, fs { flagSpecGhcMode = HiddenFlag }) + +mkFlag :: TurnOnFlag -- ^ True <=> it should be turned on + -> String -- ^ The flag prefix + -> (flag -> DynP ()) -- ^ What to do when the flag is found + -> (Deprecation, FlagSpec flag) -- ^ Specification of + -- this particular flag + -> (Deprecation, Flag (CmdLineP DynFlags)) +mkFlag turn_on flagPrefix f (dep, (FlagSpec name flag extra_action mode)) + = (dep, + Flag (flagPrefix ++ name) (NoArg (f flag >> extra_action turn_on)) mode) + +deprecatedForExtension :: String -> TurnOnFlag -> String +deprecatedForExtension lang turn_on + = "use -X" ++ flag ++ + " or pragma {-# LANGUAGE " ++ flag ++ " #-} instead" + where + flag | turn_on = lang + | otherwise = "No" ++ lang + +useInstead :: String -> String -> TurnOnFlag -> String +useInstead prefix flag turn_on + = "Use " ++ prefix ++ no ++ flag ++ " instead" + where + no = if turn_on then "" else "no-" + +nop :: TurnOnFlag -> DynP () +nop _ = return () + +-- | Find the 'FlagSpec' for a 'WarningFlag'. +flagSpecOf :: WarningFlag -> Maybe (FlagSpec WarningFlag) +flagSpecOf flag = listToMaybe $ filter check wWarningFlags + where + check fs = flagSpecFlag fs == flag + +-- | These @-W\@ flags can all be reversed with @-Wno-\@ +wWarningFlags :: [FlagSpec WarningFlag] +wWarningFlags = map snd (sortBy (comparing fst) wWarningFlagsDeps) + +wWarningFlagsDeps :: [(Deprecation, FlagSpec WarningFlag)] +wWarningFlagsDeps = [ +-- See Note [Updating flag description in the User's Guide] +-- See Note [Supporting CLI completion] +-- Please keep the list of flags below sorted alphabetically + flagSpec "alternative-layout-rule-transitional" + Opt_WarnAlternativeLayoutRuleTransitional, + depFlagSpec "auto-orphans" Opt_WarnAutoOrphans + "it has no effect", + flagSpec "cpp-undef" Opt_WarnCPPUndef, + flagSpec "unbanged-strict-patterns" Opt_WarnUnbangedStrictPatterns, + flagSpec "deferred-type-errors" Opt_WarnDeferredTypeErrors, + flagSpec "deferred-out-of-scope-variables" + Opt_WarnDeferredOutOfScopeVariables, + flagSpec "deprecations" Opt_WarnWarningsDeprecations, + flagSpec "deprecated-flags" Opt_WarnDeprecatedFlags, + flagSpec "deriving-typeable" Opt_WarnDerivingTypeable, + flagSpec "dodgy-exports" Opt_WarnDodgyExports, + flagSpec "dodgy-foreign-imports" Opt_WarnDodgyForeignImports, + flagSpec "dodgy-imports" Opt_WarnDodgyImports, + flagSpec "empty-enumerations" Opt_WarnEmptyEnumerations, + depFlagSpec "duplicate-constraints" Opt_WarnDuplicateConstraints + "it is subsumed by -Wredundant-constraints", + flagSpec "redundant-constraints" Opt_WarnRedundantConstraints, + flagSpec "duplicate-exports" Opt_WarnDuplicateExports, + flagSpec "hi-shadowing" Opt_WarnHiShadows, + flagSpec "inaccessible-code" Opt_WarnInaccessibleCode, + flagSpec "implicit-prelude" Opt_WarnImplicitPrelude, + depFlagSpec "implicit-kind-vars" Opt_WarnImplicitKindVars + "it is now an error", + flagSpec "incomplete-patterns" Opt_WarnIncompletePatterns, + flagSpec "incomplete-record-updates" Opt_WarnIncompletePatternsRecUpd, + flagSpec "incomplete-uni-patterns" Opt_WarnIncompleteUniPatterns, + flagSpec "inline-rule-shadowing" Opt_WarnInlineRuleShadowing, + flagSpec "identities" Opt_WarnIdentities, + flagSpec "missing-fields" Opt_WarnMissingFields, + flagSpec "missing-import-lists" Opt_WarnMissingImportList, + flagSpec "missing-export-lists" Opt_WarnMissingExportList, + depFlagSpec "missing-local-sigs" Opt_WarnMissingLocalSignatures + "it is replaced by -Wmissing-local-signatures", + flagSpec "missing-local-signatures" Opt_WarnMissingLocalSignatures, + flagSpec "missing-methods" Opt_WarnMissingMethods, + flagSpec "missing-monadfail-instances" Opt_WarnMissingMonadFailInstances, + flagSpec "semigroup" Opt_WarnSemigroup, + flagSpec "missing-signatures" Opt_WarnMissingSignatures, + depFlagSpec "missing-exported-sigs" Opt_WarnMissingExportedSignatures + "it is replaced by -Wmissing-exported-signatures", + flagSpec "missing-exported-signatures" Opt_WarnMissingExportedSignatures, + flagSpec "monomorphism-restriction" Opt_WarnMonomorphism, + flagSpec "name-shadowing" Opt_WarnNameShadowing, + flagSpec "noncanonical-monad-instances" + Opt_WarnNonCanonicalMonadInstances, + depFlagSpec "noncanonical-monadfail-instances" + Opt_WarnNonCanonicalMonadInstances + "fail is no longer a method of Monad", + flagSpec "noncanonical-monoid-instances" + Opt_WarnNonCanonicalMonoidInstances, + flagSpec "orphans" Opt_WarnOrphans, + flagSpec "overflowed-literals" Opt_WarnOverflowedLiterals, + flagSpec "overlapping-patterns" Opt_WarnOverlappingPatterns, + flagSpec "missed-specialisations" Opt_WarnMissedSpecs, + flagSpec "missed-specializations" Opt_WarnMissedSpecs, + flagSpec "all-missed-specialisations" Opt_WarnAllMissedSpecs, + flagSpec "all-missed-specializations" Opt_WarnAllMissedSpecs, + flagSpec' "safe" Opt_WarnSafe setWarnSafe, + flagSpec "trustworthy-safe" Opt_WarnTrustworthySafe, + flagSpec "tabs" Opt_WarnTabs, + flagSpec "type-defaults" Opt_WarnTypeDefaults, + flagSpec "typed-holes" Opt_WarnTypedHoles, + flagSpec "partial-type-signatures" Opt_WarnPartialTypeSignatures, + flagSpec "unrecognised-pragmas" Opt_WarnUnrecognisedPragmas, + flagSpec' "unsafe" Opt_WarnUnsafe setWarnUnsafe, + flagSpec "unsupported-calling-conventions" + Opt_WarnUnsupportedCallingConventions, + flagSpec "unsupported-llvm-version" Opt_WarnUnsupportedLlvmVersion, + flagSpec "missed-extra-shared-lib" Opt_WarnMissedExtraSharedLib, + flagSpec "unticked-promoted-constructors" + Opt_WarnUntickedPromotedConstructors, + flagSpec "unused-do-bind" Opt_WarnUnusedDoBind, + flagSpec "unused-foralls" Opt_WarnUnusedForalls, + flagSpec "unused-imports" Opt_WarnUnusedImports, + flagSpec "unused-local-binds" Opt_WarnUnusedLocalBinds, + flagSpec "unused-matches" Opt_WarnUnusedMatches, + flagSpec "unused-pattern-binds" Opt_WarnUnusedPatternBinds, + flagSpec "unused-top-binds" Opt_WarnUnusedTopBinds, + flagSpec "unused-type-patterns" Opt_WarnUnusedTypePatterns, + flagSpec "unused-record-wildcards" Opt_WarnUnusedRecordWildcards, + flagSpec "redundant-record-wildcards" Opt_WarnRedundantRecordWildcards, + flagSpec "warnings-deprecations" Opt_WarnWarningsDeprecations, + flagSpec "wrong-do-bind" Opt_WarnWrongDoBind, + flagSpec "missing-pattern-synonym-signatures" + Opt_WarnMissingPatternSynonymSignatures, + flagSpec "missing-deriving-strategies" Opt_WarnMissingDerivingStrategies, + flagSpec "simplifiable-class-constraints" Opt_WarnSimplifiableClassConstraints, + flagSpec "missing-home-modules" Opt_WarnMissingHomeModules, + flagSpec "unrecognised-warning-flags" Opt_WarnUnrecognisedWarningFlags, + flagSpec "star-binder" Opt_WarnStarBinder, + flagSpec "star-is-type" Opt_WarnStarIsType, + flagSpec "missing-space-after-bang" Opt_WarnSpaceAfterBang, + flagSpec "partial-fields" Opt_WarnPartialFields ] + +-- | These @-\@ flags can all be reversed with @-no-\@ +negatableFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)] +negatableFlagsDeps = [ + flagGhciSpec "ignore-dot-ghci" Opt_IgnoreDotGhci ] + +-- | These @-d\@ flags can all be reversed with @-dno-\@ +dFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)] +dFlagsDeps = [ +-- See Note [Updating flag description in the User's Guide] +-- See Note [Supporting CLI completion] +-- Please keep the list of flags below sorted alphabetically + flagSpec "ppr-case-as-let" Opt_PprCaseAsLet, + depFlagSpec' "ppr-ticks" Opt_PprShowTicks + (\turn_on -> useInstead "-d" "suppress-ticks" (not turn_on)), + flagSpec "suppress-ticks" Opt_SuppressTicks, + depFlagSpec' "suppress-stg-free-vars" Opt_SuppressStgExts + (useInstead "-d" "suppress-stg-exts"), + flagSpec "suppress-stg-exts" Opt_SuppressStgExts, + flagSpec "suppress-coercions" Opt_SuppressCoercions, + flagSpec "suppress-idinfo" Opt_SuppressIdInfo, + flagSpec "suppress-unfoldings" Opt_SuppressUnfoldings, + flagSpec "suppress-module-prefixes" Opt_SuppressModulePrefixes, + flagSpec "suppress-timestamps" Opt_SuppressTimestamps, + flagSpec "suppress-type-applications" Opt_SuppressTypeApplications, + flagSpec "suppress-type-signatures" Opt_SuppressTypeSignatures, + flagSpec "suppress-uniques" Opt_SuppressUniques, + flagSpec "suppress-var-kinds" Opt_SuppressVarKinds + ] + +-- | These @-f\@ flags can all be reversed with @-fno-\@ +fFlags :: [FlagSpec GeneralFlag] +fFlags = map snd fFlagsDeps + +fFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)] +fFlagsDeps = [ +-- See Note [Updating flag description in the User's Guide] +-- See Note [Supporting CLI completion] +-- Please keep the list of flags below sorted alphabetically + flagSpec "asm-shortcutting" Opt_AsmShortcutting, + flagGhciSpec "break-on-error" Opt_BreakOnError, + flagGhciSpec "break-on-exception" Opt_BreakOnException, + flagSpec "building-cabal-package" Opt_BuildingCabalPackage, + flagSpec "call-arity" Opt_CallArity, + flagSpec "exitification" Opt_Exitification, + flagSpec "case-merge" Opt_CaseMerge, + flagSpec "case-folding" Opt_CaseFolding, + flagSpec "cmm-elim-common-blocks" Opt_CmmElimCommonBlocks, + flagSpec "cmm-sink" Opt_CmmSink, + flagSpec "cse" Opt_CSE, + flagSpec "stg-cse" Opt_StgCSE, + flagSpec "stg-lift-lams" Opt_StgLiftLams, + flagSpec "cpr-anal" Opt_CprAnal, + flagSpec "defer-diagnostics" Opt_DeferDiagnostics, + flagSpec "defer-type-errors" Opt_DeferTypeErrors, + flagSpec "defer-typed-holes" Opt_DeferTypedHoles, + flagSpec "defer-out-of-scope-variables" Opt_DeferOutOfScopeVariables, + flagSpec "diagnostics-show-caret" Opt_DiagnosticsShowCaret, + flagSpec "dicts-cheap" Opt_DictsCheap, + flagSpec "dicts-strict" Opt_DictsStrict, + flagSpec "dmd-tx-dict-sel" Opt_DmdTxDictSel, + flagSpec "do-eta-reduction" Opt_DoEtaReduction, + flagSpec "do-lambda-eta-expansion" Opt_DoLambdaEtaExpansion, + flagSpec "eager-blackholing" Opt_EagerBlackHoling, + flagSpec "embed-manifest" Opt_EmbedManifest, + flagSpec "enable-rewrite-rules" Opt_EnableRewriteRules, + flagSpec "error-spans" Opt_ErrorSpans, + flagSpec "excess-precision" Opt_ExcessPrecision, + flagSpec "expose-all-unfoldings" Opt_ExposeAllUnfoldings, + flagSpec "external-dynamic-refs" Opt_ExternalDynamicRefs, + flagSpec "external-interpreter" Opt_ExternalInterpreter, + flagSpec "flat-cache" Opt_FlatCache, + flagSpec "float-in" Opt_FloatIn, + flagSpec "force-recomp" Opt_ForceRecomp, + flagSpec "ignore-optim-changes" Opt_IgnoreOptimChanges, + flagSpec "ignore-hpc-changes" Opt_IgnoreHpcChanges, + flagSpec "full-laziness" Opt_FullLaziness, + flagSpec "fun-to-thunk" Opt_FunToThunk, + flagSpec "gen-manifest" Opt_GenManifest, + flagSpec "ghci-history" Opt_GhciHistory, + flagSpec "ghci-leak-check" Opt_GhciLeakCheck, + flagSpec "validate-ide-info" Opt_ValidateHie, + flagGhciSpec "local-ghci-history" Opt_LocalGhciHistory, + flagGhciSpec "no-it" Opt_NoIt, + flagSpec "ghci-sandbox" Opt_GhciSandbox, + flagSpec "helpful-errors" Opt_HelpfulErrors, + flagSpec "hpc" Opt_Hpc, + flagSpec "ignore-asserts" Opt_IgnoreAsserts, + flagSpec "ignore-interface-pragmas" Opt_IgnoreInterfacePragmas, + flagGhciSpec "implicit-import-qualified" Opt_ImplicitImportQualified, + flagSpec "irrefutable-tuples" Opt_IrrefutableTuples, + flagSpec "kill-absence" Opt_KillAbsence, + flagSpec "kill-one-shot" Opt_KillOneShot, + flagSpec "late-dmd-anal" Opt_LateDmdAnal, + flagSpec "late-specialise" Opt_LateSpecialise, + flagSpec "liberate-case" Opt_LiberateCase, + flagHiddenSpec "llvm-tbaa" Opt_LlvmTBAA, + flagHiddenSpec "llvm-fill-undef-with-garbage" Opt_LlvmFillUndefWithGarbage, + flagSpec "loopification" Opt_Loopification, + flagSpec "block-layout-cfg" Opt_CfgBlocklayout, + flagSpec "block-layout-weightless" Opt_WeightlessBlocklayout, + flagSpec "omit-interface-pragmas" Opt_OmitInterfacePragmas, + flagSpec "omit-yields" Opt_OmitYields, + flagSpec "optimal-applicative-do" Opt_OptimalApplicativeDo, + flagSpec "pedantic-bottoms" Opt_PedanticBottoms, + flagSpec "pre-inlining" Opt_SimplPreInlining, + flagGhciSpec "print-bind-contents" Opt_PrintBindContents, + flagGhciSpec "print-bind-result" Opt_PrintBindResult, + flagGhciSpec "print-evld-with-show" Opt_PrintEvldWithShow, + flagSpec "print-explicit-foralls" Opt_PrintExplicitForalls, + flagSpec "print-explicit-kinds" Opt_PrintExplicitKinds, + flagSpec "print-explicit-coercions" Opt_PrintExplicitCoercions, + flagSpec "print-explicit-runtime-reps" Opt_PrintExplicitRuntimeReps, + flagSpec "print-equality-relations" Opt_PrintEqualityRelations, + flagSpec "print-unicode-syntax" Opt_PrintUnicodeSyntax, + flagSpec "print-expanded-synonyms" Opt_PrintExpandedSynonyms, + flagSpec "print-potential-instances" Opt_PrintPotentialInstances, + flagSpec "print-typechecker-elaboration" Opt_PrintTypecheckerElaboration, + flagSpec "prof-cafs" Opt_AutoSccsOnIndividualCafs, + flagSpec "prof-count-entries" Opt_ProfCountEntries, + flagSpec "regs-graph" Opt_RegsGraph, + flagSpec "regs-iterative" Opt_RegsIterative, + depFlagSpec' "rewrite-rules" Opt_EnableRewriteRules + (useInstead "-f" "enable-rewrite-rules"), + flagSpec "shared-implib" Opt_SharedImplib, + flagSpec "spec-constr" Opt_SpecConstr, + flagSpec "spec-constr-keen" Opt_SpecConstrKeen, + flagSpec "specialise" Opt_Specialise, + flagSpec "specialize" Opt_Specialise, + flagSpec "specialise-aggressively" Opt_SpecialiseAggressively, + flagSpec "specialize-aggressively" Opt_SpecialiseAggressively, + flagSpec "cross-module-specialise" Opt_CrossModuleSpecialise, + flagSpec "cross-module-specialize" Opt_CrossModuleSpecialise, + flagSpec "static-argument-transformation" Opt_StaticArgumentTransformation, + flagSpec "strictness" Opt_Strictness, + flagSpec "use-rpaths" Opt_RPath, + flagSpec "write-interface" Opt_WriteInterface, + flagSpec "write-ide-info" Opt_WriteHie, + flagSpec "unbox-small-strict-fields" Opt_UnboxSmallStrictFields, + flagSpec "unbox-strict-fields" Opt_UnboxStrictFields, + flagSpec "version-macros" Opt_VersionMacros, + flagSpec "worker-wrapper" Opt_WorkerWrapper, + flagSpec "solve-constant-dicts" Opt_SolveConstantDicts, + flagSpec "catch-bottoms" Opt_CatchBottoms, + flagSpec "alignment-sanitisation" Opt_AlignmentSanitisation, + flagSpec "num-constant-folding" Opt_NumConstantFolding, + flagSpec "show-warning-groups" Opt_ShowWarnGroups, + flagSpec "hide-source-paths" Opt_HideSourcePaths, + flagSpec "show-loaded-modules" Opt_ShowLoadedModules, + flagSpec "whole-archive-hs-libs" Opt_WholeArchiveHsLibs, + flagSpec "keep-cafs" Opt_KeepCAFs + ] + ++ fHoleFlags + +-- | These @-f\@ flags have to do with the typed-hole error message or +-- the valid hole fits in that message. See Note [Valid hole fits include ...] +-- in the TcHoleErrors module. These flags can all be reversed with +-- @-fno-\@ +fHoleFlags :: [(Deprecation, FlagSpec GeneralFlag)] +fHoleFlags = [ + flagSpec "show-hole-constraints" Opt_ShowHoleConstraints, + depFlagSpec' "show-valid-substitutions" Opt_ShowValidHoleFits + (useInstead "-f" "show-valid-hole-fits"), + flagSpec "show-valid-hole-fits" Opt_ShowValidHoleFits, + -- Sorting settings + flagSpec "sort-valid-hole-fits" Opt_SortValidHoleFits, + flagSpec "sort-by-size-hole-fits" Opt_SortBySizeHoleFits, + flagSpec "sort-by-subsumption-hole-fits" Opt_SortBySubsumHoleFits, + flagSpec "abstract-refinement-hole-fits" Opt_AbstractRefHoleFits, + -- Output format settings + flagSpec "show-hole-matches-of-hole-fits" Opt_ShowMatchesOfHoleFits, + flagSpec "show-provenance-of-hole-fits" Opt_ShowProvOfHoleFits, + flagSpec "show-type-of-hole-fits" Opt_ShowTypeOfHoleFits, + flagSpec "show-type-app-of-hole-fits" Opt_ShowTypeAppOfHoleFits, + flagSpec "show-type-app-vars-of-hole-fits" Opt_ShowTypeAppVarsOfHoleFits, + flagSpec "show-docs-of-hole-fits" Opt_ShowDocsOfHoleFits, + flagSpec "unclutter-valid-hole-fits" Opt_UnclutterValidHoleFits + ] + +-- | These @-f\@ flags can all be reversed with @-fno-\@ +fLangFlags :: [FlagSpec LangExt.Extension] +fLangFlags = map snd fLangFlagsDeps + +fLangFlagsDeps :: [(Deprecation, FlagSpec LangExt.Extension)] +fLangFlagsDeps = [ +-- See Note [Updating flag description in the User's Guide] +-- See Note [Supporting CLI completion] + depFlagSpecOp' "th" LangExt.TemplateHaskell + checkTemplateHaskellOk + (deprecatedForExtension "TemplateHaskell"), + depFlagSpec' "fi" LangExt.ForeignFunctionInterface + (deprecatedForExtension "ForeignFunctionInterface"), + depFlagSpec' "ffi" LangExt.ForeignFunctionInterface + (deprecatedForExtension "ForeignFunctionInterface"), + depFlagSpec' "arrows" LangExt.Arrows + (deprecatedForExtension "Arrows"), + depFlagSpec' "implicit-prelude" LangExt.ImplicitPrelude + (deprecatedForExtension "ImplicitPrelude"), + depFlagSpec' "bang-patterns" LangExt.BangPatterns + (deprecatedForExtension "BangPatterns"), + depFlagSpec' "monomorphism-restriction" LangExt.MonomorphismRestriction + (deprecatedForExtension "MonomorphismRestriction"), + depFlagSpec' "mono-pat-binds" LangExt.MonoPatBinds + (deprecatedForExtension "MonoPatBinds"), + depFlagSpec' "extended-default-rules" LangExt.ExtendedDefaultRules + (deprecatedForExtension "ExtendedDefaultRules"), + depFlagSpec' "implicit-params" LangExt.ImplicitParams + (deprecatedForExtension "ImplicitParams"), + depFlagSpec' "scoped-type-variables" LangExt.ScopedTypeVariables + (deprecatedForExtension "ScopedTypeVariables"), + depFlagSpec' "allow-overlapping-instances" LangExt.OverlappingInstances + (deprecatedForExtension "OverlappingInstances"), + depFlagSpec' "allow-undecidable-instances" LangExt.UndecidableInstances + (deprecatedForExtension "UndecidableInstances"), + depFlagSpec' "allow-incoherent-instances" LangExt.IncoherentInstances + (deprecatedForExtension "IncoherentInstances") + ] + +supportedLanguages :: [String] +supportedLanguages = map (flagSpecName . snd) languageFlagsDeps + +supportedLanguageOverlays :: [String] +supportedLanguageOverlays = map (flagSpecName . snd) safeHaskellFlagsDeps + +supportedExtensions :: [String] +supportedExtensions = concatMap toFlagSpecNamePair xFlags + where + toFlagSpecNamePair flg +#if !defined(GHCI) + -- IMPORTANT! Make sure that `ghc --supported-extensions` omits + -- "TemplateHaskell"/"QuasiQuotes" when it's known not to work out of the + -- box. See also GHC #11102 and #16331 for more details about + -- the rationale + | flagSpecFlag flg == LangExt.TemplateHaskell = [noName] + | flagSpecFlag flg == LangExt.QuasiQuotes = [noName] +#endif + | otherwise = [name, noName] + where + noName = "No" ++ name + name = flagSpecName flg + +supportedLanguagesAndExtensions :: [String] +supportedLanguagesAndExtensions = + supportedLanguages ++ supportedLanguageOverlays ++ supportedExtensions + +-- | These -X flags cannot be reversed with -XNo +languageFlagsDeps :: [(Deprecation, FlagSpec Language)] +languageFlagsDeps = [ + flagSpec "Haskell98" Haskell98, + flagSpec "Haskell2010" Haskell2010 + ] + +-- | These -X flags cannot be reversed with -XNo +-- They are used to place hard requirements on what GHC Haskell language +-- features can be used. +safeHaskellFlagsDeps :: [(Deprecation, FlagSpec SafeHaskellMode)] +safeHaskellFlagsDeps = [mkF Sf_Unsafe, mkF Sf_Trustworthy, mkF Sf_Safe] + where mkF flag = flagSpec (show flag) flag + +-- | These -X flags can all be reversed with -XNo +xFlags :: [FlagSpec LangExt.Extension] +xFlags = map snd xFlagsDeps + +xFlagsDeps :: [(Deprecation, FlagSpec LangExt.Extension)] +xFlagsDeps = [ +-- See Note [Updating flag description in the User's Guide] +-- See Note [Supporting CLI completion] +-- See Note [Adding a language extension] +-- Please keep the list of flags below sorted alphabetically + flagSpec "AllowAmbiguousTypes" LangExt.AllowAmbiguousTypes, + flagSpec "AlternativeLayoutRule" LangExt.AlternativeLayoutRule, + flagSpec "AlternativeLayoutRuleTransitional" + LangExt.AlternativeLayoutRuleTransitional, + flagSpec "Arrows" LangExt.Arrows, + depFlagSpecCond "AutoDeriveTypeable" LangExt.AutoDeriveTypeable + id + ("Typeable instances are created automatically " ++ + "for all types since GHC 8.2."), + flagSpec "BangPatterns" LangExt.BangPatterns, + flagSpec "BinaryLiterals" LangExt.BinaryLiterals, + flagSpec "CApiFFI" LangExt.CApiFFI, + flagSpec "CPP" LangExt.Cpp, + flagSpec "ConstrainedClassMethods" LangExt.ConstrainedClassMethods, + flagSpec "ConstraintKinds" LangExt.ConstraintKinds, + flagSpec "DataKinds" LangExt.DataKinds, + depFlagSpecCond "DatatypeContexts" LangExt.DatatypeContexts + id + ("It was widely considered a misfeature, " ++ + "and has been removed from the Haskell language."), + flagSpec "DefaultSignatures" LangExt.DefaultSignatures, + flagSpec "DeriveAnyClass" LangExt.DeriveAnyClass, + flagSpec "DeriveDataTypeable" LangExt.DeriveDataTypeable, + flagSpec "DeriveFoldable" LangExt.DeriveFoldable, + flagSpec "DeriveFunctor" LangExt.DeriveFunctor, + flagSpec "DeriveGeneric" LangExt.DeriveGeneric, + flagSpec "DeriveLift" LangExt.DeriveLift, + flagSpec "DeriveTraversable" LangExt.DeriveTraversable, + flagSpec "DerivingStrategies" LangExt.DerivingStrategies, + flagSpec "DerivingVia" LangExt.DerivingVia, + flagSpec "DisambiguateRecordFields" LangExt.DisambiguateRecordFields, + flagSpec "DoAndIfThenElse" LangExt.DoAndIfThenElse, + flagSpec "BlockArguments" LangExt.BlockArguments, + depFlagSpec' "DoRec" LangExt.RecursiveDo + (deprecatedForExtension "RecursiveDo"), + flagSpec "DuplicateRecordFields" LangExt.DuplicateRecordFields, + flagSpec "EmptyCase" LangExt.EmptyCase, + flagSpec "EmptyDataDecls" LangExt.EmptyDataDecls, + flagSpec "EmptyDataDeriving" LangExt.EmptyDataDeriving, + flagSpec "ExistentialQuantification" LangExt.ExistentialQuantification, + flagSpec "ExplicitForAll" LangExt.ExplicitForAll, + flagSpec "ExplicitNamespaces" LangExt.ExplicitNamespaces, + flagSpec "ExtendedDefaultRules" LangExt.ExtendedDefaultRules, + flagSpec "FlexibleContexts" LangExt.FlexibleContexts, + flagSpec "FlexibleInstances" LangExt.FlexibleInstances, + flagSpec "ForeignFunctionInterface" LangExt.ForeignFunctionInterface, + flagSpec "FunctionalDependencies" LangExt.FunctionalDependencies, + flagSpec "GADTSyntax" LangExt.GADTSyntax, + flagSpec "GADTs" LangExt.GADTs, + flagSpec "GHCForeignImportPrim" LangExt.GHCForeignImportPrim, + flagSpec' "GeneralizedNewtypeDeriving" LangExt.GeneralizedNewtypeDeriving + setGenDeriving, + flagSpec' "GeneralisedNewtypeDeriving" LangExt.GeneralizedNewtypeDeriving + setGenDeriving, + flagSpec "ImplicitParams" LangExt.ImplicitParams, + flagSpec "ImplicitPrelude" LangExt.ImplicitPrelude, + flagSpec "ImpredicativeTypes" LangExt.ImpredicativeTypes, + flagSpec' "IncoherentInstances" LangExt.IncoherentInstances + setIncoherentInsts, + flagSpec "TypeFamilyDependencies" LangExt.TypeFamilyDependencies, + flagSpec "InstanceSigs" LangExt.InstanceSigs, + flagSpec "ApplicativeDo" LangExt.ApplicativeDo, + flagSpec "InterruptibleFFI" LangExt.InterruptibleFFI, + flagSpec "JavaScriptFFI" LangExt.JavaScriptFFI, + flagSpec "KindSignatures" LangExt.KindSignatures, + flagSpec "LambdaCase" LangExt.LambdaCase, + flagSpec "LiberalTypeSynonyms" LangExt.LiberalTypeSynonyms, + flagSpec "MagicHash" LangExt.MagicHash, + flagSpec "MonadComprehensions" LangExt.MonadComprehensions, + depFlagSpec "MonadFailDesugaring" LangExt.MonadFailDesugaring + "MonadFailDesugaring is now the default behavior", + flagSpec "MonoLocalBinds" LangExt.MonoLocalBinds, + depFlagSpecCond "MonoPatBinds" LangExt.MonoPatBinds + id + "Experimental feature now removed; has no effect", + flagSpec "MonomorphismRestriction" LangExt.MonomorphismRestriction, + flagSpec "MultiParamTypeClasses" LangExt.MultiParamTypeClasses, + flagSpec "MultiWayIf" LangExt.MultiWayIf, + flagSpec "NumericUnderscores" LangExt.NumericUnderscores, + flagSpec "NPlusKPatterns" LangExt.NPlusKPatterns, + flagSpec "NamedFieldPuns" LangExt.RecordPuns, + flagSpec "NamedWildCards" LangExt.NamedWildCards, + flagSpec "NegativeLiterals" LangExt.NegativeLiterals, + flagSpec "HexFloatLiterals" LangExt.HexFloatLiterals, + flagSpec "NondecreasingIndentation" LangExt.NondecreasingIndentation, + depFlagSpec' "NullaryTypeClasses" LangExt.NullaryTypeClasses + (deprecatedForExtension "MultiParamTypeClasses"), + flagSpec "NumDecimals" LangExt.NumDecimals, + depFlagSpecOp "OverlappingInstances" LangExt.OverlappingInstances + setOverlappingInsts + "instead use per-instance pragmas OVERLAPPING/OVERLAPPABLE/OVERLAPS", + flagSpec "OverloadedLabels" LangExt.OverloadedLabels, + flagSpec "OverloadedLists" LangExt.OverloadedLists, + flagSpec "OverloadedStrings" LangExt.OverloadedStrings, + flagSpec "PackageImports" LangExt.PackageImports, + flagSpec "ParallelArrays" LangExt.ParallelArrays, + flagSpec "ParallelListComp" LangExt.ParallelListComp, + flagSpec "PartialTypeSignatures" LangExt.PartialTypeSignatures, + flagSpec "PatternGuards" LangExt.PatternGuards, + depFlagSpec' "PatternSignatures" LangExt.ScopedTypeVariables + (deprecatedForExtension "ScopedTypeVariables"), + flagSpec "PatternSynonyms" LangExt.PatternSynonyms, + flagSpec "PolyKinds" LangExt.PolyKinds, + flagSpec "PolymorphicComponents" LangExt.RankNTypes, + flagSpec "QuantifiedConstraints" LangExt.QuantifiedConstraints, + flagSpec "PostfixOperators" LangExt.PostfixOperators, + flagSpec "QuasiQuotes" LangExt.QuasiQuotes, + flagSpec "Rank2Types" LangExt.RankNTypes, + flagSpec "RankNTypes" LangExt.RankNTypes, + flagSpec "RebindableSyntax" LangExt.RebindableSyntax, + depFlagSpec' "RecordPuns" LangExt.RecordPuns + (deprecatedForExtension "NamedFieldPuns"), + flagSpec "RecordWildCards" LangExt.RecordWildCards, + flagSpec "RecursiveDo" LangExt.RecursiveDo, + flagSpec "RelaxedLayout" LangExt.RelaxedLayout, + depFlagSpecCond "RelaxedPolyRec" LangExt.RelaxedPolyRec + not + "You can't turn off RelaxedPolyRec any more", + flagSpec "RoleAnnotations" LangExt.RoleAnnotations, + flagSpec "ScopedTypeVariables" LangExt.ScopedTypeVariables, + flagSpec "StandaloneDeriving" LangExt.StandaloneDeriving, + flagSpec "StarIsType" LangExt.StarIsType, + flagSpec "StaticPointers" LangExt.StaticPointers, + flagSpec "Strict" LangExt.Strict, + flagSpec "StrictData" LangExt.StrictData, + flagSpec' "TemplateHaskell" LangExt.TemplateHaskell + checkTemplateHaskellOk, + flagSpec "TemplateHaskellQuotes" LangExt.TemplateHaskellQuotes, + flagSpec "TraditionalRecordSyntax" LangExt.TraditionalRecordSyntax, + flagSpec "TransformListComp" LangExt.TransformListComp, + flagSpec "TupleSections" LangExt.TupleSections, + flagSpec "TypeApplications" LangExt.TypeApplications, + flagSpec "TypeInType" LangExt.TypeInType, + flagSpec "TypeFamilies" LangExt.TypeFamilies, + flagSpec "TypeOperators" LangExt.TypeOperators, + flagSpec "TypeSynonymInstances" LangExt.TypeSynonymInstances, + flagSpec "UnboxedTuples" LangExt.UnboxedTuples, + flagSpec "UnboxedSums" LangExt.UnboxedSums, + flagSpec "UndecidableInstances" LangExt.UndecidableInstances, + flagSpec "UndecidableSuperClasses" LangExt.UndecidableSuperClasses, + flagSpec "UnicodeSyntax" LangExt.UnicodeSyntax, + flagSpec "UnliftedFFITypes" LangExt.UnliftedFFITypes, + flagSpec "ViewPatterns" LangExt.ViewPatterns + ] + +defaultFlags :: Settings -> [GeneralFlag] +defaultFlags settings +-- See Note [Updating flag description in the User's Guide] + = [ Opt_AutoLinkPackages, + Opt_DiagnosticsShowCaret, + Opt_EmbedManifest, + Opt_FlatCache, + Opt_GenManifest, + Opt_GhciHistory, + Opt_GhciSandbox, + Opt_HelpfulErrors, + Opt_KeepHiFiles, + Opt_KeepOFiles, + Opt_OmitYields, + Opt_PrintBindContents, + Opt_ProfCountEntries, + Opt_RPath, + Opt_SharedImplib, + Opt_SimplPreInlining, + Opt_VersionMacros + ] + + ++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns] + -- The default -O0 options + + ++ default_PIC platform + + ++ concatMap (wayGeneralFlags platform) (defaultWays settings) + ++ validHoleFitDefaults + + where platform = sTargetPlatform settings + +-- | These are the default settings for the display and sorting of valid hole +-- fits in typed-hole error messages. See Note [Valid hole fits include ...] + -- in the TcHoleErrors module. +validHoleFitDefaults :: [GeneralFlag] +validHoleFitDefaults + = [ Opt_ShowTypeAppOfHoleFits + , Opt_ShowTypeOfHoleFits + , Opt_ShowProvOfHoleFits + , Opt_ShowMatchesOfHoleFits + , Opt_ShowValidHoleFits + , Opt_SortValidHoleFits + , Opt_SortBySizeHoleFits + , Opt_ShowHoleConstraints ] + + +validHoleFitsImpliedGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)] +validHoleFitsImpliedGFlags + = [ (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowTypeAppOfHoleFits) + , (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowTypeAppVarsOfHoleFits) + , (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowDocsOfHoleFits) + , (Opt_ShowTypeAppVarsOfHoleFits, turnOff, Opt_ShowTypeAppOfHoleFits) + , (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowProvOfHoleFits) ] + +default_PIC :: Platform -> [GeneralFlag] +default_PIC platform = + case (platformOS platform, platformArch platform) of + (OSDarwin, ArchX86_64) -> [Opt_PIC] + (OSOpenBSD, ArchX86_64) -> [Opt_PIC] -- Due to PIE support in + -- OpenBSD since 5.3 release + -- (1 May 2013) we need to + -- always generate PIC. See + -- #10597 for more + -- information. + _ -> [] + +-- General flags that are switched on/off when other general flags are switched +-- on +impliedGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)] +impliedGFlags = [(Opt_DeferTypeErrors, turnOn, Opt_DeferTypedHoles) + ,(Opt_DeferTypeErrors, turnOn, Opt_DeferOutOfScopeVariables) + ,(Opt_Strictness, turnOn, Opt_WorkerWrapper) + ] ++ validHoleFitsImpliedGFlags + +-- General flags that are switched on/off when other general flags are switched +-- off +impliedOffGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)] +impliedOffGFlags = [(Opt_Strictness, turnOff, Opt_WorkerWrapper)] + +impliedXFlags :: [(LangExt.Extension, TurnOnFlag, LangExt.Extension)] +impliedXFlags +-- See Note [Updating flag description in the User's Guide] + = [ (LangExt.RankNTypes, turnOn, LangExt.ExplicitForAll) + , (LangExt.QuantifiedConstraints, turnOn, LangExt.ExplicitForAll) + , (LangExt.ScopedTypeVariables, turnOn, LangExt.ExplicitForAll) + , (LangExt.LiberalTypeSynonyms, turnOn, LangExt.ExplicitForAll) + , (LangExt.ExistentialQuantification, turnOn, LangExt.ExplicitForAll) + , (LangExt.FlexibleInstances, turnOn, LangExt.TypeSynonymInstances) + , (LangExt.FunctionalDependencies, turnOn, LangExt.MultiParamTypeClasses) + , (LangExt.MultiParamTypeClasses, turnOn, LangExt.ConstrainedClassMethods) -- c.f. #7854 + , (LangExt.TypeFamilyDependencies, turnOn, LangExt.TypeFamilies) + + , (LangExt.RebindableSyntax, turnOff, LangExt.ImplicitPrelude) -- NB: turn off! + + , (LangExt.DerivingVia, turnOn, LangExt.DerivingStrategies) + + , (LangExt.GADTs, turnOn, LangExt.GADTSyntax) + , (LangExt.GADTs, turnOn, LangExt.MonoLocalBinds) + , (LangExt.TypeFamilies, turnOn, LangExt.MonoLocalBinds) + + , (LangExt.TypeFamilies, turnOn, LangExt.KindSignatures) -- Type families use kind signatures + , (LangExt.PolyKinds, turnOn, LangExt.KindSignatures) -- Ditto polymorphic kinds + + -- TypeInType is now just a synonym for a couple of other extensions. + , (LangExt.TypeInType, turnOn, LangExt.DataKinds) + , (LangExt.TypeInType, turnOn, LangExt.PolyKinds) + , (LangExt.TypeInType, turnOn, LangExt.KindSignatures) + + -- AutoDeriveTypeable is not very useful without DeriveDataTypeable + , (LangExt.AutoDeriveTypeable, turnOn, LangExt.DeriveDataTypeable) + + -- We turn this on so that we can export associated type + -- type synonyms in subordinates (e.g. MyClass(type AssocType)) + , (LangExt.TypeFamilies, turnOn, LangExt.ExplicitNamespaces) + , (LangExt.TypeOperators, turnOn, LangExt.ExplicitNamespaces) + + , (LangExt.ImpredicativeTypes, turnOn, LangExt.RankNTypes) + + -- Record wild-cards implies field disambiguation + -- Otherwise if you write (C {..}) you may well get + -- stuff like " 'a' not in scope ", which is a bit silly + -- if the compiler has just filled in field 'a' of constructor 'C' + , (LangExt.RecordWildCards, turnOn, LangExt.DisambiguateRecordFields) + + , (LangExt.ParallelArrays, turnOn, LangExt.ParallelListComp) + + , (LangExt.JavaScriptFFI, turnOn, LangExt.InterruptibleFFI) + + , (LangExt.DeriveTraversable, turnOn, LangExt.DeriveFunctor) + , (LangExt.DeriveTraversable, turnOn, LangExt.DeriveFoldable) + + -- Duplicate record fields require field disambiguation + , (LangExt.DuplicateRecordFields, turnOn, LangExt.DisambiguateRecordFields) + + , (LangExt.TemplateHaskell, turnOn, LangExt.TemplateHaskellQuotes) + , (LangExt.Strict, turnOn, LangExt.StrictData) + ] + +-- Note [When is StarIsType enabled] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The StarIsType extension determines whether to treat '*' as a regular type +-- operator or as a synonym for 'Data.Kind.Type'. Many existing pre-TypeInType +-- programs expect '*' to be synonymous with 'Type', so by default StarIsType is +-- enabled. +-- +-- Programs that use TypeOperators might expect to repurpose '*' for +-- multiplication or another binary operation, but making TypeOperators imply +-- NoStarIsType caused too much breakage on Hackage. +-- + +-- Note [Documenting optimisation flags] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- If you change the list of flags enabled for particular optimisation levels +-- please remember to update the User's Guide. The relevant file is: +-- +-- docs/users_guide/using-optimisation.rst +-- +-- Make sure to note whether a flag is implied by -O0, -O or -O2. + +optLevelFlags :: [([Int], GeneralFlag)] +optLevelFlags -- see Note [Documenting optimisation flags] + = [ ([0,1,2], Opt_DoLambdaEtaExpansion) + , ([0,1,2], Opt_DoEtaReduction) -- See Note [Eta-reduction in -O0] + , ([0,1,2], Opt_DmdTxDictSel) + , ([0,1,2], Opt_LlvmTBAA) + + , ([0], Opt_IgnoreInterfacePragmas) + , ([0], Opt_OmitInterfacePragmas) + + , ([1,2], Opt_CallArity) + , ([1,2], Opt_Exitification) + , ([1,2], Opt_CaseMerge) + , ([1,2], Opt_CaseFolding) + , ([1,2], Opt_CmmElimCommonBlocks) + , ([2], Opt_AsmShortcutting) + , ([1,2], Opt_CmmSink) + , ([1,2], Opt_CSE) + , ([1,2], Opt_StgCSE) + , ([2], Opt_StgLiftLams) + , ([1,2], Opt_EnableRewriteRules) -- Off for -O0; see Note [Scoping for Builtin rules] + -- in PrelRules + , ([1,2], Opt_FloatIn) + , ([1,2], Opt_FullLaziness) + , ([1,2], Opt_IgnoreAsserts) + , ([1,2], Opt_Loopification) + , ([1,2], Opt_CfgBlocklayout) -- Experimental + + , ([1,2], Opt_Specialise) + , ([1,2], Opt_CrossModuleSpecialise) + , ([1,2], Opt_Strictness) + , ([1,2], Opt_UnboxSmallStrictFields) + , ([1,2], Opt_CprAnal) + , ([1,2], Opt_WorkerWrapper) + , ([1,2], Opt_SolveConstantDicts) + , ([1,2], Opt_NumConstantFolding) + + , ([2], Opt_LiberateCase) + , ([2], Opt_SpecConstr) +-- , ([2], Opt_RegsGraph) +-- RegsGraph suffers performance regression. See #7679 +-- , ([2], Opt_StaticArgumentTransformation) +-- Static Argument Transformation needs investigation. See #9374 + ] + +{- Note [Eta-reduction in -O0] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +#11562 showed an example which tripped an ASSERT in CoreToStg; a +function was marked as MayHaveCafRefs when in fact it obviously +didn't. Reason was: + * Eta reduction wasn't happening in the simplifier, but it was + happening in CorePrep, on + $fBla = MkDict (/\a. K a) + * Result: rhsIsStatic told TidyPgm that $fBla might have CAF refs + but the eta-reduced version (MkDict K) obviously doesn't +Simple solution: just let the simplifier do eta-reduction even in -O0. +After all, CorePrep does it unconditionally! Not a big deal, but +removes an assertion failure. -} + + +-- ----------------------------------------------------------------------------- +-- Standard sets of warning options + +-- Note [Documenting warning flags] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- If you change the list of warning enabled by default +-- please remember to update the User's Guide. The relevant file is: +-- +-- docs/users_guide/using-warnings.rst + +-- | Warning groups. +-- +-- As all warnings are in the Weverything set, it is ignored when +-- displaying to the user which group a warning is in. +warningGroups :: [(String, [WarningFlag])] +warningGroups = + [ ("compat", minusWcompatOpts) + , ("unused-binds", unusedBindsFlags) + , ("default", standardWarnings) + , ("extra", minusWOpts) + , ("all", minusWallOpts) + , ("everything", minusWeverythingOpts) + ] + +-- | Warning group hierarchies, where there is an explicit inclusion +-- relation. +-- +-- Each inner list is a hierarchy of warning groups, ordered from +-- smallest to largest, where each group is a superset of the one +-- before it. +-- +-- Separating this from 'warningGroups' allows for multiple +-- hierarchies with no inherent relation to be defined. +-- +-- The special-case Weverything group is not included. +warningHierarchies :: [[String]] +warningHierarchies = hierarchies ++ map (:[]) rest + where + hierarchies = [["default", "extra", "all"]] + rest = filter (`notElem` "everything" : concat hierarchies) $ + map fst warningGroups + +-- | Find the smallest group in every hierarchy which a warning +-- belongs to, excluding Weverything. +smallestGroups :: WarningFlag -> [String] +smallestGroups flag = mapMaybe go warningHierarchies where + -- Because each hierarchy is arranged from smallest to largest, + -- the first group we find in a hierarchy which contains the flag + -- is the smallest. + go (group:rest) = fromMaybe (go rest) $ do + flags <- lookup group warningGroups + guard (flag `elem` flags) + pure (Just group) + go [] = Nothing + +-- | Warnings enabled unless specified otherwise +standardWarnings :: [WarningFlag] +standardWarnings -- see Note [Documenting warning flags] + = [ Opt_WarnOverlappingPatterns, + Opt_WarnWarningsDeprecations, + Opt_WarnDeprecatedFlags, + Opt_WarnDeferredTypeErrors, + Opt_WarnTypedHoles, + Opt_WarnDeferredOutOfScopeVariables, + Opt_WarnPartialTypeSignatures, + Opt_WarnUnrecognisedPragmas, + Opt_WarnDuplicateExports, + Opt_WarnOverflowedLiterals, + Opt_WarnEmptyEnumerations, + Opt_WarnMissingFields, + Opt_WarnMissingMethods, + Opt_WarnWrongDoBind, + Opt_WarnUnsupportedCallingConventions, + Opt_WarnDodgyForeignImports, + Opt_WarnInlineRuleShadowing, + Opt_WarnAlternativeLayoutRuleTransitional, + Opt_WarnUnsupportedLlvmVersion, + Opt_WarnMissedExtraSharedLib, + Opt_WarnTabs, + Opt_WarnUnrecognisedWarningFlags, + Opt_WarnSimplifiableClassConstraints, + Opt_WarnStarBinder, + Opt_WarnInaccessibleCode, + Opt_WarnSpaceAfterBang + ] + +-- | Things you get with -W +minusWOpts :: [WarningFlag] +minusWOpts + = standardWarnings ++ + [ Opt_WarnUnusedTopBinds, + Opt_WarnUnusedLocalBinds, + Opt_WarnUnusedPatternBinds, + Opt_WarnUnusedMatches, + Opt_WarnUnusedForalls, + Opt_WarnUnusedImports, + Opt_WarnIncompletePatterns, + Opt_WarnDodgyExports, + Opt_WarnDodgyImports, + Opt_WarnUnbangedStrictPatterns + ] + +-- | Things you get with -Wall +minusWallOpts :: [WarningFlag] +minusWallOpts + = minusWOpts ++ + [ Opt_WarnTypeDefaults, + Opt_WarnNameShadowing, + Opt_WarnMissingSignatures, + Opt_WarnHiShadows, + Opt_WarnOrphans, + Opt_WarnUnusedDoBind, + Opt_WarnTrustworthySafe, + Opt_WarnUntickedPromotedConstructors, + Opt_WarnMissingPatternSynonymSignatures, + Opt_WarnUnusedRecordWildcards, + Opt_WarnRedundantRecordWildcards + ] + +-- | Things you get with -Weverything, i.e. *all* known warnings flags +minusWeverythingOpts :: [WarningFlag] +minusWeverythingOpts = [ toEnum 0 .. ] + +-- | Things you get with -Wcompat. +-- +-- This is intended to group together warnings that will be enabled by default +-- at some point in the future, so that library authors eager to make their +-- code future compatible to fix issues before they even generate warnings. +minusWcompatOpts :: [WarningFlag] +minusWcompatOpts + = [ Opt_WarnMissingMonadFailInstances + , Opt_WarnSemigroup + , Opt_WarnNonCanonicalMonoidInstances + , Opt_WarnStarIsType + ] + +enableUnusedBinds :: DynP () +enableUnusedBinds = mapM_ setWarningFlag unusedBindsFlags + +disableUnusedBinds :: DynP () +disableUnusedBinds = mapM_ unSetWarningFlag unusedBindsFlags + +-- Things you get with -Wunused-binds +unusedBindsFlags :: [WarningFlag] +unusedBindsFlags = [ Opt_WarnUnusedTopBinds + , Opt_WarnUnusedLocalBinds + , Opt_WarnUnusedPatternBinds + ] + +enableGlasgowExts :: DynP () +enableGlasgowExts = do setGeneralFlag Opt_PrintExplicitForalls + mapM_ setExtensionFlag glasgowExtsFlags + +disableGlasgowExts :: DynP () +disableGlasgowExts = do unSetGeneralFlag Opt_PrintExplicitForalls + mapM_ unSetExtensionFlag glasgowExtsFlags + +-- Please keep what_glasgow_exts_does.rst up to date with this list +glasgowExtsFlags :: [LangExt.Extension] +glasgowExtsFlags = [ + LangExt.ConstrainedClassMethods + , LangExt.DeriveDataTypeable + , LangExt.DeriveFoldable + , LangExt.DeriveFunctor + , LangExt.DeriveGeneric + , LangExt.DeriveTraversable + , LangExt.EmptyDataDecls + , LangExt.ExistentialQuantification + , LangExt.ExplicitNamespaces + , LangExt.FlexibleContexts + , LangExt.FlexibleInstances + , LangExt.ForeignFunctionInterface + , LangExt.FunctionalDependencies + , LangExt.GeneralizedNewtypeDeriving + , LangExt.ImplicitParams + , LangExt.KindSignatures + , LangExt.LiberalTypeSynonyms + , LangExt.MagicHash + , LangExt.MultiParamTypeClasses + , LangExt.ParallelListComp + , LangExt.PatternGuards + , LangExt.PostfixOperators + , LangExt.RankNTypes + , LangExt.RecursiveDo + , LangExt.ScopedTypeVariables + , LangExt.StandaloneDeriving + , LangExt.TypeOperators + , LangExt.TypeSynonymInstances + , LangExt.UnboxedTuples + , LangExt.UnicodeSyntax + , LangExt.UnliftedFFITypes ] + +foreign import ccall unsafe "rts_isProfiled" rtsIsProfiledIO :: IO CInt + +-- | Was the runtime system built with profiling enabled? +rtsIsProfiled :: Bool +rtsIsProfiled = unsafeDupablePerformIO rtsIsProfiledIO /= 0 + +-- Consult the RTS to find whether GHC itself has been built with +-- dynamic linking. This can't be statically known at compile-time, +-- because we build both the static and dynamic versions together with +-- -dynamic-too. +foreign import ccall unsafe "rts_isDynamic" rtsIsDynamicIO :: IO CInt + +dynamicGhc :: Bool +dynamicGhc = unsafeDupablePerformIO rtsIsDynamicIO /= 0 + +setWarnSafe :: Bool -> DynP () +setWarnSafe True = getCurLoc >>= \l -> upd (\d -> d { warnSafeOnLoc = l }) +setWarnSafe False = return () + +setWarnUnsafe :: Bool -> DynP () +setWarnUnsafe True = getCurLoc >>= \l -> upd (\d -> d { warnUnsafeOnLoc = l }) +setWarnUnsafe False = return () + +setPackageTrust :: DynP () +setPackageTrust = do + setGeneralFlag Opt_PackageTrust + l <- getCurLoc + upd $ \d -> d { pkgTrustOnLoc = l } + +setGenDeriving :: TurnOnFlag -> DynP () +setGenDeriving True = getCurLoc >>= \l -> upd (\d -> d { newDerivOnLoc = l }) +setGenDeriving False = return () + +setOverlappingInsts :: TurnOnFlag -> DynP () +setOverlappingInsts False = return () +setOverlappingInsts True = do + l <- getCurLoc + upd (\d -> d { overlapInstLoc = l }) + +setIncoherentInsts :: TurnOnFlag -> DynP () +setIncoherentInsts False = return () +setIncoherentInsts True = do + l <- getCurLoc + upd (\d -> d { incoherentOnLoc = l }) + +checkTemplateHaskellOk :: TurnOnFlag -> DynP () +checkTemplateHaskellOk _turn_on + = getCurLoc >>= \l -> upd (\d -> d { thOnLoc = l }) + +{- ********************************************************************** +%* * + DynFlags constructors +%* * +%********************************************************************* -} + +type DynP = EwM (CmdLineP DynFlags) + +upd :: (DynFlags -> DynFlags) -> DynP () +upd f = liftEwM (do dflags <- getCmdLineState + putCmdLineState $! f dflags) + +updM :: (DynFlags -> DynP DynFlags) -> DynP () +updM f = do dflags <- liftEwM getCmdLineState + dflags' <- f dflags + liftEwM $ putCmdLineState $! dflags' + +--------------- Constructor functions for OptKind ----------------- +noArg :: (DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) +noArg fn = NoArg (upd fn) + +noArgM :: (DynFlags -> DynP DynFlags) -> OptKind (CmdLineP DynFlags) +noArgM fn = NoArg (updM fn) + +hasArg :: (String -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) +hasArg fn = HasArg (upd . fn) + +sepArg :: (String -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) +sepArg fn = SepArg (upd . fn) + +intSuffix :: (Int -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) +intSuffix fn = IntSuffix (\n -> upd (fn n)) + +intSuffixM :: (Int -> DynFlags -> DynP DynFlags) -> OptKind (CmdLineP DynFlags) +intSuffixM fn = IntSuffix (\n -> updM (fn n)) + +floatSuffix :: (Float -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) +floatSuffix fn = FloatSuffix (\n -> upd (fn n)) + +optIntSuffixM :: (Maybe Int -> DynFlags -> DynP DynFlags) + -> OptKind (CmdLineP DynFlags) +optIntSuffixM fn = OptIntSuffix (\mi -> updM (fn mi)) + +setDumpFlag :: DumpFlag -> OptKind (CmdLineP DynFlags) +setDumpFlag dump_flag = NoArg (setDumpFlag' dump_flag) + +-------------------------- +addWay :: Way -> DynP () +addWay w = upd (addWay' w) + +addWay' :: Way -> DynFlags -> DynFlags +addWay' w dflags0 = let platform = targetPlatform dflags0 + dflags1 = dflags0 { ways = w : ways dflags0 } + dflags2 = foldr setGeneralFlag' dflags1 + (wayGeneralFlags platform w) + dflags3 = foldr unSetGeneralFlag' dflags2 + (wayUnsetGeneralFlags platform w) + in dflags3 + +removeWayDyn :: DynP () +removeWayDyn = upd (\dfs -> dfs { ways = filter (WayDyn /=) (ways dfs) }) + +-------------------------- +setGeneralFlag, unSetGeneralFlag :: GeneralFlag -> DynP () +setGeneralFlag f = upd (setGeneralFlag' f) +unSetGeneralFlag f = upd (unSetGeneralFlag' f) + +setGeneralFlag' :: GeneralFlag -> DynFlags -> DynFlags +setGeneralFlag' f dflags = foldr ($) (gopt_set dflags f) deps + where + deps = [ if turn_on then setGeneralFlag' d + else unSetGeneralFlag' d + | (f', turn_on, d) <- impliedGFlags, f' == f ] + -- When you set f, set the ones it implies + -- NB: use setGeneralFlag recursively, in case the implied flags + -- implies further flags + +unSetGeneralFlag' :: GeneralFlag -> DynFlags -> DynFlags +unSetGeneralFlag' f dflags = foldr ($) (gopt_unset dflags f) deps + where + deps = [ if turn_on then setGeneralFlag' d + else unSetGeneralFlag' d + | (f', turn_on, d) <- impliedOffGFlags, f' == f ] + -- In general, when you un-set f, we don't un-set the things it implies. + -- There are however some exceptions, e.g., -fno-strictness implies + -- -fno-worker-wrapper. + -- + -- NB: use unSetGeneralFlag' recursively, in case the implied off flags + -- imply further flags. + +-------------------------- +setWarningFlag, unSetWarningFlag :: WarningFlag -> DynP () +setWarningFlag f = upd (\dfs -> wopt_set dfs f) +unSetWarningFlag f = upd (\dfs -> wopt_unset dfs f) + +setFatalWarningFlag, unSetFatalWarningFlag :: WarningFlag -> DynP () +setFatalWarningFlag f = upd (\dfs -> wopt_set_fatal dfs f) +unSetFatalWarningFlag f = upd (\dfs -> wopt_unset_fatal dfs f) + +setWErrorFlag :: WarningFlag -> DynP () +setWErrorFlag flag = + do { setWarningFlag flag + ; setFatalWarningFlag flag } + +-------------------------- +setExtensionFlag, unSetExtensionFlag :: LangExt.Extension -> DynP () +setExtensionFlag f = upd (setExtensionFlag' f) +unSetExtensionFlag f = upd (unSetExtensionFlag' f) + +setExtensionFlag', unSetExtensionFlag' :: LangExt.Extension -> DynFlags -> DynFlags +setExtensionFlag' f dflags = foldr ($) (xopt_set dflags f) deps + where + deps = [ if turn_on then setExtensionFlag' d + else unSetExtensionFlag' d + | (f', turn_on, d) <- impliedXFlags, f' == f ] + -- When you set f, set the ones it implies + -- NB: use setExtensionFlag recursively, in case the implied flags + -- implies further flags + +unSetExtensionFlag' f dflags = xopt_unset dflags f + -- When you un-set f, however, we don't un-set the things it implies + -- (except for -fno-glasgow-exts, which is treated specially) + +-------------------------- +alterSettings :: (Settings -> Settings) -> DynFlags -> DynFlags +alterSettings f dflags = dflags { settings = f (settings dflags) } + +-------------------------- +setDumpFlag' :: DumpFlag -> DynP () +setDumpFlag' dump_flag + = do upd (\dfs -> dopt_set dfs dump_flag) + when want_recomp forceRecompile + where -- Certain dumpy-things are really interested in what's going + -- on during recompilation checking, so in those cases we + -- don't want to turn it off. + want_recomp = dump_flag `notElem` [Opt_D_dump_if_trace, + Opt_D_dump_hi_diffs, + Opt_D_no_debug_output] + +forceRecompile :: DynP () +-- Whenver we -ddump, force recompilation (by switching off the +-- recompilation checker), else you don't see the dump! However, +-- don't switch it off in --make mode, else *everything* gets +-- recompiled which probably isn't what you want +forceRecompile = do dfs <- liftEwM getCmdLineState + when (force_recomp dfs) (setGeneralFlag Opt_ForceRecomp) + where + force_recomp dfs = isOneShot (ghcMode dfs) + + +setVerboseCore2Core :: DynP () +setVerboseCore2Core = setDumpFlag' Opt_D_verbose_core2core + +setVerbosity :: Maybe Int -> DynP () +setVerbosity mb_n = upd (\dfs -> dfs{ verbosity = mb_n `orElse` 3 }) + +setDebugLevel :: Maybe Int -> DynP () +setDebugLevel mb_n = upd (\dfs -> dfs{ debugLevel = mb_n `orElse` 2 }) + +data PkgConfRef + = GlobalPkgConf + | UserPkgConf + | PkgConfFile FilePath + deriving Eq + +addPkgConfRef :: PkgConfRef -> DynP () +addPkgConfRef p = upd $ \s -> + s { packageDBFlags = PackageDB p : packageDBFlags s } + +removeUserPkgConf :: DynP () +removeUserPkgConf = upd $ \s -> + s { packageDBFlags = NoUserPackageDB : packageDBFlags s } + +removeGlobalPkgConf :: DynP () +removeGlobalPkgConf = upd $ \s -> + s { packageDBFlags = NoGlobalPackageDB : packageDBFlags s } + +clearPkgConf :: DynP () +clearPkgConf = upd $ \s -> + s { packageDBFlags = ClearPackageDBs : packageDBFlags s } + +parsePackageFlag :: String -- the flag + -> ReadP PackageArg -- type of argument + -> String -- string to parse + -> PackageFlag +parsePackageFlag flag arg_parse str + = case filter ((=="").snd) (readP_to_S parse str) of + [(r, "")] -> r + _ -> throwGhcException $ CmdLineError ("Can't parse package flag: " ++ str) + where doc = flag ++ " " ++ str + parse = do + pkg_arg <- tok arg_parse + let mk_expose = ExposePackage doc pkg_arg + ( do _ <- tok $ string "with" + fmap (mk_expose . ModRenaming True) parseRns + <++ fmap (mk_expose . ModRenaming False) parseRns + <++ return (mk_expose (ModRenaming True []))) + parseRns = do _ <- tok $ R.char '(' + rns <- tok $ sepBy parseItem (tok $ R.char ',') + _ <- tok $ R.char ')' + return rns + parseItem = do + orig <- tok $ parseModuleName + (do _ <- tok $ string "as" + new <- tok $ parseModuleName + return (orig, new) + +++ + return (orig, orig)) + tok m = m >>= \x -> skipSpaces >> return x + +exposePackage, exposePackageId, hidePackage, + exposePluginPackage, exposePluginPackageId, + ignorePackage, + trustPackage, distrustPackage :: String -> DynP () +exposePackage p = upd (exposePackage' p) +exposePackageId p = + upd (\s -> s{ packageFlags = + parsePackageFlag "-package-id" parseUnitIdArg p : packageFlags s }) +exposePluginPackage p = + upd (\s -> s{ pluginPackageFlags = + parsePackageFlag "-plugin-package" parsePackageArg p : pluginPackageFlags s }) +exposePluginPackageId p = + upd (\s -> s{ pluginPackageFlags = + parsePackageFlag "-plugin-package-id" parseUnitIdArg p : pluginPackageFlags s }) +hidePackage p = + upd (\s -> s{ packageFlags = HidePackage p : packageFlags s }) +ignorePackage p = + upd (\s -> s{ ignorePackageFlags = IgnorePackage p : ignorePackageFlags s }) + +trustPackage p = exposePackage p >> -- both trust and distrust also expose a package + upd (\s -> s{ trustFlags = TrustPackage p : trustFlags s }) +distrustPackage p = exposePackage p >> + upd (\s -> s{ trustFlags = DistrustPackage p : trustFlags s }) + +exposePackage' :: String -> DynFlags -> DynFlags +exposePackage' p dflags + = dflags { packageFlags = + parsePackageFlag "-package" parsePackageArg p : packageFlags dflags } + +parsePackageArg :: ReadP PackageArg +parsePackageArg = + fmap PackageArg (munch1 (\c -> isAlphaNum c || c `elem` ":-_.")) + +parseUnitIdArg :: ReadP PackageArg +parseUnitIdArg = + fmap UnitIdArg parseUnitId + +setUnitId :: String -> DynFlags -> DynFlags +setUnitId p d = d { thisInstalledUnitId = stringToInstalledUnitId p } + +-- | Given a 'ModuleName' of a signature in the home library, find +-- out how it is instantiated. E.g., the canonical form of +-- A in @p[A=q[]:A]@ is @q[]:A@. +canonicalizeHomeModule :: DynFlags -> ModuleName -> Module +canonicalizeHomeModule dflags mod_name = + case lookup mod_name (thisUnitIdInsts dflags) of + Nothing -> mkModule (thisPackage dflags) mod_name + Just mod -> mod + +canonicalizeModuleIfHome :: DynFlags -> Module -> Module +canonicalizeModuleIfHome dflags mod + = if thisPackage dflags == moduleUnitId mod + then canonicalizeHomeModule dflags (moduleName mod) + else mod + + +-- ----------------------------------------------------------------------------- +-- | Find the package environment (if one exists) +-- +-- We interpret the package environment as a set of package flags; to be +-- specific, if we find a package environment file like +-- +-- > clear-package-db +-- > global-package-db +-- > package-db blah/package.conf.d +-- > package-id id1 +-- > package-id id2 +-- +-- we interpret this as +-- +-- > [ -hide-all-packages +-- > , -clear-package-db +-- > , -global-package-db +-- > , -package-db blah/package.conf.d +-- > , -package-id id1 +-- > , -package-id id2 +-- > ] +-- +-- There's also an older syntax alias for package-id, which is just an +-- unadorned package id +-- +-- > id1 +-- > id2 +-- +interpretPackageEnv :: DynFlags -> IO DynFlags +interpretPackageEnv dflags = do + mPkgEnv <- runMaybeT $ msum $ [ + getCmdLineArg >>= \env -> msum [ + probeNullEnv env + , probeEnvFile env + , probeEnvName env + , cmdLineError env + ] + , getEnvVar >>= \env -> msum [ + probeNullEnv env + , probeEnvFile env + , probeEnvName env + , envError env + ] + , notIfHideAllPackages >> msum [ + findLocalEnvFile >>= probeEnvFile + , probeEnvName defaultEnvName + ] + ] + case mPkgEnv of + Nothing -> + -- No environment found. Leave DynFlags unchanged. + return dflags + Just "-" -> do + -- Explicitly disabled environment file. Leave DynFlags unchanged. + return dflags + Just envfile -> do + content <- readFile envfile + putLogMsg dflags NoReason SevInfo noSrcSpan + (defaultUserStyle dflags) + (text ("Loaded package environment from " ++ envfile)) + let setFlags :: DynP () + setFlags = do + setGeneralFlag Opt_HideAllPackages + parseEnvFile envfile content + + (_, dflags') = runCmdLine (runEwM setFlags) dflags + + return dflags' + where + -- Loading environments (by name or by location) + + namedEnvPath :: String -> MaybeT IO FilePath + namedEnvPath name = do + appdir <- versionedAppDir dflags + return $ appdir "environments" name + + probeEnvName :: String -> MaybeT IO FilePath + probeEnvName name = probeEnvFile =<< namedEnvPath name + + probeEnvFile :: FilePath -> MaybeT IO FilePath + probeEnvFile path = do + guard =<< liftMaybeT (doesFileExist path) + return path + + probeNullEnv :: FilePath -> MaybeT IO FilePath + probeNullEnv "-" = return "-" + probeNullEnv _ = mzero + + parseEnvFile :: FilePath -> String -> DynP () + parseEnvFile envfile = mapM_ parseEntry . lines + where + parseEntry str = case words str of + ("package-db": _) -> addPkgConfRef (PkgConfFile (envdir db)) + -- relative package dbs are interpreted relative to the env file + where envdir = takeDirectory envfile + db = drop 11 str + ["clear-package-db"] -> clearPkgConf + ["global-package-db"] -> addPkgConfRef GlobalPkgConf + ["user-package-db"] -> addPkgConfRef UserPkgConf + ["package-id", pkgid] -> exposePackageId pkgid + (('-':'-':_):_) -> return () -- comments + -- and the original syntax introduced in 7.10: + [pkgid] -> exposePackageId pkgid + [] -> return () + _ -> throwGhcException $ CmdLineError $ + "Can't parse environment file entry: " + ++ envfile ++ ": " ++ str + + -- Various ways to define which environment to use + + getCmdLineArg :: MaybeT IO String + getCmdLineArg = MaybeT $ return $ packageEnv dflags + + getEnvVar :: MaybeT IO String + getEnvVar = do + mvar <- liftMaybeT $ try $ getEnv "GHC_ENVIRONMENT" + case mvar of + Right var -> return var + Left err -> if isDoesNotExistError err then mzero + else liftMaybeT $ throwIO err + + notIfHideAllPackages :: MaybeT IO () + notIfHideAllPackages = + guard (not (gopt Opt_HideAllPackages dflags)) + + defaultEnvName :: String + defaultEnvName = "default" + + -- e.g. .ghc.environment.x86_64-linux-7.6.3 + localEnvFileName :: FilePath + localEnvFileName = ".ghc.environment" <.> versionedFilePath dflags + + -- Search for an env file, starting in the current dir and looking upwards. + -- Fail if we get to the users home dir or the filesystem root. That is, + -- we don't look for an env file in the user's home dir. The user-wide + -- env lives in ghc's versionedAppDir/environments/default + findLocalEnvFile :: MaybeT IO FilePath + findLocalEnvFile = do + curdir <- liftMaybeT getCurrentDirectory + homedir <- tryMaybeT getHomeDirectory + let probe dir | isDrive dir || dir == homedir + = mzero + probe dir = do + let file = dir localEnvFileName + exists <- liftMaybeT (doesFileExist file) + if exists + then return file + else probe (takeDirectory dir) + probe curdir + + -- Error reporting + + cmdLineError :: String -> MaybeT IO a + cmdLineError env = liftMaybeT . throwGhcExceptionIO . CmdLineError $ + "Package environment " ++ show env ++ " not found" + + envError :: String -> MaybeT IO a + envError env = liftMaybeT . throwGhcExceptionIO . CmdLineError $ + "Package environment " + ++ show env + ++ " (specified in GHC_ENVIRONMENT) not found" + + +-- If we're linking a binary, then only targets that produce object +-- code are allowed (requests for other target types are ignored). +setTarget :: HscTarget -> DynP () +setTarget l = setTargetWithPlatform (const l) + +setTargetWithPlatform :: (Platform -> HscTarget) -> DynP () +setTargetWithPlatform f = upd set + where + set dfs = let l = f (targetPlatform dfs) + in if ghcLink dfs /= LinkBinary || isObjectTarget l + then dfs{ hscTarget = l } + else dfs + +-- Changes the target only if we're compiling object code. This is +-- used by -fasm and -fllvm, which switch from one to the other, but +-- not from bytecode to object-code. The idea is that -fasm/-fllvm +-- can be safely used in an OPTIONS_GHC pragma. +setObjTarget :: HscTarget -> DynP () +setObjTarget l = updM set + where + set dflags + | isObjectTarget (hscTarget dflags) + = return $ dflags { hscTarget = l } + | otherwise = return dflags + +setOptLevel :: Int -> DynFlags -> DynP DynFlags +setOptLevel n dflags = return (updOptLevel n dflags) + +checkOptLevel :: Int -> DynFlags -> Either String DynFlags +checkOptLevel n dflags + | hscTarget dflags == HscInterpreted && n > 0 + = Left "-O conflicts with --interactive; -O ignored." + | otherwise + = Right dflags + +setMainIs :: String -> DynP () +setMainIs arg + | not (null main_fn) && isLower (head main_fn) + -- The arg looked like "Foo.Bar.baz" + = upd $ \d -> d { mainFunIs = Just main_fn, + mainModIs = mkModule mainUnitId (mkModuleName main_mod) } + + | isUpper (head arg) -- The arg looked like "Foo" or "Foo.Bar" + = upd $ \d -> d { mainModIs = mkModule mainUnitId (mkModuleName arg) } + + | otherwise -- The arg looked like "baz" + = upd $ \d -> d { mainFunIs = Just arg } + where + (main_mod, main_fn) = splitLongestPrefix arg (== '.') + +addLdInputs :: Option -> DynFlags -> DynFlags +addLdInputs p dflags = dflags{ldInputs = ldInputs dflags ++ [p]} + +----------------------------------------------------------------------------- +-- Paths & Libraries + +addImportPath, addLibraryPath, addIncludePath, addFrameworkPath :: FilePath -> DynP () + +-- -i on its own deletes the import paths +addImportPath "" = upd (\s -> s{importPaths = []}) +addImportPath p = upd (\s -> s{importPaths = importPaths s ++ splitPathList p}) + +addLibraryPath p = + upd (\s -> s{libraryPaths = libraryPaths s ++ splitPathList p}) + +addIncludePath p = + upd (\s -> s{includePaths = + addGlobalInclude (includePaths s) (splitPathList p)}) + +addFrameworkPath p = + upd (\s -> s{frameworkPaths = frameworkPaths s ++ splitPathList p}) + +#if !defined(mingw32_TARGET_OS) +split_marker :: Char +split_marker = ':' -- not configurable (ToDo) +#endif + +splitPathList :: String -> [String] +splitPathList s = filter notNull (splitUp s) + -- empty paths are ignored: there might be a trailing + -- ':' in the initial list, for example. Empty paths can + -- cause confusion when they are translated into -I options + -- for passing to gcc. + where +#if !defined(mingw32_TARGET_OS) + splitUp xs = split split_marker xs +#else + -- Windows: 'hybrid' support for DOS-style paths in directory lists. + -- + -- That is, if "foo:bar:baz" is used, this interpreted as + -- consisting of three entries, 'foo', 'bar', 'baz'. + -- However, with "c:/foo:c:\\foo;x:/bar", this is interpreted + -- as 3 elts, "c:/foo", "c:\\foo", "x:/bar" + -- + -- Notice that no attempt is made to fully replace the 'standard' + -- split marker ':' with the Windows / DOS one, ';'. The reason being + -- that this will cause too much breakage for users & ':' will + -- work fine even with DOS paths, if you're not insisting on being silly. + -- So, use either. + splitUp [] = [] + splitUp (x:':':div:xs) | div `elem` dir_markers + = ((x:':':div:p): splitUp rs) + where + (p,rs) = findNextPath xs + -- we used to check for existence of the path here, but that + -- required the IO monad to be threaded through the command-line + -- parser which is quite inconvenient. The + splitUp xs = cons p (splitUp rs) + where + (p,rs) = findNextPath xs + + cons "" xs = xs + cons x xs = x:xs + + -- will be called either when we've consumed nought or the + -- ":/" part of a DOS path, so splitting is just a Q of + -- finding the next split marker. + findNextPath xs = + case break (`elem` split_markers) xs of + (p, _:ds) -> (p, ds) + (p, xs) -> (p, xs) + + split_markers :: [Char] + split_markers = [':', ';'] + + dir_markers :: [Char] + dir_markers = ['/', '\\'] +#endif + +-- ----------------------------------------------------------------------------- +-- tmpDir, where we store temporary files. + +setTmpDir :: FilePath -> DynFlags -> DynFlags +setTmpDir dir = alterSettings (\s -> s { sTmpDir = normalise dir }) + -- we used to fix /cygdrive/c/.. on Windows, but this doesn't + -- seem necessary now --SDM 7/2/2008 + +----------------------------------------------------------------------------- +-- RTS opts + +setRtsOpts :: String -> DynP () +setRtsOpts arg = upd $ \ d -> d {rtsOpts = Just arg} + +setRtsOptsEnabled :: RtsOptsEnabled -> DynP () +setRtsOptsEnabled arg = upd $ \ d -> d {rtsOptsEnabled = arg} + +----------------------------------------------------------------------------- +-- Hpc stuff + +setOptHpcDir :: String -> DynP () +setOptHpcDir arg = upd $ \ d -> d {hpcDir = arg} + +----------------------------------------------------------------------------- +-- Via-C compilation stuff + +-- There are some options that we need to pass to gcc when compiling +-- Haskell code via C, but are only supported by recent versions of +-- gcc. The configure script decides which of these options we need, +-- and puts them in the "settings" file in $topdir. The advantage of +-- having these in a separate file is that the file can be created at +-- install-time depending on the available gcc version, and even +-- re-generated later if gcc is upgraded. +-- +-- The options below are not dependent on the version of gcc, only the +-- platform. + +picCCOpts :: DynFlags -> [String] +picCCOpts dflags = pieOpts ++ picOpts + where + picOpts = + case platformOS (targetPlatform dflags) of + OSDarwin + -- Apple prefers to do things the other way round. + -- PIC is on by default. + -- -mdynamic-no-pic: + -- Turn off PIC code generation. + -- -fno-common: + -- Don't generate "common" symbols - these are unwanted + -- in dynamic libraries. + + | gopt Opt_PIC dflags -> ["-fno-common", "-U__PIC__", "-D__PIC__"] + | otherwise -> ["-mdynamic-no-pic"] + OSMinGW32 -- no -fPIC for Windows + | gopt Opt_PIC dflags -> ["-U__PIC__", "-D__PIC__"] + | otherwise -> [] + _ + -- we need -fPIC for C files when we are compiling with -dynamic, + -- otherwise things like stub.c files don't get compiled + -- correctly. They need to reference data in the Haskell + -- objects, but can't without -fPIC. See + -- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/position-independent-code + | gopt Opt_PIC dflags || WayDyn `elem` ways dflags -> + ["-fPIC", "-U__PIC__", "-D__PIC__"] + -- gcc may be configured to have PIC on by default, let's be + -- explicit here, see #15847 + | otherwise -> ["-fno-PIC"] + + pieOpts + | gopt Opt_PICExecutable dflags = ["-pie"] + -- See Note [No PIE when linking] + | sGccSupportsNoPie (settings dflags) = ["-no-pie"] + | otherwise = [] + + +{- +Note [No PIE while linking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As of 2016 some Linux distributions (e.g. Debian) have started enabling -pie by +default in their gcc builds. This is incompatible with -r as it implies that we +are producing an executable. Consequently, we must manually pass -no-pie to gcc +when joining object files or linking dynamic libraries. Unless, of course, the +user has explicitly requested a PIE executable with -pie. See #12759. +-} + +picPOpts :: DynFlags -> [String] +picPOpts dflags + | gopt Opt_PIC dflags = ["-U__PIC__", "-D__PIC__"] + | otherwise = [] + +-- ----------------------------------------------------------------------------- +-- Compiler Info + +compilerInfo :: DynFlags -> [(String, String)] +compilerInfo dflags + = -- We always make "Project name" be first to keep parsing in + -- other languages simple, i.e. when looking for other fields, + -- you don't have to worry whether there is a leading '[' or not + ("Project name", cProjectName) + -- Next come the settings, so anything else can be overridden + -- in the settings file (as "lookup" uses the first match for the + -- key) + : map (fmap $ expandDirectories (topDir dflags) (toolDir dflags)) + (rawSettings dflags) + ++ [("Project version", projectVersion dflags), + ("Project Git commit id", cProjectGitCommitId), + ("Booter version", cBooterVersion), + ("Stage", cStage), + ("Build platform", cBuildPlatformString), + ("Host platform", cHostPlatformString), + ("Target platform", cTargetPlatformString), + ("Have interpreter", cGhcWithInterpreter), + ("Object splitting supported", showBool False), + ("Have native code generator", cGhcWithNativeCodeGen), + ("Support SMP", cGhcWithSMP), + ("Tables next to code", cGhcEnableTablesNextToCode), + ("RTS ways", cGhcRTSWays), + ("RTS expects libdw", showBool cGhcRtsWithLibdw), + -- Whether or not we support @-dynamic-too@ + ("Support dynamic-too", showBool $ not isWindows), + -- Whether or not we support the @-j@ flag with @--make@. + ("Support parallel --make", "YES"), + -- Whether or not we support "Foo from foo-0.1-XXX:Foo" syntax in + -- installed package info. + ("Support reexported-modules", "YES"), + -- Whether or not we support extended @-package foo (Foo)@ syntax. + ("Support thinning and renaming package flags", "YES"), + -- Whether or not we support Backpack. + ("Support Backpack", "YES"), + -- If true, we require that the 'id' field in installed package info + -- match what is passed to the @-this-unit-id@ flag for modules + -- built in it + ("Requires unified installed package IDs", "YES"), + -- Whether or not we support the @-this-package-key@ flag. Prefer + -- "Uses unit IDs" over it. + ("Uses package keys", "YES"), + -- Whether or not we support the @-this-unit-id@ flag + ("Uses unit IDs", "YES"), + -- Whether or not GHC compiles libraries as dynamic by default + ("Dynamic by default", showBool $ dYNAMIC_BY_DEFAULT dflags), + -- Whether or not GHC was compiled using -dynamic + ("GHC Dynamic", showBool dynamicGhc), + -- Whether or not GHC was compiled using -prof + ("GHC Profiled", showBool rtsIsProfiled), + ("Leading underscore", cLeadingUnderscore), + ("Debug on", show debugIsOn), + ("LibDir", topDir dflags), + -- The path of the global package database used by GHC + ("Global Package DB", systemPackageConfig dflags) + ] + where + showBool True = "YES" + showBool False = "NO" + isWindows = platformOS (targetPlatform dflags) == OSMinGW32 + expandDirectories :: FilePath -> Maybe FilePath -> String -> String + expandDirectories topd mtoold = expandToolDir mtoold . expandTopDir topd + +-- Produced by deriveConstants +#include "GHCConstantsHaskellWrappers.hs" + +bLOCK_SIZE_W :: DynFlags -> Int +bLOCK_SIZE_W dflags = bLOCK_SIZE dflags `quot` wORD_SIZE dflags + +wORD_SIZE_IN_BITS :: DynFlags -> Int +wORD_SIZE_IN_BITS dflags = wORD_SIZE dflags * 8 + +tAG_MASK :: DynFlags -> Int +tAG_MASK dflags = (1 `shiftL` tAG_BITS dflags) - 1 + +mAX_PTR_TAG :: DynFlags -> Int +mAX_PTR_TAG = tAG_MASK + +-- Might be worth caching these in targetPlatform? +tARGET_MIN_INT, tARGET_MAX_INT, tARGET_MAX_WORD :: DynFlags -> Integer +tARGET_MIN_INT dflags + = case platformWordSize (targetPlatform dflags) of + 4 -> toInteger (minBound :: Int32) + 8 -> toInteger (minBound :: Int64) + w -> panic ("tARGET_MIN_INT: Unknown platformWordSize: " ++ show w) +tARGET_MAX_INT dflags + = case platformWordSize (targetPlatform dflags) of + 4 -> toInteger (maxBound :: Int32) + 8 -> toInteger (maxBound :: Int64) + w -> panic ("tARGET_MAX_INT: Unknown platformWordSize: " ++ show w) +tARGET_MAX_WORD dflags + = case platformWordSize (targetPlatform dflags) of + 4 -> toInteger (maxBound :: Word32) + 8 -> toInteger (maxBound :: Word64) + w -> panic ("tARGET_MAX_WORD: Unknown platformWordSize: " ++ show w) + + +{- ----------------------------------------------------------------------------- +Note [DynFlags consistency] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +There are a number of number of DynFlags configurations which either +do not make sense or lead to unimplemented or buggy codepaths in the +compiler. makeDynFlagsConsistent is responsible for verifying the validity +of a set of DynFlags, fixing any issues, and reporting them back to the +caller. + +GHCi and -O +--------------- + +When using optimization, the compiler can introduce several things +(such as unboxed tuples) into the intermediate code, which GHCi later +chokes on since the bytecode interpreter can't handle this (and while +this is arguably a bug these aren't handled, there are no plans to fix +it.) + +While the driver pipeline always checks for this particular erroneous +combination when parsing flags, we also need to check when we update +the flags; this is because API clients may parse flags but update the +DynFlags afterwords, before finally running code inside a session (see +T10052 and #10052). +-} + +-- | Resolve any internal inconsistencies in a set of 'DynFlags'. +-- Returns the consistent 'DynFlags' as well as a list of warnings +-- to report to the user. +makeDynFlagsConsistent :: DynFlags -> (DynFlags, [Located String]) +-- Whenever makeDynFlagsConsistent does anything, it starts over, to +-- ensure that a later change doesn't invalidate an earlier check. +-- Be careful not to introduce potential loops! +makeDynFlagsConsistent dflags + -- Disable -dynamic-too on Windows (#8228, #7134, #5987) + | os == OSMinGW32 && gopt Opt_BuildDynamicToo dflags + = let dflags' = gopt_unset dflags Opt_BuildDynamicToo + warn = "-dynamic-too is not supported on Windows" + in loop dflags' warn + | hscTarget dflags == HscC && + not (platformUnregisterised (targetPlatform dflags)) + = if cGhcWithNativeCodeGen == "YES" + then let dflags' = dflags { hscTarget = HscAsm } + warn = "Compiler not unregisterised, so using native code generator rather than compiling via C" + in loop dflags' warn + else let dflags' = dflags { hscTarget = HscLlvm } + warn = "Compiler not unregisterised, so using LLVM rather than compiling via C" + in loop dflags' warn + | gopt Opt_Hpc dflags && hscTarget dflags == HscInterpreted + = let dflags' = gopt_unset dflags Opt_Hpc + warn = "Hpc can't be used with byte-code interpreter. Ignoring -fhpc." + in loop dflags' warn + | hscTarget dflags `elem` [HscAsm, HscLlvm] && + platformUnregisterised (targetPlatform dflags) + = loop (dflags { hscTarget = HscC }) + "Compiler unregisterised, so compiling via C" + | hscTarget dflags == HscAsm && + cGhcWithNativeCodeGen /= "YES" + = let dflags' = dflags { hscTarget = HscLlvm } + warn = "No native code generator, so using LLVM" + in loop dflags' warn + | not (osElfTarget os) && gopt Opt_PIE dflags + = loop (gopt_unset dflags Opt_PIE) + "Position-independent only supported on ELF platforms" + | os == OSDarwin && + arch == ArchX86_64 && + not (gopt Opt_PIC dflags) + = loop (gopt_set dflags Opt_PIC) + "Enabling -fPIC as it is always on for this platform" + | Left err <- checkOptLevel (optLevel dflags) dflags + = loop (updOptLevel 0 dflags) err + + | LinkInMemory <- ghcLink dflags + , not (gopt Opt_ExternalInterpreter dflags) + , rtsIsProfiled + , isObjectTarget (hscTarget dflags) + , WayProf `notElem` ways dflags + = loop dflags{ways = WayProf : ways dflags} + "Enabling -prof, because -fobject-code is enabled and GHCi is profiled" + + | otherwise = (dflags, []) + where loc = mkGeneralSrcSpan (fsLit "when making flags consistent") + loop updated_dflags warning + = case makeDynFlagsConsistent updated_dflags of + (dflags', ws) -> (dflags', L loc warning : ws) + platform = targetPlatform dflags + arch = platformArch platform + os = platformOS platform + + +-------------------------------------------------------------------------- +-- Do not use unsafeGlobalDynFlags! +-- +-- unsafeGlobalDynFlags is a hack, necessary because we need to be able +-- to show SDocs when tracing, but we don't always have DynFlags +-- available. +-- +-- Do not use it if you can help it. You may get the wrong value, or this +-- panic! + +-- | This is the value that 'unsafeGlobalDynFlags' takes before it is +-- initialized. +defaultGlobalDynFlags :: DynFlags +defaultGlobalDynFlags = + (defaultDynFlags settings (llvmTargets, llvmPasses)) { verbosity = 2 } + where + settings = panic "v_unsafeGlobalDynFlags: settings not initialised" + llvmTargets = panic "v_unsafeGlobalDynFlags: llvmTargets not initialised" + llvmPasses = panic "v_unsafeGlobalDynFlags: llvmPasses not initialised" + +#if STAGE < 2 +GLOBAL_VAR(v_unsafeGlobalDynFlags, defaultGlobalDynFlags, DynFlags) +#else +SHARED_GLOBAL_VAR( v_unsafeGlobalDynFlags + , getOrSetLibHSghcGlobalDynFlags + , "getOrSetLibHSghcGlobalDynFlags" + , defaultGlobalDynFlags + , DynFlags ) +#endif + +unsafeGlobalDynFlags :: DynFlags +unsafeGlobalDynFlags = unsafePerformIO $ readIORef v_unsafeGlobalDynFlags + +setUnsafeGlobalDynFlags :: DynFlags -> IO () +setUnsafeGlobalDynFlags = writeIORef v_unsafeGlobalDynFlags + +-- ----------------------------------------------------------------------------- +-- SSE and AVX + +-- TODO: Instead of using a separate predicate (i.e. isSse2Enabled) to +-- check if SSE is enabled, we might have x86-64 imply the -msse2 +-- flag. + +data SseVersion = SSE1 + | SSE2 + | SSE3 + | SSE4 + | SSE42 + deriving (Eq, Ord) + +isSseEnabled :: DynFlags -> Bool +isSseEnabled dflags = case platformArch (targetPlatform dflags) of + ArchX86_64 -> True + ArchX86 -> sseVersion dflags >= Just SSE1 + _ -> False + +isSse2Enabled :: DynFlags -> Bool +isSse2Enabled dflags = case platformArch (targetPlatform dflags) of + ArchX86_64 -> -- SSE2 is fixed on for x86_64. It would be + -- possible to make it optional, but we'd need to + -- fix at least the foreign call code where the + -- calling convention specifies the use of xmm regs, + -- and possibly other places. + True + ArchX86 -> sseVersion dflags >= Just SSE2 + _ -> False + +isSse4_2Enabled :: DynFlags -> Bool +isSse4_2Enabled dflags = sseVersion dflags >= Just SSE42 + +isAvxEnabled :: DynFlags -> Bool +isAvxEnabled dflags = avx dflags || avx2 dflags || avx512f dflags + +isAvx2Enabled :: DynFlags -> Bool +isAvx2Enabled dflags = avx2 dflags || avx512f dflags + +isAvx512cdEnabled :: DynFlags -> Bool +isAvx512cdEnabled dflags = avx512cd dflags + +isAvx512erEnabled :: DynFlags -> Bool +isAvx512erEnabled dflags = avx512er dflags + +isAvx512fEnabled :: DynFlags -> Bool +isAvx512fEnabled dflags = avx512f dflags + +isAvx512pfEnabled :: DynFlags -> Bool +isAvx512pfEnabled dflags = avx512pf dflags + +-- ----------------------------------------------------------------------------- +-- BMI2 + +data BmiVersion = BMI1 + | BMI2 + deriving (Eq, Ord) + +isBmiEnabled :: DynFlags -> Bool +isBmiEnabled dflags = case platformArch (targetPlatform dflags) of + ArchX86_64 -> bmiVersion dflags >= Just BMI1 + ArchX86 -> bmiVersion dflags >= Just BMI1 + _ -> False + +isBmi2Enabled :: DynFlags -> Bool +isBmi2Enabled dflags = case platformArch (targetPlatform dflags) of + ArchX86_64 -> bmiVersion dflags >= Just BMI2 + ArchX86 -> bmiVersion dflags >= Just BMI2 + _ -> False + +-- ----------------------------------------------------------------------------- +-- Linker/compiler information + +-- LinkerInfo contains any extra options needed by the system linker. +data LinkerInfo + = GnuLD [Option] + | GnuGold [Option] + | LlvmLLD [Option] + | DarwinLD [Option] + | SolarisLD [Option] + | AixLD [Option] + | UnknownLD + deriving Eq + +-- CompilerInfo tells us which C compiler we're using +data CompilerInfo + = GCC + | Clang + | AppleClang + | AppleClang51 + | UnknownCC + deriving Eq + +-- ----------------------------------------------------------------------------- +-- RTS hooks + +-- Convert sizes like "3.5M" into integers +decodeSize :: String -> Integer +decodeSize str + | c == "" = truncate n + | c == "K" || c == "k" = truncate (n * 1000) + | c == "M" || c == "m" = truncate (n * 1000 * 1000) + | c == "G" || c == "g" = truncate (n * 1000 * 1000 * 1000) + | otherwise = throwGhcException (CmdLineError ("can't decode size: " ++ str)) + where (m, c) = span pred str + n = readRational m + pred c = isDigit c || c == '.' + +foreign import ccall unsafe "setHeapSize" setHeapSize :: Int -> IO () +foreign import ccall unsafe "enableTimingStats" enableTimingStats :: IO () + +-- ----------------------------------------------------------------------------- +-- Types for managing temporary files. +-- +-- these are here because FilesToClean is used in DynFlags + +-- | A collection of files that must be deleted before ghc exits. +-- The current collection +-- is stored in an IORef in DynFlags, 'filesToClean'. +data FilesToClean = FilesToClean { + ftcGhcSession :: !(Set FilePath), + -- ^ Files that will be deleted at the end of runGhc(T) + ftcCurrentModule :: !(Set FilePath) + -- ^ Files that will be deleted the next time + -- 'FileCleanup.cleanCurrentModuleTempFiles' is called, or otherwise at the + -- end of the session. + } + +-- | An empty FilesToClean +emptyFilesToClean :: FilesToClean +emptyFilesToClean = FilesToClean Set.empty Set.empty diff --git a/compiler/main/DynFlags.hs-boot b/compiler/main/DynFlags.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/main/DynFlags.hs-boot @@ -0,0 +1,20 @@ +module DynFlags where + +import GhcPrelude +import Platform + +data DynFlags +data DumpFlag +data GeneralFlag + +targetPlatform :: DynFlags -> Platform +pprUserLength :: DynFlags -> Int +pprCols :: DynFlags -> Int +unsafeGlobalDynFlags :: DynFlags +useUnicode :: DynFlags -> Bool +useUnicodeSyntax :: DynFlags -> Bool +useStarIsType :: DynFlags -> Bool +shouldUseColor :: DynFlags -> Bool +shouldUseHexWordLiterals :: DynFlags -> Bool +hasPprDebug :: DynFlags -> Bool +hasNoDebugOutput :: DynFlags -> Bool diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs new file mode 100644 --- /dev/null +++ b/compiler/main/ErrUtils.hs @@ -0,0 +1,747 @@ +{- +(c) The AQUA Project, Glasgow University, 1994-1998 + +\section[ErrsUtils]{Utilities for error reporting} +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RecordWildCards #-} + +module ErrUtils ( + -- * Basic types + Validity(..), andValid, allValid, isValid, getInvalids, orValid, + Severity(..), + + -- * Messages + ErrMsg, errMsgDoc, errMsgSeverity, errMsgReason, + ErrDoc, errDoc, errDocImportant, errDocContext, errDocSupplementary, + WarnMsg, MsgDoc, + Messages, ErrorMessages, WarningMessages, + unionMessages, + errMsgSpan, errMsgContext, + errorsFound, isEmptyMessages, + isWarnMsgFatal, + warningsToMessages, + + -- ** Formatting + pprMessageBag, pprErrMsgBagWithLoc, + pprLocErrMsg, printBagOfErrors, + formatErrDoc, + + -- ** Construction + emptyMessages, mkLocMessage, mkLocMessageAnn, makeIntoWarning, + mkErrMsg, mkPlainErrMsg, mkErrDoc, mkLongErrMsg, mkWarnMsg, + mkPlainWarnMsg, + mkLongWarnMsg, + + -- * Utilities + doIfSet, doIfSet_dyn, + getCaretDiagnostic, + + -- * Dump files + dumpIfSet, dumpIfSet_dyn, dumpIfSet_dyn_printer, + mkDumpDoc, dumpSDoc, dumpSDocForUser, + dumpSDocWithStyle, + + -- * Issuing messages during compilation + putMsg, printInfoForUser, printOutputForUser, + logInfo, logOutput, + errorMsg, warningMsg, + fatalErrorMsg, fatalErrorMsg'', + compilationProgressMsg, + showPass, withTiming, + debugTraceMsg, + ghcExit, + prettyPrintGhcErrors, + traceCmd + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import Bag +import Exception +import Outputable +import Panic +import qualified PprColour as Col +import SrcLoc +import DynFlags +import FastString (unpackFS) +import StringBuffer (atLine, hGetStringBuffer, len, lexemeToString) +import Json + +import System.Directory +import System.Exit ( ExitCode(..), exitWith ) +import System.FilePath ( takeDirectory, () ) +import Data.List +import qualified Data.Set as Set +import Data.IORef +import Data.Maybe ( fromMaybe ) +import Data.Ord +import Data.Time +import Control.Monad +import Control.Monad.IO.Class +import System.IO +import System.IO.Error ( catchIOError ) +import GHC.Conc ( getAllocationCounter ) +import System.CPUTime + +------------------------- +type MsgDoc = SDoc + +------------------------- +data Validity + = IsValid -- ^ Everything is fine + | NotValid MsgDoc -- ^ A problem, and some indication of why + +isValid :: Validity -> Bool +isValid IsValid = True +isValid (NotValid {}) = False + +andValid :: Validity -> Validity -> Validity +andValid IsValid v = v +andValid v _ = v + +-- | If they aren't all valid, return the first +allValid :: [Validity] -> Validity +allValid [] = IsValid +allValid (v : vs) = v `andValid` allValid vs + +getInvalids :: [Validity] -> [MsgDoc] +getInvalids vs = [d | NotValid d <- vs] + +orValid :: Validity -> Validity -> Validity +orValid IsValid _ = IsValid +orValid _ v = v + +-- ----------------------------------------------------------------------------- +-- Basic error messages: just render a message with a source location. + +type Messages = (WarningMessages, ErrorMessages) +type WarningMessages = Bag WarnMsg +type ErrorMessages = Bag ErrMsg + +unionMessages :: Messages -> Messages -> Messages +unionMessages (warns1, errs1) (warns2, errs2) = + (warns1 `unionBags` warns2, errs1 `unionBags` errs2) + +data ErrMsg = ErrMsg { + errMsgSpan :: SrcSpan, + errMsgContext :: PrintUnqualified, + errMsgDoc :: ErrDoc, + -- | This has the same text as errDocImportant . errMsgDoc. + errMsgShortString :: String, + errMsgSeverity :: Severity, + errMsgReason :: WarnReason + } + -- The SrcSpan is used for sorting errors into line-number order + + +-- | Categorise error msgs by their importance. This is so each section can +-- be rendered visually distinct. See Note [Error report] for where these come +-- from. +data ErrDoc = ErrDoc { + -- | Primary error msg. + errDocImportant :: [MsgDoc], + -- | Context e.g. \"In the second argument of ...\". + errDocContext :: [MsgDoc], + -- | Supplementary information, e.g. \"Relevant bindings include ...\". + errDocSupplementary :: [MsgDoc] + } + +errDoc :: [MsgDoc] -> [MsgDoc] -> [MsgDoc] -> ErrDoc +errDoc = ErrDoc + +type WarnMsg = ErrMsg + +data Severity + = SevOutput + | SevFatal + | SevInteractive + + | SevDump + -- ^ Log message intended for compiler developers + -- No file/line/column stuff + + | SevInfo + -- ^ Log messages intended for end users. + -- No file/line/column stuff. + + | SevWarning + | SevError + -- ^ SevWarning and SevError are used for warnings and errors + -- o The message has a file/line/column heading, + -- plus "warning:" or "error:", + -- added by mkLocMessags + -- o Output is intended for end users + deriving Show + + +instance ToJson Severity where + json s = JSString (show s) + + +instance Show ErrMsg where + show em = errMsgShortString em + +pprMessageBag :: Bag MsgDoc -> SDoc +pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs)) + +-- | Make an unannotated error message with location info. +mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc +mkLocMessage = mkLocMessageAnn Nothing + +-- | Make a possibly annotated error message with location info. +mkLocMessageAnn + :: Maybe String -- ^ optional annotation + -> Severity -- ^ severity + -> SrcSpan -- ^ location + -> MsgDoc -- ^ message + -> MsgDoc + -- Always print the location, even if it is unhelpful. Error messages + -- are supposed to be in a standard format, and one without a location + -- would look strange. Better to say explicitly "". +mkLocMessageAnn ann severity locn msg + = sdocWithDynFlags $ \dflags -> + let locn' = if gopt Opt_ErrorSpans dflags + then ppr locn + else ppr (srcSpanStart locn) + + sevColour = getSeverityColour severity (colScheme dflags) + + -- Add optional information + optAnn = case ann of + Nothing -> text "" + Just i -> text " [" <> coloured sevColour (text i) <> text "]" + + -- Add prefixes, like Foo.hs:34: warning: + -- + header = locn' <> colon <+> + coloured sevColour sevText <> optAnn + + in coloured (Col.sMessage (colScheme dflags)) + (hang (coloured (Col.sHeader (colScheme dflags)) header) 4 + msg) + + where + sevText = + case severity of + SevWarning -> text "warning:" + SevError -> text "error:" + SevFatal -> text "fatal:" + _ -> empty + +getSeverityColour :: Severity -> Col.Scheme -> Col.PprColour +getSeverityColour SevWarning = Col.sWarning +getSeverityColour SevError = Col.sError +getSeverityColour SevFatal = Col.sFatal +getSeverityColour _ = const mempty + +getCaretDiagnostic :: Severity -> SrcSpan -> IO MsgDoc +getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty +getCaretDiagnostic severity (RealSrcSpan span) = do + caretDiagnostic <$> getSrcLine (srcSpanFile span) row + + where + getSrcLine fn i = + getLine i (unpackFS fn) + `catchIOError` \_ -> + pure Nothing + + getLine i fn = do + -- StringBuffer has advantages over readFile: + -- (a) no lazy IO, otherwise IO exceptions may occur in pure code + -- (b) always UTF-8, rather than some system-dependent encoding + -- (Haskell source code must be UTF-8 anyway) + content <- hGetStringBuffer fn + case atLine i content of + Just at_line -> pure $ + case lines (fix <$> lexemeToString at_line (len at_line)) of + srcLine : _ -> Just srcLine + _ -> Nothing + _ -> pure Nothing + + -- allow user to visibly see that their code is incorrectly encoded + -- (StringBuffer.nextChar uses \0 to represent undecodable characters) + fix '\0' = '\xfffd' + fix c = c + + row = srcSpanStartLine span + rowStr = show row + multiline = row /= srcSpanEndLine span + + caretDiagnostic Nothing = empty + caretDiagnostic (Just srcLineWithNewline) = + sdocWithDynFlags $ \ dflags -> + let sevColour = getSeverityColour severity (colScheme dflags) + marginColour = Col.sMargin (colScheme dflags) + in + coloured marginColour (text marginSpace) <> + text ("\n") <> + coloured marginColour (text marginRow) <> + text (" " ++ srcLinePre) <> + coloured sevColour (text srcLineSpan) <> + text (srcLinePost ++ "\n") <> + coloured marginColour (text marginSpace) <> + coloured sevColour (text (" " ++ caretLine)) + + where + + -- expand tabs in a device-independent manner #13664 + expandTabs tabWidth i s = + case s of + "" -> "" + '\t' : cs -> replicate effectiveWidth ' ' ++ + expandTabs tabWidth (i + effectiveWidth) cs + c : cs -> c : expandTabs tabWidth (i + 1) cs + where effectiveWidth = tabWidth - i `mod` tabWidth + + srcLine = filter (/= '\n') (expandTabs 8 0 srcLineWithNewline) + + start = srcSpanStartCol span - 1 + end | multiline = length srcLine + | otherwise = srcSpanEndCol span - 1 + width = max 1 (end - start) + + marginWidth = length rowStr + marginSpace = replicate marginWidth ' ' ++ " |" + marginRow = rowStr ++ " |" + + (srcLinePre, srcLineRest) = splitAt start srcLine + (srcLineSpan, srcLinePost) = splitAt width srcLineRest + + caretEllipsis | multiline = "..." + | otherwise = "" + caretLine = replicate start ' ' ++ replicate width '^' ++ caretEllipsis + +makeIntoWarning :: WarnReason -> ErrMsg -> ErrMsg +makeIntoWarning reason err = err + { errMsgSeverity = SevWarning + , errMsgReason = reason } + +-- ----------------------------------------------------------------------------- +-- Collecting up messages for later ordering and printing. + +mk_err_msg :: DynFlags -> Severity -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg +mk_err_msg dflags sev locn print_unqual doc + = ErrMsg { errMsgSpan = locn + , errMsgContext = print_unqual + , errMsgDoc = doc + , errMsgShortString = showSDoc dflags (vcat (errDocImportant doc)) + , errMsgSeverity = sev + , errMsgReason = NoReason } + +mkErrDoc :: DynFlags -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg +mkErrDoc dflags = mk_err_msg dflags SevError + +mkLongErrMsg, mkLongWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg +-- ^ A long (multi-line) error message +mkErrMsg, mkWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> ErrMsg +-- ^ A short (one-line) error message +mkPlainErrMsg, mkPlainWarnMsg :: DynFlags -> SrcSpan -> MsgDoc -> ErrMsg +-- ^ Variant that doesn't care about qualified/unqualified names + +mkLongErrMsg dflags locn unqual msg extra = mk_err_msg dflags SevError locn unqual (ErrDoc [msg] [] [extra]) +mkErrMsg dflags locn unqual msg = mk_err_msg dflags SevError locn unqual (ErrDoc [msg] [] []) +mkPlainErrMsg dflags locn msg = mk_err_msg dflags SevError locn alwaysQualify (ErrDoc [msg] [] []) +mkLongWarnMsg dflags locn unqual msg extra = mk_err_msg dflags SevWarning locn unqual (ErrDoc [msg] [] [extra]) +mkWarnMsg dflags locn unqual msg = mk_err_msg dflags SevWarning locn unqual (ErrDoc [msg] [] []) +mkPlainWarnMsg dflags locn msg = mk_err_msg dflags SevWarning locn alwaysQualify (ErrDoc [msg] [] []) + +---------------- +emptyMessages :: Messages +emptyMessages = (emptyBag, emptyBag) + +isEmptyMessages :: Messages -> Bool +isEmptyMessages (warns, errs) = isEmptyBag warns && isEmptyBag errs + +errorsFound :: DynFlags -> Messages -> Bool +errorsFound _dflags (_warns, errs) = not (isEmptyBag errs) + +warningsToMessages :: DynFlags -> WarningMessages -> Messages +warningsToMessages dflags = + partitionBagWith $ \warn -> + case isWarnMsgFatal dflags warn of + Nothing -> Left warn + Just err_reason -> + Right warn{ errMsgSeverity = SevError + , errMsgReason = ErrReason err_reason } + +printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO () +printBagOfErrors dflags bag_of_errors + = sequence_ [ let style = mkErrStyle dflags unqual + in putLogMsg dflags reason sev s style (formatErrDoc dflags doc) + | ErrMsg { errMsgSpan = s, + errMsgDoc = doc, + errMsgSeverity = sev, + errMsgReason = reason, + errMsgContext = unqual } <- sortMsgBag (Just dflags) + bag_of_errors ] + +formatErrDoc :: DynFlags -> ErrDoc -> SDoc +formatErrDoc dflags (ErrDoc important context supplementary) + = case msgs of + [msg] -> vcat msg + _ -> vcat $ map starred msgs + where + msgs = filter (not . null) $ map (filter (not . Outputable.isEmpty dflags)) + [important, context, supplementary] + starred = (bullet<+>) . vcat + +pprErrMsgBagWithLoc :: Bag ErrMsg -> [SDoc] +pprErrMsgBagWithLoc bag = [ pprLocErrMsg item | item <- sortMsgBag Nothing bag ] + +pprLocErrMsg :: ErrMsg -> SDoc +pprLocErrMsg (ErrMsg { errMsgSpan = s + , errMsgDoc = doc + , errMsgSeverity = sev + , errMsgContext = unqual }) + = sdocWithDynFlags $ \dflags -> + withPprStyle (mkErrStyle dflags unqual) $ + mkLocMessage sev s (formatErrDoc dflags doc) + +sortMsgBag :: Maybe DynFlags -> Bag ErrMsg -> [ErrMsg] +sortMsgBag dflags = maybeLimit . sortBy (maybeFlip cmp) . bagToList + where maybeFlip :: (a -> a -> b) -> (a -> a -> b) + maybeFlip + | fromMaybe False (fmap reverseErrors dflags) = flip + | otherwise = id + cmp = comparing errMsgSpan + maybeLimit = case join (fmap maxErrors dflags) of + Nothing -> id + Just err_limit -> take err_limit + +ghcExit :: DynFlags -> Int -> IO () +ghcExit dflags val + | val == 0 = exitWith ExitSuccess + | otherwise = do errorMsg dflags (text "\nCompilation had errors\n\n") + exitWith (ExitFailure val) + +doIfSet :: Bool -> IO () -> IO () +doIfSet flag action | flag = action + | otherwise = return () + +doIfSet_dyn :: DynFlags -> GeneralFlag -> IO () -> IO() +doIfSet_dyn dflags flag action | gopt flag dflags = action + | otherwise = return () + +-- ----------------------------------------------------------------------------- +-- Dumping + +dumpIfSet :: DynFlags -> Bool -> String -> SDoc -> IO () +dumpIfSet dflags flag hdr doc + | not flag = return () + | otherwise = putLogMsg dflags + NoReason + SevDump + noSrcSpan + (defaultDumpStyle dflags) + (mkDumpDoc hdr doc) + +-- | a wrapper around 'dumpSDoc'. +-- First check whether the dump flag is set +-- Do nothing if it is unset +dumpIfSet_dyn :: DynFlags -> DumpFlag -> String -> SDoc -> IO () +dumpIfSet_dyn dflags flag hdr doc + = when (dopt flag dflags) $ dumpSDoc dflags alwaysQualify flag hdr doc + +-- | a wrapper around 'dumpSDoc'. +-- First check whether the dump flag is set +-- Do nothing if it is unset +-- +-- Unlike 'dumpIfSet_dyn', +-- has a printer argument but no header argument +dumpIfSet_dyn_printer :: PrintUnqualified + -> DynFlags -> DumpFlag -> SDoc -> IO () +dumpIfSet_dyn_printer printer dflags flag doc + = when (dopt flag dflags) $ dumpSDoc dflags printer flag "" doc + +mkDumpDoc :: String -> SDoc -> SDoc +mkDumpDoc hdr doc + = vcat [blankLine, + line <+> text hdr <+> line, + doc, + blankLine] + where + line = text (replicate 20 '=') + +-- | Run an action with the handle of a 'DumpFlag' if we are outputting to a +-- file, otherwise 'Nothing'. +withDumpFileHandle :: DynFlags -> DumpFlag -> (Maybe Handle -> IO ()) -> IO () +withDumpFileHandle dflags flag action = do + let mFile = chooseDumpFile dflags flag + case mFile of + Just fileName -> do + let gdref = generatedDumps dflags + gd <- readIORef gdref + let append = Set.member fileName gd + mode = if append then AppendMode else WriteMode + unless append $ + writeIORef gdref (Set.insert fileName gd) + createDirectoryIfMissing True (takeDirectory fileName) + withFile fileName mode $ \handle -> do + -- We do not want the dump file to be affected by + -- environment variables, but instead to always use + -- UTF8. See: + -- https://gitlab.haskell.org/ghc/ghc/issues/10762 + hSetEncoding handle utf8 + + action (Just handle) + Nothing -> action Nothing + + +dumpSDoc, dumpSDocForUser + :: DynFlags -> PrintUnqualified -> DumpFlag -> String -> SDoc -> IO () + +-- | A wrapper around 'dumpSDocWithStyle' which uses 'PprDump' style. +dumpSDoc dflags print_unqual + = dumpSDocWithStyle dump_style dflags + where dump_style = mkDumpStyle dflags print_unqual + +-- | A wrapper around 'dumpSDocWithStyle' which uses 'PprUser' style. +dumpSDocForUser dflags print_unqual + = dumpSDocWithStyle user_style dflags + where user_style = mkUserStyle dflags print_unqual AllTheWay + +-- | Write out a dump. +-- If --dump-to-file is set then this goes to a file. +-- otherwise emit to stdout. +-- +-- When @hdr@ is empty, we print in a more compact format (no separators and +-- blank lines) +-- +-- The 'DumpFlag' is used only to choose the filename to use if @--dump-to-file@ +-- is used; it is not used to decide whether to dump the output +dumpSDocWithStyle :: PprStyle -> DynFlags -> DumpFlag -> String -> SDoc -> IO () +dumpSDocWithStyle sty dflags flag hdr doc = + withDumpFileHandle dflags flag writeDump + where + -- write dump to file + writeDump (Just handle) = do + doc' <- if null hdr + then return doc + else do t <- getCurrentTime + let timeStamp = if (gopt Opt_SuppressTimestamps dflags) + then empty + else text (show t) + let d = timeStamp + $$ blankLine + $$ doc + return $ mkDumpDoc hdr d + defaultLogActionHPrintDoc dflags handle doc' sty + + -- write the dump to stdout + writeDump Nothing = do + let (doc', severity) + | null hdr = (doc, SevOutput) + | otherwise = (mkDumpDoc hdr doc, SevDump) + putLogMsg dflags NoReason severity noSrcSpan sty doc' + + +-- | Choose where to put a dump file based on DynFlags +-- +chooseDumpFile :: DynFlags -> DumpFlag -> Maybe FilePath +chooseDumpFile dflags flag + + | gopt Opt_DumpToFile dflags || flag == Opt_D_th_dec_file + , Just prefix <- getPrefix + = Just $ setDir (prefix ++ (beautifyDumpName flag)) + + | otherwise + = Nothing + + where getPrefix + -- dump file location is being forced + -- by the --ddump-file-prefix flag. + | Just prefix <- dumpPrefixForce dflags + = Just prefix + -- dump file location chosen by DriverPipeline.runPipeline + | Just prefix <- dumpPrefix dflags + = Just prefix + -- we haven't got a place to put a dump file. + | otherwise + = Nothing + setDir f = case dumpDir dflags of + Just d -> d f + Nothing -> f + +-- | Build a nice file name from name of a 'DumpFlag' constructor +beautifyDumpName :: DumpFlag -> String +beautifyDumpName Opt_D_th_dec_file = "th.hs" +beautifyDumpName flag + = let str = show flag + suff = case stripPrefix "Opt_D_" str of + Just x -> x + Nothing -> panic ("Bad flag name: " ++ str) + dash = map (\c -> if c == '_' then '-' else c) suff + in dash + + +-- ----------------------------------------------------------------------------- +-- Outputting messages from the compiler + +-- We want all messages to go through one place, so that we can +-- redirect them if necessary. For example, when GHC is used as a +-- library we might want to catch all messages that GHC tries to +-- output and do something else with them. + +ifVerbose :: DynFlags -> Int -> IO () -> IO () +ifVerbose dflags val act + | verbosity dflags >= val = act + | otherwise = return () + +errorMsg :: DynFlags -> MsgDoc -> IO () +errorMsg dflags msg + = putLogMsg dflags NoReason SevError noSrcSpan (defaultErrStyle dflags) msg + +warningMsg :: DynFlags -> MsgDoc -> IO () +warningMsg dflags msg + = putLogMsg dflags NoReason SevWarning noSrcSpan (defaultErrStyle dflags) msg + +fatalErrorMsg :: DynFlags -> MsgDoc -> IO () +fatalErrorMsg dflags msg = + putLogMsg dflags NoReason SevFatal noSrcSpan (defaultErrStyle dflags) msg + +fatalErrorMsg'' :: FatalMessager -> String -> IO () +fatalErrorMsg'' fm msg = fm msg + +compilationProgressMsg :: DynFlags -> String -> IO () +compilationProgressMsg dflags msg + = ifVerbose dflags 1 $ + logOutput dflags (defaultUserStyle dflags) (text msg) + +showPass :: DynFlags -> String -> IO () +showPass dflags what + = ifVerbose dflags 2 $ + logInfo dflags (defaultUserStyle dflags) (text "***" <+> text what <> colon) + +-- | Time a compilation phase. +-- +-- When timings are enabled (e.g. with the @-v2@ flag), the allocations +-- and CPU time used by the phase will be reported to stderr. Consider +-- a typical usage: @withTiming getDynFlags (text "simplify") force pass@. +-- When timings are enabled the following costs are included in the +-- produced accounting, +-- +-- - The cost of executing @pass@ to a result @r@ in WHNF +-- - The cost of evaluating @force r@ to WHNF (e.g. @()@) +-- +-- The choice of the @force@ function depends upon the amount of forcing +-- desired; the goal here is to ensure that the cost of evaluating the result +-- is, to the greatest extent possible, included in the accounting provided by +-- 'withTiming'. Often the pass already sufficiently forces its result during +-- construction; in this case @const ()@ is a reasonable choice. +-- In other cases, it is necessary to evaluate the result to normal form, in +-- which case something like @Control.DeepSeq.rnf@ is appropriate. +-- +-- To avoid adversely affecting compiler performance when timings are not +-- requested, the result is only forced when timings are enabled. +withTiming :: MonadIO m + => m DynFlags -- ^ A means of getting a 'DynFlags' (often + -- 'getDynFlags' will work here) + -> SDoc -- ^ The name of the phase + -> (a -> ()) -- ^ A function to force the result + -- (often either @const ()@ or 'rnf') + -> m a -- ^ The body of the phase to be timed + -> m a +withTiming getDFlags what force_result action + = do dflags <- getDFlags + if verbosity dflags >= 2 || dopt Opt_D_dump_timings dflags + then do liftIO $ logInfo dflags (defaultUserStyle dflags) + $ text "***" <+> what <> colon + alloc0 <- liftIO getAllocationCounter + start <- liftIO getCPUTime + !r <- action + () <- pure $ force_result r + end <- liftIO getCPUTime + alloc1 <- liftIO getAllocationCounter + -- recall that allocation counter counts down + let alloc = alloc0 - alloc1 + time = realToFrac (end - start) * 1e-9 + + when (verbosity dflags >= 2) + $ liftIO $ logInfo dflags (defaultUserStyle dflags) + (text "!!!" <+> what <> colon <+> text "finished in" + <+> doublePrec 2 time + <+> text "milliseconds" + <> comma + <+> text "allocated" + <+> doublePrec 3 (realToFrac alloc / 1024 / 1024) + <+> text "megabytes") + + liftIO $ dumpIfSet_dyn dflags Opt_D_dump_timings "" + $ text $ showSDocOneLine dflags + $ hsep [ what <> colon + , text "alloc=" <> ppr alloc + , text "time=" <> doublePrec 3 time + ] + pure r + else action + +debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO () +debugTraceMsg dflags val msg = ifVerbose dflags val $ + logInfo dflags (defaultDumpStyle dflags) msg +putMsg :: DynFlags -> MsgDoc -> IO () +putMsg dflags msg = logInfo dflags (defaultUserStyle dflags) msg + +printInfoForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO () +printInfoForUser dflags print_unqual msg + = logInfo dflags (mkUserStyle dflags print_unqual AllTheWay) msg + +printOutputForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO () +printOutputForUser dflags print_unqual msg + = logOutput dflags (mkUserStyle dflags print_unqual AllTheWay) msg + +logInfo :: DynFlags -> PprStyle -> MsgDoc -> IO () +logInfo dflags sty msg + = putLogMsg dflags NoReason SevInfo noSrcSpan sty msg + +logOutput :: DynFlags -> PprStyle -> MsgDoc -> IO () +-- ^ Like 'logInfo' but with 'SevOutput' rather then 'SevInfo' +logOutput dflags sty msg + = putLogMsg dflags NoReason SevOutput noSrcSpan sty msg + +prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a +prettyPrintGhcErrors dflags + = ghandle $ \e -> case e of + PprPanic str doc -> + pprDebugAndThen dflags panic (text str) doc + PprSorry str doc -> + pprDebugAndThen dflags sorry (text str) doc + PprProgramError str doc -> + pprDebugAndThen dflags pgmError (text str) doc + _ -> + liftIO $ throwIO e + +-- | Checks if given 'WarnMsg' is a fatal warning. +isWarnMsgFatal :: DynFlags -> WarnMsg -> Maybe (Maybe WarningFlag) +isWarnMsgFatal dflags ErrMsg{errMsgReason = Reason wflag} + = if wopt_fatal wflag dflags + then Just (Just wflag) + else Nothing +isWarnMsgFatal dflags _ + = if gopt Opt_WarnIsError dflags + then Just Nothing + else Nothing + +traceCmd :: DynFlags -> String -> String -> IO a -> IO a +-- trace the command (at two levels of verbosity) +traceCmd dflags phase_name cmd_line action + = do { let verb = verbosity dflags + ; showPass dflags phase_name + ; debugTraceMsg dflags 3 (text cmd_line) + ; case flushErr dflags of + FlushErr io -> io + + -- And run it! + ; action `catchIO` handle_exn verb + } + where + handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n') + ; debugTraceMsg dflags 2 + (text "Failed:" + <+> text cmd_line + <+> text (show exn)) + ; throwGhcExceptionIO (ProgramError (show exn))} diff --git a/compiler/main/ErrUtils.hs-boot b/compiler/main/ErrUtils.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/main/ErrUtils.hs-boot @@ -0,0 +1,26 @@ +module ErrUtils where + +import GhcPrelude +import Outputable (SDoc, PrintUnqualified ) +import SrcLoc (SrcSpan) +import Json +import {-# SOURCE #-} DynFlags ( DynFlags, DumpFlag ) + +data Severity + = SevOutput + | SevFatal + | SevInteractive + | SevDump + | SevInfo + | SevWarning + | SevError + + +type MsgDoc = SDoc + +mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc +mkLocMessageAnn :: Maybe String -> Severity -> SrcSpan -> MsgDoc -> MsgDoc +getCaretDiagnostic :: Severity -> SrcSpan -> IO MsgDoc +dumpSDoc :: DynFlags -> PrintUnqualified -> DumpFlag -> String -> SDoc -> IO () + +instance ToJson Severity diff --git a/compiler/main/FileCleanup.hs b/compiler/main/FileCleanup.hs new file mode 100644 --- /dev/null +++ b/compiler/main/FileCleanup.hs @@ -0,0 +1,314 @@ +{-# LANGUAGE CPP #-} +module FileCleanup + ( TempFileLifetime(..) + , cleanTempDirs, cleanTempFiles, cleanCurrentModuleTempFiles + , addFilesToClean, changeTempFilesLifetime + , newTempName, newTempLibName, newTempDir + , withSystemTempDirectory, withTempDirectory + ) where + +import GhcPrelude + +import DynFlags +import ErrUtils +import Outputable +import Util +import Exception +import DriverPhases + +import Control.Monad +import Data.List +import qualified Data.Set as Set +import qualified Data.Map as Map +import Data.IORef +import System.Directory +import System.FilePath +import System.IO.Error + +#if !defined(mingw32_HOST_OS) +import qualified System.Posix.Internals +#endif + +-- | Used when a temp file is created. This determines which component Set of +-- FilesToClean will get the temp file +data TempFileLifetime + = TFL_CurrentModule + -- ^ A file with lifetime TFL_CurrentModule will be cleaned up at the + -- end of upweep_mod + | TFL_GhcSession + -- ^ A file with lifetime TFL_GhcSession will be cleaned up at the end of + -- runGhc(T) + deriving (Show) + +cleanTempDirs :: DynFlags -> IO () +cleanTempDirs dflags + = unless (gopt Opt_KeepTmpFiles dflags) + $ mask_ + $ do let ref = dirsToClean dflags + ds <- atomicModifyIORef' ref $ \ds -> (Map.empty, ds) + removeTmpDirs dflags (Map.elems ds) + +-- | Delete all files in @filesToClean dflags@. +cleanTempFiles :: DynFlags -> IO () +cleanTempFiles dflags + = unless (gopt Opt_KeepTmpFiles dflags) + $ mask_ + $ do let ref = filesToClean dflags + to_delete <- atomicModifyIORef' ref $ + \FilesToClean + { ftcCurrentModule = cm_files + , ftcGhcSession = gs_files + } -> ( emptyFilesToClean + , Set.toList cm_files ++ Set.toList gs_files) + removeTmpFiles dflags to_delete + +-- | Delete all files in @filesToClean dflags@. That have lifetime +-- TFL_CurrentModule. +-- If a file must be cleaned eventually, but must survive a +-- cleanCurrentModuleTempFiles, ensure it has lifetime TFL_GhcSession. +cleanCurrentModuleTempFiles :: DynFlags -> IO () +cleanCurrentModuleTempFiles dflags + = unless (gopt Opt_KeepTmpFiles dflags) + $ mask_ + $ do let ref = filesToClean dflags + to_delete <- atomicModifyIORef' ref $ + \ftc@FilesToClean{ftcCurrentModule = cm_files} -> + (ftc {ftcCurrentModule = Set.empty}, Set.toList cm_files) + removeTmpFiles dflags to_delete + +-- | Ensure that new_files are cleaned on the next call of +-- 'cleanTempFiles' or 'cleanCurrentModuleTempFiles', depending on lifetime. +-- If any of new_files are already tracked, they will have their lifetime +-- updated. +addFilesToClean :: DynFlags -> TempFileLifetime -> [FilePath] -> IO () +addFilesToClean dflags lifetime new_files = modifyIORef' (filesToClean dflags) $ + \FilesToClean + { ftcCurrentModule = cm_files + , ftcGhcSession = gs_files + } -> case lifetime of + TFL_CurrentModule -> FilesToClean + { ftcCurrentModule = cm_files `Set.union` new_files_set + , ftcGhcSession = gs_files `Set.difference` new_files_set + } + TFL_GhcSession -> FilesToClean + { ftcCurrentModule = cm_files `Set.difference` new_files_set + , ftcGhcSession = gs_files `Set.union` new_files_set + } + where + new_files_set = Set.fromList new_files + +-- | Update the lifetime of files already being tracked. If any files are +-- not being tracked they will be discarded. +changeTempFilesLifetime :: DynFlags -> TempFileLifetime -> [FilePath] -> IO () +changeTempFilesLifetime dflags lifetime files = do + FilesToClean + { ftcCurrentModule = cm_files + , ftcGhcSession = gs_files + } <- readIORef (filesToClean dflags) + let old_set = case lifetime of + TFL_CurrentModule -> gs_files + TFL_GhcSession -> cm_files + existing_files = [f | f <- files, f `Set.member` old_set] + addFilesToClean dflags lifetime existing_files + +-- Return a unique numeric temp file suffix +newTempSuffix :: DynFlags -> IO Int +newTempSuffix dflags = + atomicModifyIORef' (nextTempSuffix dflags) $ \n -> (n+1,n) + +-- Find a temporary name that doesn't already exist. +newTempName :: DynFlags -> TempFileLifetime -> Suffix -> IO FilePath +newTempName dflags lifetime extn + = do d <- getTempDir dflags + findTempName (d "ghc_") -- See Note [Deterministic base name] + where + findTempName :: FilePath -> IO FilePath + findTempName prefix + = do n <- newTempSuffix dflags + let filename = prefix ++ show n <.> extn + b <- doesFileExist filename + if b then findTempName prefix + else do -- clean it up later + addFilesToClean dflags lifetime [filename] + return filename + +newTempDir :: DynFlags -> IO FilePath +newTempDir dflags + = do d <- getTempDir dflags + findTempDir (d "ghc_") + where + findTempDir :: FilePath -> IO FilePath + findTempDir prefix + = do n <- newTempSuffix dflags + let filename = prefix ++ show n + b <- doesDirectoryExist filename + if b then findTempDir prefix + else do createDirectory filename + -- see mkTempDir below; this is wrong: -> consIORef (dirsToClean dflags) filename + return filename + +newTempLibName :: DynFlags -> TempFileLifetime -> Suffix + -> IO (FilePath, FilePath, String) +newTempLibName dflags lifetime extn + = do d <- getTempDir dflags + findTempName d ("ghc_") + where + findTempName :: FilePath -> String -> IO (FilePath, FilePath, String) + findTempName dir prefix + = do n <- newTempSuffix dflags -- See Note [Deterministic base name] + let libname = prefix ++ show n + filename = dir "lib" ++ libname <.> extn + b <- doesFileExist filename + if b then findTempName dir prefix + else do -- clean it up later + addFilesToClean dflags lifetime [filename] + return (filename, dir, libname) + + +-- Return our temporary directory within tmp_dir, creating one if we +-- don't have one yet. +getTempDir :: DynFlags -> IO FilePath +getTempDir dflags = do + mapping <- readIORef dir_ref + case Map.lookup tmp_dir mapping of + Nothing -> do + pid <- getProcessID + let prefix = tmp_dir "ghc" ++ show pid ++ "_" + mask_ $ mkTempDir prefix + Just dir -> return dir + where + tmp_dir = tmpDir dflags + dir_ref = dirsToClean dflags + + mkTempDir :: FilePath -> IO FilePath + mkTempDir prefix = do + n <- newTempSuffix dflags + let our_dir = prefix ++ show n + + -- 1. Speculatively create our new directory. + createDirectory our_dir + + -- 2. Update the dirsToClean mapping unless an entry already exists + -- (i.e. unless another thread beat us to it). + their_dir <- atomicModifyIORef' dir_ref $ \mapping -> + case Map.lookup tmp_dir mapping of + Just dir -> (mapping, Just dir) + Nothing -> (Map.insert tmp_dir our_dir mapping, Nothing) + + -- 3. If there was an existing entry, return it and delete the + -- directory we created. Otherwise return the directory we created. + case their_dir of + Nothing -> do + debugTraceMsg dflags 2 $ + text "Created temporary directory:" <+> text our_dir + return our_dir + Just dir -> do + removeDirectory our_dir + return dir + `catchIO` \e -> if isAlreadyExistsError e + then mkTempDir prefix else ioError e + +{- Note [Deterministic base name] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The filename of temporary files, especially the basename of C files, can end +up in the output in some form, e.g. as part of linker debug information. In the +interest of bit-wise exactly reproducible compilation (#4012), the basename of +the temporary file no longer contains random information (it used to contain +the process id). + +This is ok, as the temporary directory used contains the pid (see getTempDir). +-} +removeTmpDirs :: DynFlags -> [FilePath] -> IO () +removeTmpDirs dflags ds + = traceCmd dflags "Deleting temp dirs" + ("Deleting: " ++ unwords ds) + (mapM_ (removeWith dflags removeDirectory) ds) + +removeTmpFiles :: DynFlags -> [FilePath] -> IO () +removeTmpFiles dflags fs + = warnNon $ + traceCmd dflags "Deleting temp files" + ("Deleting: " ++ unwords deletees) + (mapM_ (removeWith dflags removeFile) deletees) + where + -- Flat out refuse to delete files that are likely to be source input + -- files (is there a worse bug than having a compiler delete your source + -- files?) + -- + -- Deleting source files is a sign of a bug elsewhere, so prominently flag + -- the condition. + warnNon act + | null non_deletees = act + | otherwise = do + putMsg dflags (text "WARNING - NOT deleting source files:" + <+> hsep (map text non_deletees)) + act + + (non_deletees, deletees) = partition isHaskellUserSrcFilename fs + +removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO () +removeWith dflags remover f = remover f `catchIO` + (\e -> + let msg = if isDoesNotExistError e + then text "Warning: deleting non-existent" <+> text f + else text "Warning: exception raised when deleting" + <+> text f <> colon + $$ text (show e) + in debugTraceMsg dflags 2 msg + ) + +#if defined(mingw32_HOST_OS) +-- relies on Int == Int32 on Windows +foreign import ccall unsafe "_getpid" getProcessID :: IO Int +#else +getProcessID :: IO Int +getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral +#endif + +-- The following three functions are from the `temporary` package. + +-- | Create and use a temporary directory in the system standard temporary +-- directory. +-- +-- Behaves exactly the same as 'withTempDirectory', except that the parent +-- temporary directory will be that returned by 'getTemporaryDirectory'. +withSystemTempDirectory :: String -- ^ Directory name template. See 'openTempFile'. + -> (FilePath -> IO a) -- ^ Callback that can use the directory + -> IO a +withSystemTempDirectory template action = + getTemporaryDirectory >>= \tmpDir -> withTempDirectory tmpDir template action + + +-- | Create and use a temporary directory. +-- +-- Creates a new temporary directory inside the given directory, making use +-- of the template. The temp directory is deleted after use. For example: +-- +-- > withTempDirectory "src" "sdist." $ \tmpDir -> do ... +-- +-- The @tmpDir@ will be a new subdirectory of the given directory, e.g. +-- @src/sdist.342@. +withTempDirectory :: FilePath -- ^ Temp directory to create the directory in + -> String -- ^ Directory name template. See 'openTempFile'. + -> (FilePath -> IO a) -- ^ Callback that can use the directory + -> IO a +withTempDirectory targetDir template = + Exception.bracket + (createTempDirectory targetDir template) + (ignoringIOErrors . removeDirectoryRecursive) + +ignoringIOErrors :: IO () -> IO () +ignoringIOErrors ioe = ioe `catch` (\e -> const (return ()) (e :: IOError)) + + +createTempDirectory :: FilePath -> String -> IO FilePath +createTempDirectory dir template = do + pid <- getProcessID + findTempName pid + where findTempName x = do + let path = dir template ++ show x + createDirectory path + return path + `catchIO` \e -> if isAlreadyExistsError e + then findTempName (x+1) else ioError e diff --git a/compiler/main/GhcMonad.hs b/compiler/main/GhcMonad.hs new file mode 100644 --- /dev/null +++ b/compiler/main/GhcMonad.hs @@ -0,0 +1,209 @@ +{-# LANGUAGE CPP, RankNTypes #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow, 2010 +-- +-- The Session type and related functionality +-- +-- ----------------------------------------------------------------------------- + +module GhcMonad ( + -- * 'Ghc' monad stuff + GhcMonad(..), + Ghc(..), + GhcT(..), liftGhcT, + reflectGhc, reifyGhc, + getSessionDynFlags, + liftIO, + Session(..), withSession, modifySession, withTempSession, + + -- ** Warnings + logWarnings, printException, + WarnErrLogger, defaultWarnErrLogger + ) where + +import GhcPrelude + +import MonadUtils +import HscTypes +import DynFlags +import Exception +import ErrUtils + +import Control.Monad +import Data.IORef + +-- ----------------------------------------------------------------------------- +-- | A monad that has all the features needed by GHC API calls. +-- +-- In short, a GHC monad +-- +-- - allows embedding of IO actions, +-- +-- - can log warnings, +-- +-- - allows handling of (extensible) exceptions, and +-- +-- - maintains a current session. +-- +-- If you do not use 'Ghc' or 'GhcT', make sure to call 'GHC.initGhcMonad' +-- before any call to the GHC API functions can occur. +-- +class (Functor m, MonadIO m, ExceptionMonad m, HasDynFlags m) => GhcMonad m where + getSession :: m HscEnv + setSession :: HscEnv -> m () + +-- | Call the argument with the current session. +withSession :: GhcMonad m => (HscEnv -> m a) -> m a +withSession f = getSession >>= f + +-- | Grabs the DynFlags from the Session +getSessionDynFlags :: GhcMonad m => m DynFlags +getSessionDynFlags = withSession (return . hsc_dflags) + +-- | Set the current session to the result of applying the current session to +-- the argument. +modifySession :: GhcMonad m => (HscEnv -> HscEnv) -> m () +modifySession f = do h <- getSession + setSession $! f h + +withSavedSession :: GhcMonad m => m a -> m a +withSavedSession m = do + saved_session <- getSession + m `gfinally` setSession saved_session + +-- | Call an action with a temporarily modified Session. +withTempSession :: GhcMonad m => (HscEnv -> HscEnv) -> m a -> m a +withTempSession f m = + withSavedSession $ modifySession f >> m + +-- ----------------------------------------------------------------------------- +-- | A monad that allows logging of warnings. + +logWarnings :: GhcMonad m => WarningMessages -> m () +logWarnings warns = do + dflags <- getSessionDynFlags + liftIO $ printOrThrowWarnings dflags warns + +-- ----------------------------------------------------------------------------- +-- | A minimal implementation of a 'GhcMonad'. If you need a custom monad, +-- e.g., to maintain additional state consider wrapping this monad or using +-- 'GhcT'. +newtype Ghc a = Ghc { unGhc :: Session -> IO a } + +-- | The Session is a handle to the complete state of a compilation +-- session. A compilation session consists of a set of modules +-- constituting the current program or library, the context for +-- interactive evaluation, and various caches. +data Session = Session !(IORef HscEnv) + +instance Functor Ghc where + fmap f m = Ghc $ \s -> f `fmap` unGhc m s + +instance Applicative Ghc where + pure a = Ghc $ \_ -> return a + g <*> m = do f <- g; a <- m; return (f a) + +instance Monad Ghc where + m >>= g = Ghc $ \s -> do a <- unGhc m s; unGhc (g a) s + +instance MonadIO Ghc where + liftIO ioA = Ghc $ \_ -> ioA + +instance MonadFix Ghc where + mfix f = Ghc $ \s -> mfix (\x -> unGhc (f x) s) + +instance ExceptionMonad Ghc where + gcatch act handle = + Ghc $ \s -> unGhc act s `gcatch` \e -> unGhc (handle e) s + gmask f = + Ghc $ \s -> gmask $ \io_restore -> + let + g_restore (Ghc m) = Ghc $ \s -> io_restore (m s) + in + unGhc (f g_restore) s + +instance HasDynFlags Ghc where + getDynFlags = getSessionDynFlags + +instance GhcMonad Ghc where + getSession = Ghc $ \(Session r) -> readIORef r + setSession s' = Ghc $ \(Session r) -> writeIORef r s' + +-- | Reflect a computation in the 'Ghc' monad into the 'IO' monad. +-- +-- You can use this to call functions returning an action in the 'Ghc' monad +-- inside an 'IO' action. This is needed for some (too restrictive) callback +-- arguments of some library functions: +-- +-- > libFunc :: String -> (Int -> IO a) -> IO a +-- > ghcFunc :: Int -> Ghc a +-- > +-- > ghcFuncUsingLibFunc :: String -> Ghc a -> Ghc a +-- > ghcFuncUsingLibFunc str = +-- > reifyGhc $ \s -> +-- > libFunc $ \i -> do +-- > reflectGhc (ghcFunc i) s +-- +reflectGhc :: Ghc a -> Session -> IO a +reflectGhc m = unGhc m + +-- > Dual to 'reflectGhc'. See its documentation. +reifyGhc :: (Session -> IO a) -> Ghc a +reifyGhc act = Ghc $ act + +-- ----------------------------------------------------------------------------- +-- | A monad transformer to add GHC specific features to another monad. +-- +-- Note that the wrapped monad must support IO and handling of exceptions. +newtype GhcT m a = GhcT { unGhcT :: Session -> m a } + +liftGhcT :: m a -> GhcT m a +liftGhcT m = GhcT $ \_ -> m + +instance Functor m => Functor (GhcT m) where + fmap f m = GhcT $ \s -> f `fmap` unGhcT m s + +instance Applicative m => Applicative (GhcT m) where + pure x = GhcT $ \_ -> pure x + g <*> m = GhcT $ \s -> unGhcT g s <*> unGhcT m s + +instance Monad m => Monad (GhcT m) where + m >>= k = GhcT $ \s -> do a <- unGhcT m s; unGhcT (k a) s + +instance MonadIO m => MonadIO (GhcT m) where + liftIO ioA = GhcT $ \_ -> liftIO ioA + +instance ExceptionMonad m => ExceptionMonad (GhcT m) where + gcatch act handle = + GhcT $ \s -> unGhcT act s `gcatch` \e -> unGhcT (handle e) s + gmask f = + GhcT $ \s -> gmask $ \io_restore -> + let + g_restore (GhcT m) = GhcT $ \s -> io_restore (m s) + in + unGhcT (f g_restore) s + +instance MonadIO m => HasDynFlags (GhcT m) where + getDynFlags = GhcT $ \(Session r) -> liftM hsc_dflags (liftIO $ readIORef r) + +instance ExceptionMonad m => GhcMonad (GhcT m) where + getSession = GhcT $ \(Session r) -> liftIO $ readIORef r + setSession s' = GhcT $ \(Session r) -> liftIO $ writeIORef r s' + + +-- | Print the error message and all warnings. Useful inside exception +-- handlers. Clears warnings after printing. +printException :: GhcMonad m => SourceError -> m () +printException err = do + dflags <- getSessionDynFlags + liftIO $ printBagOfErrors dflags (srcErrorMessages err) + +-- | A function called to log warnings and errors. +type WarnErrLogger = forall m. GhcMonad m => Maybe SourceError -> m () + +defaultWarnErrLogger :: WarnErrLogger +defaultWarnErrLogger Nothing = return () +defaultWarnErrLogger (Just e) = printException e + diff --git a/compiler/main/Hooks.hs b/compiler/main/Hooks.hs new file mode 100644 --- /dev/null +++ b/compiler/main/Hooks.hs @@ -0,0 +1,104 @@ +-- \section[Hooks]{Low level API hooks} + +-- NB: this module is SOURCE-imported by DynFlags, and should primarily +-- refer to *types*, rather than *code* + +{-# LANGUAGE CPP #-} +module Hooks ( Hooks + , emptyHooks + , lookupHook + , getHooked + -- the hooks: + , dsForeignsHook + , tcForeignImportsHook + , tcForeignExportsHook + , hscFrontendHook + , hscCompileCoreExprHook + , ghcPrimIfaceHook + , runPhaseHook + , runMetaHook + , linkHook + , runRnSpliceHook + , getValueSafelyHook + , createIservProcessHook + ) where + +import GhcPrelude + +import DynFlags +import PipelineMonad +import HscTypes +import HsDecls +import HsBinds +import HsExpr +import OrdList +import TcRnTypes +import Bag +import RdrName +import Name +import Id +import CoreSyn +import GHCi.RemoteTypes +import SrcLoc +import Type +import System.Process +import BasicTypes +import HsExtension + +import Data.Maybe + +{- +************************************************************************ +* * +\subsection{Hooks} +* * +************************************************************************ +-} + +-- | Hooks can be used by GHC API clients to replace parts of +-- the compiler pipeline. If a hook is not installed, GHC +-- uses the default built-in behaviour + +emptyHooks :: Hooks +emptyHooks = Hooks + { dsForeignsHook = Nothing + , tcForeignImportsHook = Nothing + , tcForeignExportsHook = Nothing + , hscFrontendHook = Nothing + , hscCompileCoreExprHook = Nothing + , ghcPrimIfaceHook = Nothing + , runPhaseHook = Nothing + , runMetaHook = Nothing + , linkHook = Nothing + , runRnSpliceHook = Nothing + , getValueSafelyHook = Nothing + , createIservProcessHook = Nothing + } + +data Hooks = Hooks + { dsForeignsHook :: Maybe ([LForeignDecl GhcTc] + -> DsM (ForeignStubs, OrdList (Id, CoreExpr))) + , tcForeignImportsHook :: Maybe ([LForeignDecl GhcRn] + -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt)) + , tcForeignExportsHook :: Maybe ([LForeignDecl GhcRn] + -> TcM (LHsBinds GhcTcId, [LForeignDecl GhcTcId], Bag GlobalRdrElt)) + , hscFrontendHook :: Maybe (ModSummary -> Hsc FrontendResult) + , hscCompileCoreExprHook :: + Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue) + , ghcPrimIfaceHook :: Maybe ModIface + , runPhaseHook :: Maybe (PhasePlus -> FilePath -> DynFlags + -> CompPipeline (PhasePlus, FilePath)) + , runMetaHook :: Maybe (MetaHook TcM) + , linkHook :: Maybe (GhcLink -> DynFlags -> Bool + -> HomePackageTable -> IO SuccessFlag) + , runRnSpliceHook :: Maybe (HsSplice GhcRn -> RnM (HsSplice GhcRn)) + , getValueSafelyHook :: Maybe (HscEnv -> Name -> Type + -> IO (Maybe HValue)) + , createIservProcessHook :: Maybe (CreateProcess -> IO ProcessHandle) + } + +getHooked :: (Functor f, HasDynFlags f) => (Hooks -> Maybe a) -> a -> f a +getHooked hook def = fmap (lookupHook hook def) getDynFlags + +lookupHook :: (Hooks -> Maybe a) -> a -> DynFlags -> a +lookupHook hook def = fromMaybe def . hook . hooks diff --git a/compiler/main/Hooks.hs-boot b/compiler/main/Hooks.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/main/Hooks.hs-boot @@ -0,0 +1,7 @@ +module Hooks where + +import GhcPrelude () + +data Hooks + +emptyHooks :: Hooks diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs new file mode 100644 --- /dev/null +++ b/compiler/main/HscTypes.hs @@ -0,0 +1,3138 @@ +{- +(c) The University of Glasgow, 2006 + +\section[HscTypes]{Types for the per-module compiler} +-} + +{-# LANGUAGE CPP, ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Types for the per-module compiler +module HscTypes ( + -- * compilation state + HscEnv(..), hscEPS, + FinderCache, FindResult(..), InstalledFindResult(..), + Target(..), TargetId(..), pprTarget, pprTargetId, + HscStatus(..), + IServ(..), + + -- * ModuleGraph + ModuleGraph, emptyMG, mkModuleGraph, extendMG, mapMG, + mgModSummaries, mgElemModule, mgLookupModule, + needsTemplateHaskellOrQQ, mgBootModules, + + -- * Hsc monad + Hsc(..), runHsc, mkInteractiveHscEnv, runInteractiveHsc, + + -- * Information about modules + ModDetails(..), emptyModDetails, + ModGuts(..), CgGuts(..), ForeignStubs(..), appendStubC, + ImportedMods, ImportedBy(..), importedByUser, ImportedModsVal(..), SptEntry(..), + ForeignSrcLang(..), + + ModSummary(..), ms_imps, ms_installed_mod, ms_mod_name, showModMsg, isBootSummary, + msHsFilePath, msHiFilePath, msObjFilePath, + SourceModified(..), isTemplateHaskellOrQQNonBoot, + + -- * Information about the module being compiled + -- (re-exported from DriverPhases) + HscSource(..), isHsBootOrSig, isHsigFile, hscSourceString, + + + -- * State relating to modules in this package + HomePackageTable, HomeModInfo(..), emptyHomePackageTable, + lookupHpt, eltsHpt, filterHpt, allHpt, mapHpt, delFromHpt, + addToHpt, addListToHpt, lookupHptDirectly, listToHpt, + hptCompleteSigs, + hptInstances, hptRules, pprHPT, + + -- * State relating to known packages + ExternalPackageState(..), EpsStats(..), addEpsInStats, + PackageTypeEnv, PackageIfaceTable, emptyPackageIfaceTable, + lookupIfaceByModule, emptyModIface, lookupHptByModule, + + PackageInstEnv, PackageFamInstEnv, PackageRuleBase, + PackageCompleteMatchMap, + + mkSOName, mkHsSOName, soExt, + + -- * Metaprogramming + MetaRequest(..), + MetaResult, -- data constructors not exported to ensure correct response type + metaRequestE, metaRequestP, metaRequestT, metaRequestD, metaRequestAW, + MetaHook, + + -- * Annotations + prepareAnnotations, + + -- * Interactive context + InteractiveContext(..), emptyInteractiveContext, + icPrintUnqual, icInScopeTTs, icExtendGblRdrEnv, + extendInteractiveContext, extendInteractiveContextWithIds, + substInteractiveContext, + setInteractivePrintName, icInteractiveModule, + InteractiveImport(..), setInteractivePackage, + mkPrintUnqualified, pprModulePrefix, + mkQualPackage, mkQualModule, pkgQual, + + -- * Interfaces + ModIface(..), mkIfaceWarnCache, mkIfaceHashCache, mkIfaceFixCache, + emptyIfaceWarnCache, mi_boot, mi_fix, + mi_semantic_module, + mi_free_holes, + renameFreeHoles, + + -- * Fixity + FixityEnv, FixItem(..), lookupFixity, emptyFixityEnv, + + -- * TyThings and type environments + TyThing(..), tyThingAvailInfo, + tyThingTyCon, tyThingDataCon, tyThingConLike, + tyThingId, tyThingCoAxiom, tyThingParent_maybe, tyThingsTyCoVars, + implicitTyThings, implicitTyConThings, implicitClassThings, + isImplicitTyThing, + + TypeEnv, lookupType, lookupTypeHscEnv, mkTypeEnv, emptyTypeEnv, + typeEnvFromEntities, mkTypeEnvWithImplicits, + extendTypeEnv, extendTypeEnvList, + extendTypeEnvWithIds, plusTypeEnv, + lookupTypeEnv, + typeEnvElts, typeEnvTyCons, typeEnvIds, typeEnvPatSyns, + typeEnvDataCons, typeEnvCoAxioms, typeEnvClasses, + + -- * MonadThings + MonadThings(..), + + -- * Information on imports and exports + WhetherHasOrphans, IsBootInterface, Usage(..), + Dependencies(..), noDependencies, + updNameCache, + IfaceExport, + + -- * Warnings + Warnings(..), WarningTxt(..), plusWarns, + + -- * Linker stuff + Linkable(..), isObjectLinkable, linkableObjs, + Unlinked(..), CompiledByteCode, + isObject, nameOfObject, isInterpretable, byteCodeOfObject, + + -- * Program coverage + HpcInfo(..), emptyHpcInfo, isHpcUsed, AnyHpcUsage, + + -- * Breakpoints + ModBreaks (..), emptyModBreaks, + + -- * Safe Haskell information + IfaceTrustInfo, getSafeMode, setSafeMode, noIfaceTrustInfo, + trustInfoToNum, numToTrustInfo, IsSafeImport, + + -- * result of the parser + HsParsedModule(..), + + -- * Compilation errors and warnings + SourceError, GhcApiError, mkSrcErr, srcErrorMessages, mkApiErr, + throwOneError, throwErrors, handleSourceError, + handleFlagWarnings, printOrThrowWarnings, + + -- * COMPLETE signature + CompleteMatch(..), CompleteMatchMap, + mkCompleteMatchMap, extendCompleteMatchMap + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import ByteCodeTypes +import InteractiveEvalTypes ( Resume ) +import GHCi.Message ( Pipe ) +import GHCi.RemoteTypes +import GHC.ForeignSrcLang + +import UniqFM +import HsSyn +import RdrName +import Avail +import Module +import InstEnv ( InstEnv, ClsInst, identicalClsInstHead ) +import FamInstEnv +import CoreSyn ( CoreProgram, RuleBase, CoreRule ) +import Name +import NameEnv +import VarSet +import Var +import Id +import IdInfo ( IdDetails(..), RecSelParent(..)) +import Type + +import ApiAnnotation ( ApiAnns ) +import Annotations ( Annotation, AnnEnv, mkAnnEnv, plusAnnEnv ) +import Class +import TyCon +import CoAxiom +import ConLike +import DataCon +import PatSyn +import PrelNames ( gHC_PRIM, ioTyConName, printName, mkInteractiveModule ) +import TysWiredIn +import Packages hiding ( Version(..) ) +import CmdLineParser +import DynFlags +import DriverPhases ( Phase, HscSource(..), hscSourceString + , isHsBootOrSig, isHsigFile ) +import BasicTypes +import IfaceSyn +import Maybes +import Outputable +import SrcLoc +import Unique +import UniqDFM +import FastString +import StringBuffer ( StringBuffer ) +import Fingerprint +import MonadUtils +import Bag +import Binary +import ErrUtils +import NameCache +import Platform +import Util +import UniqDSet +import GHC.Serialized ( Serialized ) +import qualified GHC.LanguageExtensions as LangExt + +import Foreign +import Control.Monad ( guard, liftM, ap ) +import Data.IORef +import Data.Time +import Exception +import System.FilePath +import Control.Concurrent +import System.Process ( ProcessHandle ) + +-- ----------------------------------------------------------------------------- +-- Compilation state +-- ----------------------------------------------------------------------------- + +-- | Status of a compilation to hard-code +data HscStatus + = HscNotGeneratingCode + | HscUpToDate + | HscUpdateBoot + | HscUpdateSig + | HscRecomp CgGuts ModSummary + +-- ----------------------------------------------------------------------------- +-- The Hsc monad: Passing an environment and warning state + +newtype Hsc a = Hsc (HscEnv -> WarningMessages -> IO (a, WarningMessages)) + +instance Functor Hsc where + fmap = liftM + +instance Applicative Hsc where + pure a = Hsc $ \_ w -> return (a, w) + (<*>) = ap + +instance Monad Hsc where + Hsc m >>= k = Hsc $ \e w -> do (a, w1) <- m e w + case k a of + Hsc k' -> k' e w1 + +instance MonadIO Hsc where + liftIO io = Hsc $ \_ w -> do a <- io; return (a, w) + +instance HasDynFlags Hsc where + getDynFlags = Hsc $ \e w -> return (hsc_dflags e, w) + +runHsc :: HscEnv -> Hsc a -> IO a +runHsc hsc_env (Hsc hsc) = do + (a, w) <- hsc hsc_env emptyBag + printOrThrowWarnings (hsc_dflags hsc_env) w + return a + +mkInteractiveHscEnv :: HscEnv -> HscEnv +mkInteractiveHscEnv hsc_env = hsc_env{ hsc_dflags = interactive_dflags } + where + interactive_dflags = ic_dflags (hsc_IC hsc_env) + +runInteractiveHsc :: HscEnv -> Hsc a -> IO a +-- A variant of runHsc that switches in the DynFlags from the +-- InteractiveContext before running the Hsc computation. +runInteractiveHsc hsc_env = runHsc (mkInteractiveHscEnv hsc_env) + +-- ----------------------------------------------------------------------------- +-- Source Errors + +-- When the compiler (HscMain) discovers errors, it throws an +-- exception in the IO monad. + +mkSrcErr :: ErrorMessages -> SourceError +mkSrcErr = SourceError + +srcErrorMessages :: SourceError -> ErrorMessages +srcErrorMessages (SourceError msgs) = msgs + +mkApiErr :: DynFlags -> SDoc -> GhcApiError +mkApiErr dflags msg = GhcApiError (showSDoc dflags msg) + +throwErrors :: MonadIO io => ErrorMessages -> io a +throwErrors = liftIO . throwIO . mkSrcErr + +throwOneError :: MonadIO io => ErrMsg -> io a +throwOneError = throwErrors . unitBag + +-- | A source error is an error that is caused by one or more errors in the +-- source code. A 'SourceError' is thrown by many functions in the +-- compilation pipeline. Inside GHC these errors are merely printed via +-- 'log_action', but API clients may treat them differently, for example, +-- insert them into a list box. If you want the default behaviour, use the +-- idiom: +-- +-- > handleSourceError printExceptionAndWarnings $ do +-- > ... api calls that may fail ... +-- +-- The 'SourceError's error messages can be accessed via 'srcErrorMessages'. +-- This list may be empty if the compiler failed due to @-Werror@ +-- ('Opt_WarnIsError'). +-- +-- See 'printExceptionAndWarnings' for more information on what to take care +-- of when writing a custom error handler. +newtype SourceError = SourceError ErrorMessages + +instance Show SourceError where + show (SourceError msgs) = unlines . map show . bagToList $ msgs + +instance Exception SourceError + +-- | Perform the given action and call the exception handler if the action +-- throws a 'SourceError'. See 'SourceError' for more information. +handleSourceError :: (ExceptionMonad m) => + (SourceError -> m a) -- ^ exception handler + -> m a -- ^ action to perform + -> m a +handleSourceError handler act = + gcatch act (\(e :: SourceError) -> handler e) + +-- | An error thrown if the GHC API is used in an incorrect fashion. +newtype GhcApiError = GhcApiError String + +instance Show GhcApiError where + show (GhcApiError msg) = msg + +instance Exception GhcApiError + +-- | Given a bag of warnings, turn them into an exception if +-- -Werror is enabled, or print them out otherwise. +printOrThrowWarnings :: DynFlags -> Bag WarnMsg -> IO () +printOrThrowWarnings dflags warns = do + let (make_error, warns') = + mapAccumBagL + (\make_err warn -> + case isWarnMsgFatal dflags warn of + Nothing -> + (make_err, warn) + Just err_reason -> + (True, warn{ errMsgSeverity = SevError + , errMsgReason = ErrReason err_reason + })) + False warns + if make_error + then throwIO (mkSrcErr warns') + else printBagOfErrors dflags warns + +handleFlagWarnings :: DynFlags -> [Warn] -> IO () +handleFlagWarnings dflags warns = do + let warns' = filter (shouldPrintWarning dflags . warnReason) warns + + -- It would be nicer if warns :: [Located MsgDoc], but that + -- has circular import problems. + bag = listToBag [ mkPlainWarnMsg dflags loc (text warn) + | Warn _ (dL->L loc warn) <- warns' ] + + printOrThrowWarnings dflags bag + +-- Given a warn reason, check to see if it's associated -W opt is enabled +shouldPrintWarning :: DynFlags -> CmdLineParser.WarnReason -> Bool +shouldPrintWarning dflags ReasonDeprecatedFlag + = wopt Opt_WarnDeprecatedFlags dflags +shouldPrintWarning dflags ReasonUnrecognisedFlag + = wopt Opt_WarnUnrecognisedWarningFlags dflags +shouldPrintWarning _ _ + = True + +{- +************************************************************************ +* * +\subsection{HscEnv} +* * +************************************************************************ +-} + +-- | HscEnv is like 'Session', except that some of the fields are immutable. +-- An HscEnv is used to compile a single module from plain Haskell source +-- code (after preprocessing) to either C, assembly or C--. Things like +-- the module graph don't change during a single compilation. +-- +-- Historical note: \"hsc\" used to be the name of the compiler binary, +-- when there was a separate driver and compiler. To compile a single +-- module, the driver would invoke hsc on the source code... so nowadays +-- we think of hsc as the layer of the compiler that deals with compiling +-- a single module. +data HscEnv + = HscEnv { + hsc_dflags :: DynFlags, + -- ^ The dynamic flag settings + + hsc_targets :: [Target], + -- ^ The targets (or roots) of the current session + + hsc_mod_graph :: ModuleGraph, + -- ^ The module graph of the current session + + hsc_IC :: InteractiveContext, + -- ^ The context for evaluating interactive statements + + hsc_HPT :: HomePackageTable, + -- ^ The home package table describes already-compiled + -- home-package modules, /excluding/ the module we + -- are compiling right now. + -- (In one-shot mode the current module is the only + -- home-package module, so hsc_HPT is empty. All other + -- modules count as \"external-package\" modules. + -- However, even in GHCi mode, hi-boot interfaces are + -- demand-loaded into the external-package table.) + -- + -- 'hsc_HPT' is not mutable because we only demand-load + -- external packages; the home package is eagerly + -- loaded, module by module, by the compilation manager. + -- + -- The HPT may contain modules compiled earlier by @--make@ + -- but not actually below the current module in the dependency + -- graph. + -- + -- (This changes a previous invariant: changed Jan 05.) + + hsc_EPS :: {-# UNPACK #-} !(IORef ExternalPackageState), + -- ^ Information about the currently loaded external packages. + -- This is mutable because packages will be demand-loaded during + -- a compilation run as required. + + hsc_NC :: {-# UNPACK #-} !(IORef NameCache), + -- ^ As with 'hsc_EPS', this is side-effected by compiling to + -- reflect sucking in interface files. They cache the state of + -- external interface files, in effect. + + hsc_FC :: {-# UNPACK #-} !(IORef FinderCache), + -- ^ The cached result of performing finding in the file system + + hsc_type_env_var :: Maybe (Module, IORef TypeEnv) + -- ^ Used for one-shot compilation only, to initialise + -- the 'IfGblEnv'. See 'TcRnTypes.tcg_type_env_var' for + -- 'TcRnTypes.TcGblEnv'. See also Note [hsc_type_env_var hack] + + , hsc_iserv :: MVar (Maybe IServ) + -- ^ interactive server process. Created the first + -- time it is needed. + } + +-- Note [hsc_type_env_var hack] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- hsc_type_env_var is used to initialize tcg_type_env_var, and +-- eventually it is the mutable variable that is queried from +-- if_rec_types to get a TypeEnv. So, clearly, it's something +-- related to knot-tying (see Note [Tying the knot]). +-- hsc_type_env_var is used in two places: initTcRn (where +-- it initializes tcg_type_env_var) and initIfaceCheck +-- (where it initializes if_rec_types). +-- +-- But why do we need a way to feed a mutable variable in? Why +-- can't we just initialize tcg_type_env_var when we start +-- typechecking? The problem is we need to knot-tie the +-- EPS, and we may start adding things to the EPS before type +-- checking starts. +-- +-- Here is a concrete example. Suppose we are running +-- "ghc -c A.hs", and we have this file system state: +-- +-- A.hs-boot A.hi-boot **up to date** +-- B.hs B.hi **up to date** +-- A.hs A.hi **stale** +-- +-- The first thing we do is run checkOldIface on A.hi. +-- checkOldIface will call loadInterface on B.hi so it can +-- get its hands on the fingerprints, to find out if A.hi +-- needs recompilation. But loadInterface also populates +-- the EPS! And so if compilation turns out to be necessary, +-- as it is in this case, the thunks we put into the EPS for +-- B.hi need to have the correct if_rec_types mutable variable +-- to query. +-- +-- If the mutable variable is only allocated WHEN we start +-- typechecking, then that's too late: we can't get the +-- information to the thunks. So we need to pre-commit +-- to a type variable in 'hscIncrementalCompile' BEFORE we +-- check the old interface. +-- +-- This is all a massive hack because arguably checkOldIface +-- should not populate the EPS. But that's a refactor for +-- another day. + + +data IServ = IServ + { iservPipe :: Pipe + , iservProcess :: ProcessHandle + , iservLookupSymbolCache :: IORef (UniqFM (Ptr ())) + , iservPendingFrees :: [HValueRef] + } + +-- | Retrieve the ExternalPackageState cache. +hscEPS :: HscEnv -> IO ExternalPackageState +hscEPS hsc_env = readIORef (hsc_EPS hsc_env) + +-- | A compilation target. +-- +-- A target may be supplied with the actual text of the +-- module. If so, use this instead of the file contents (this +-- is for use in an IDE where the file hasn't been saved by +-- the user yet). +data Target + = Target { + targetId :: TargetId, -- ^ module or filename + targetAllowObjCode :: Bool, -- ^ object code allowed? + targetContents :: Maybe (StringBuffer,UTCTime) + -- ^ in-memory text buffer? + } + +data TargetId + = TargetModule ModuleName + -- ^ A module name: search for the file + | TargetFile FilePath (Maybe Phase) + -- ^ A filename: preprocess & parse it to find the module name. + -- If specified, the Phase indicates how to compile this file + -- (which phase to start from). Nothing indicates the starting phase + -- should be determined from the suffix of the filename. + deriving Eq + +pprTarget :: Target -> SDoc +pprTarget (Target id obj _) = + (if obj then char '*' else empty) <> pprTargetId id + +instance Outputable Target where + ppr = pprTarget + +pprTargetId :: TargetId -> SDoc +pprTargetId (TargetModule m) = ppr m +pprTargetId (TargetFile f _) = text f + +instance Outputable TargetId where + ppr = pprTargetId + +{- +************************************************************************ +* * +\subsection{Package and Module Tables} +* * +************************************************************************ +-} + +-- | Helps us find information about modules in the home package +type HomePackageTable = DModuleNameEnv HomeModInfo + -- Domain = modules in the home package that have been fully compiled + -- "home" unit id cached here for convenience + +-- | Helps us find information about modules in the imported packages +type PackageIfaceTable = ModuleEnv ModIface + -- Domain = modules in the imported packages + +-- | Constructs an empty HomePackageTable +emptyHomePackageTable :: HomePackageTable +emptyHomePackageTable = emptyUDFM + +-- | Constructs an empty PackageIfaceTable +emptyPackageIfaceTable :: PackageIfaceTable +emptyPackageIfaceTable = emptyModuleEnv + +pprHPT :: HomePackageTable -> SDoc +-- A bit arbitrary for now +pprHPT hpt = pprUDFM hpt $ \hms -> + vcat [ hang (ppr (mi_module (hm_iface hm))) + 2 (ppr (md_types (hm_details hm))) + | hm <- hms ] + +lookupHpt :: HomePackageTable -> ModuleName -> Maybe HomeModInfo +lookupHpt = lookupUDFM + +lookupHptDirectly :: HomePackageTable -> Unique -> Maybe HomeModInfo +lookupHptDirectly = lookupUDFM_Directly + +eltsHpt :: HomePackageTable -> [HomeModInfo] +eltsHpt = eltsUDFM + +filterHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> HomePackageTable +filterHpt = filterUDFM + +allHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> Bool +allHpt = allUDFM + +mapHpt :: (HomeModInfo -> HomeModInfo) -> HomePackageTable -> HomePackageTable +mapHpt = mapUDFM + +delFromHpt :: HomePackageTable -> ModuleName -> HomePackageTable +delFromHpt = delFromUDFM + +addToHpt :: HomePackageTable -> ModuleName -> HomeModInfo -> HomePackageTable +addToHpt = addToUDFM + +addListToHpt + :: HomePackageTable -> [(ModuleName, HomeModInfo)] -> HomePackageTable +addListToHpt = addListToUDFM + +listToHpt :: [(ModuleName, HomeModInfo)] -> HomePackageTable +listToHpt = listToUDFM + +lookupHptByModule :: HomePackageTable -> Module -> Maybe HomeModInfo +-- The HPT is indexed by ModuleName, not Module, +-- we must check for a hit on the right Module +lookupHptByModule hpt mod + = case lookupHpt hpt (moduleName mod) of + Just hm | mi_module (hm_iface hm) == mod -> Just hm + _otherwise -> Nothing + +-- | Information about modules in the package being compiled +data HomeModInfo + = HomeModInfo { + hm_iface :: !ModIface, + -- ^ The basic loaded interface file: every loaded module has one of + -- these, even if it is imported from another package + hm_details :: !ModDetails, + -- ^ Extra information that has been created from the 'ModIface' for + -- the module, typically during typechecking + hm_linkable :: !(Maybe Linkable) + -- ^ The actual artifact we would like to link to access things in + -- this module. + -- + -- 'hm_linkable' might be Nothing: + -- + -- 1. If this is an .hs-boot module + -- + -- 2. Temporarily during compilation if we pruned away + -- the old linkable because it was out of date. + -- + -- After a complete compilation ('GHC.load'), all 'hm_linkable' fields + -- in the 'HomePackageTable' will be @Just@. + -- + -- When re-linking a module ('HscMain.HscNoRecomp'), we construct the + -- 'HomeModInfo' by building a new 'ModDetails' from the old + -- 'ModIface' (only). + } + +-- | Find the 'ModIface' for a 'Module', searching in both the loaded home +-- and external package module information +lookupIfaceByModule + :: DynFlags + -> HomePackageTable + -> PackageIfaceTable + -> Module + -> Maybe ModIface +lookupIfaceByModule _dflags hpt pit mod + = case lookupHptByModule hpt mod of + Just hm -> Just (hm_iface hm) + Nothing -> lookupModuleEnv pit mod + +-- If the module does come from the home package, why do we look in the PIT as well? +-- (a) In OneShot mode, even home-package modules accumulate in the PIT +-- (b) Even in Batch (--make) mode, there is *one* case where a home-package +-- module is in the PIT, namely GHC.Prim when compiling the base package. +-- We could eliminate (b) if we wanted, by making GHC.Prim belong to a package +-- of its own, but it doesn't seem worth the bother. + +hptCompleteSigs :: HscEnv -> [CompleteMatch] +hptCompleteSigs = hptAllThings (md_complete_sigs . hm_details) + +-- | Find all the instance declarations (of classes and families) from +-- the Home Package Table filtered by the provided predicate function. +-- Used in @tcRnImports@, to select the instances that are in the +-- transitive closure of imports from the currently compiled module. +hptInstances :: HscEnv -> (ModuleName -> Bool) -> ([ClsInst], [FamInst]) +hptInstances hsc_env want_this_module + = let (insts, famInsts) = unzip $ flip hptAllThings hsc_env $ \mod_info -> do + guard (want_this_module (moduleName (mi_module (hm_iface mod_info)))) + let details = hm_details mod_info + return (md_insts details, md_fam_insts details) + in (concat insts, concat famInsts) + +-- | Get rules from modules "below" this one (in the dependency sense) +hptRules :: HscEnv -> [(ModuleName, IsBootInterface)] -> [CoreRule] +hptRules = hptSomeThingsBelowUs (md_rules . hm_details) False + + +-- | Get annotations from modules "below" this one (in the dependency sense) +hptAnns :: HscEnv -> Maybe [(ModuleName, IsBootInterface)] -> [Annotation] +hptAnns hsc_env (Just deps) = hptSomeThingsBelowUs (md_anns . hm_details) False hsc_env deps +hptAnns hsc_env Nothing = hptAllThings (md_anns . hm_details) hsc_env + +hptAllThings :: (HomeModInfo -> [a]) -> HscEnv -> [a] +hptAllThings extract hsc_env = concatMap extract (eltsHpt (hsc_HPT hsc_env)) + +-- | Get things from modules "below" this one (in the dependency sense) +-- C.f Inst.hptInstances +hptSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> [(ModuleName, IsBootInterface)] -> [a] +hptSomeThingsBelowUs extract include_hi_boot hsc_env deps + | isOneShot (ghcMode (hsc_dflags hsc_env)) = [] + + | otherwise + = let hpt = hsc_HPT hsc_env + in + [ thing + | -- Find each non-hi-boot module below me + (mod, is_boot_mod) <- deps + , include_hi_boot || not is_boot_mod + + -- unsavoury: when compiling the base package with --make, we + -- sometimes try to look up RULES etc for GHC.Prim. GHC.Prim won't + -- be in the HPT, because we never compile it; it's in the EPT + -- instead. ToDo: clean up, and remove this slightly bogus filter: + , mod /= moduleName gHC_PRIM + + -- Look it up in the HPT + , let things = case lookupHpt hpt mod of + Just info -> extract info + Nothing -> pprTrace "WARNING in hptSomeThingsBelowUs" msg [] + msg = vcat [text "missing module" <+> ppr mod, + text "Probable cause: out-of-date interface files"] + -- This really shouldn't happen, but see #962 + + -- And get its dfuns + , thing <- things ] + + +{- +************************************************************************ +* * +\subsection{Metaprogramming} +* * +************************************************************************ +-} + +-- | The supported metaprogramming result types +data MetaRequest + = MetaE (LHsExpr GhcPs -> MetaResult) + | MetaP (LPat GhcPs -> MetaResult) + | MetaT (LHsType GhcPs -> MetaResult) + | MetaD ([LHsDecl GhcPs] -> MetaResult) + | MetaAW (Serialized -> MetaResult) + +-- | data constructors not exported to ensure correct result type +data MetaResult + = MetaResE { unMetaResE :: LHsExpr GhcPs } + | MetaResP { unMetaResP :: LPat GhcPs } + | MetaResT { unMetaResT :: LHsType GhcPs } + | MetaResD { unMetaResD :: [LHsDecl GhcPs] } + | MetaResAW { unMetaResAW :: Serialized } + +type MetaHook f = MetaRequest -> LHsExpr GhcTc -> f MetaResult + +metaRequestE :: Functor f => MetaHook f -> LHsExpr GhcTc -> f (LHsExpr GhcPs) +metaRequestE h = fmap unMetaResE . h (MetaE MetaResE) + +metaRequestP :: Functor f => MetaHook f -> LHsExpr GhcTc -> f (LPat GhcPs) +metaRequestP h = fmap unMetaResP . h (MetaP MetaResP) + +metaRequestT :: Functor f => MetaHook f -> LHsExpr GhcTc -> f (LHsType GhcPs) +metaRequestT h = fmap unMetaResT . h (MetaT MetaResT) + +metaRequestD :: Functor f => MetaHook f -> LHsExpr GhcTc -> f [LHsDecl GhcPs] +metaRequestD h = fmap unMetaResD . h (MetaD MetaResD) + +metaRequestAW :: Functor f => MetaHook f -> LHsExpr GhcTc -> f Serialized +metaRequestAW h = fmap unMetaResAW . h (MetaAW MetaResAW) + +{- +************************************************************************ +* * +\subsection{Dealing with Annotations} +* * +************************************************************************ +-} + +-- | Deal with gathering annotations in from all possible places +-- and combining them into a single 'AnnEnv' +prepareAnnotations :: HscEnv -> Maybe ModGuts -> IO AnnEnv +prepareAnnotations hsc_env mb_guts = do + eps <- hscEPS hsc_env + let -- Extract annotations from the module being compiled if supplied one + mb_this_module_anns = fmap (mkAnnEnv . mg_anns) mb_guts + -- Extract dependencies of the module if we are supplied one, + -- otherwise load annotations from all home package table + -- entries regardless of dependency ordering. + home_pkg_anns = (mkAnnEnv . hptAnns hsc_env) $ fmap (dep_mods . mg_deps) mb_guts + other_pkg_anns = eps_ann_env eps + ann_env = foldl1' plusAnnEnv $ catMaybes [mb_this_module_anns, + Just home_pkg_anns, + Just other_pkg_anns] + return ann_env + +{- +************************************************************************ +* * +\subsection{The Finder cache} +* * +************************************************************************ +-} + +-- | The 'FinderCache' maps modules to the result of +-- searching for that module. It records the results of searching for +-- modules along the search path. On @:load@, we flush the entire +-- contents of this cache. +-- +type FinderCache = InstalledModuleEnv InstalledFindResult + +data InstalledFindResult + = InstalledFound ModLocation InstalledModule + | InstalledNoPackage InstalledUnitId + | InstalledNotFound [FilePath] (Maybe InstalledUnitId) + +-- | The result of searching for an imported module. +-- +-- NB: FindResult manages both user source-import lookups +-- (which can result in 'Module') as well as direct imports +-- for interfaces (which always result in 'InstalledModule'). +data FindResult + = Found ModLocation Module + -- ^ The module was found + | NoPackage UnitId + -- ^ The requested package was not found + | FoundMultiple [(Module, ModuleOrigin)] + -- ^ _Error_: both in multiple packages + + -- | Not found + | NotFound + { fr_paths :: [FilePath] -- Places where I looked + + , fr_pkg :: Maybe UnitId -- Just p => module is in this package's + -- manifest, but couldn't find + -- the .hi file + + , fr_mods_hidden :: [UnitId] -- Module is in these packages, + -- but the *module* is hidden + + , fr_pkgs_hidden :: [UnitId] -- Module is in these packages, + -- but the *package* is hidden + + -- Modules are in these packages, but it is unusable + , fr_unusables :: [(UnitId, UnusablePackageReason)] + + , fr_suggestions :: [ModuleSuggestion] -- Possible mis-spelled modules + } + +{- +************************************************************************ +* * +\subsection{Symbol tables and Module details} +* * +************************************************************************ +-} + +-- | A 'ModIface' plus a 'ModDetails' summarises everything we know +-- about a compiled module. The 'ModIface' is the stuff *before* linking, +-- and can be written out to an interface file. The 'ModDetails is after +-- linking and can be completely recovered from just the 'ModIface'. +-- +-- When we read an interface file, we also construct a 'ModIface' from it, +-- except that we explicitly make the 'mi_decls' and a few other fields empty; +-- as when reading we consolidate the declarations etc. into a number of indexed +-- maps and environments in the 'ExternalPackageState'. +data ModIface + = ModIface { + mi_module :: !Module, -- ^ Name of the module we are for + mi_sig_of :: !(Maybe Module), -- ^ Are we a sig of another mod? + mi_iface_hash :: !Fingerprint, -- ^ Hash of the whole interface + mi_mod_hash :: !Fingerprint, -- ^ Hash of the ABI only + mi_flag_hash :: !Fingerprint, -- ^ Hash of the important flags + -- used when compiling the module, + -- excluding optimisation flags + mi_opt_hash :: !Fingerprint, -- ^ Hash of optimisation flags + mi_hpc_hash :: !Fingerprint, -- ^ Hash of hpc flags + mi_plugin_hash :: !Fingerprint, -- ^ Hash of plugins + + mi_orphan :: !WhetherHasOrphans, -- ^ Whether this module has orphans + mi_finsts :: !WhetherHasFamInst, + -- ^ Whether this module has family instances. + -- See Note [The type family instance consistency story]. + mi_hsc_src :: !HscSource, -- ^ Boot? Signature? + + mi_deps :: Dependencies, + -- ^ The dependencies of the module. This is + -- consulted for directly-imported modules, but not + -- for anything else (hence lazy) + + mi_usages :: [Usage], + -- ^ Usages; kept sorted so that it's easy to decide + -- whether to write a new iface file (changing usages + -- doesn't affect the hash of this module) + -- NOT STRICT! we read this field lazily from the interface file + -- It is *only* consulted by the recompilation checker + + mi_exports :: ![IfaceExport], + -- ^ Exports + -- Kept sorted by (mod,occ), to make version comparisons easier + -- Records the modules that are the declaration points for things + -- exported by this module, and the 'OccName's of those things + + mi_exp_hash :: !Fingerprint, + -- ^ Hash of export list + + mi_used_th :: !Bool, + -- ^ Module required TH splices when it was compiled. + -- This disables recompilation avoidance (see #481). + + mi_fixities :: [(OccName,Fixity)], + -- ^ Fixities + -- NOT STRICT! we read this field lazily from the interface file + + mi_warns :: Warnings, + -- ^ Warnings + -- NOT STRICT! we read this field lazily from the interface file + + mi_anns :: [IfaceAnnotation], + -- ^ Annotations + -- NOT STRICT! we read this field lazily from the interface file + + + mi_decls :: [(Fingerprint,IfaceDecl)], + -- ^ Type, class and variable declarations + -- The hash of an Id changes if its fixity or deprecations change + -- (as well as its type of course) + -- Ditto data constructors, class operations, except that + -- the hash of the parent class/tycon changes + + mi_globals :: !(Maybe GlobalRdrEnv), + -- ^ Binds all the things defined at the top level in + -- the /original source/ code for this module. which + -- is NOT the same as mi_exports, nor mi_decls (which + -- may contains declarations for things not actually + -- defined by the user). Used for GHCi and for inspecting + -- the contents of modules via the GHC API only. + -- + -- (We need the source file to figure out the + -- top-level environment, if we didn't compile this module + -- from source then this field contains @Nothing@). + -- + -- Strictly speaking this field should live in the + -- 'HomeModInfo', but that leads to more plumbing. + + -- Instance declarations and rules + mi_insts :: [IfaceClsInst], -- ^ Sorted class instance + mi_fam_insts :: [IfaceFamInst], -- ^ Sorted family instances + mi_rules :: [IfaceRule], -- ^ Sorted rules + mi_orphan_hash :: !Fingerprint, -- ^ Hash for orphan rules, class and family + -- instances combined + + -- Cached environments for easy lookup + -- These are computed (lazily) from other fields + -- and are not put into the interface file + mi_warn_fn :: OccName -> Maybe WarningTxt, + -- ^ Cached lookup for 'mi_warns' + mi_fix_fn :: OccName -> Maybe Fixity, + -- ^ Cached lookup for 'mi_fixities' + mi_hash_fn :: OccName -> Maybe (OccName, Fingerprint), + -- ^ Cached lookup for 'mi_decls'. + -- The @Nothing@ in 'mi_hash_fn' means that the thing + -- isn't in decls. It's useful to know that when + -- seeing if we are up to date wrt. the old interface. + -- The 'OccName' is the parent of the name, if it has one. + + mi_hpc :: !AnyHpcUsage, + -- ^ True if this program uses Hpc at any point in the program. + + mi_trust :: !IfaceTrustInfo, + -- ^ Safe Haskell Trust information for this module. + + mi_trust_pkg :: !Bool, + -- ^ Do we require the package this module resides in be trusted + -- to trust this module? This is used for the situation where a + -- module is Safe (so doesn't require the package be trusted + -- itself) but imports some trustworthy modules from its own + -- package (which does require its own package be trusted). + -- See Note [RnNames . Trust Own Package] + mi_complete_sigs :: [IfaceCompleteMatch], + + mi_doc_hdr :: Maybe HsDocString, + -- ^ Module header. + + mi_decl_docs :: DeclDocMap, + -- ^ Docs on declarations. + + mi_arg_docs :: ArgDocMap + -- ^ Docs on arguments. + } + +-- | Old-style accessor for whether or not the ModIface came from an hs-boot +-- file. +mi_boot :: ModIface -> Bool +mi_boot iface = mi_hsc_src iface == HsBootFile + +-- | Lookups up a (possibly cached) fixity from a 'ModIface'. If one cannot be +-- found, 'defaultFixity' is returned instead. +mi_fix :: ModIface -> OccName -> Fixity +mi_fix iface name = mi_fix_fn iface name `orElse` defaultFixity + +-- | The semantic module for this interface; e.g., if it's a interface +-- for a signature, if 'mi_module' is @p[A=]:A@, 'mi_semantic_module' +-- will be @@. +mi_semantic_module :: ModIface -> Module +mi_semantic_module iface = case mi_sig_of iface of + Nothing -> mi_module iface + Just mod -> mod + +-- | The "precise" free holes, e.g., the signatures that this +-- 'ModIface' depends on. +mi_free_holes :: ModIface -> UniqDSet ModuleName +mi_free_holes iface = + case splitModuleInsts (mi_module iface) of + (_, Just indef) + -- A mini-hack: we rely on the fact that 'renameFreeHoles' + -- drops things that aren't holes. + -> renameFreeHoles (mkUniqDSet cands) (indefUnitIdInsts (indefModuleUnitId indef)) + _ -> emptyUniqDSet + where + cands = map fst (dep_mods (mi_deps iface)) + +-- | Given a set of free holes, and a unit identifier, rename +-- the free holes according to the instantiation of the unit +-- identifier. For example, if we have A and B free, and +-- our unit identity is @p[A=,B=impl:B]@, the renamed free +-- holes are just C. +renameFreeHoles :: UniqDSet ModuleName -> [(ModuleName, Module)] -> UniqDSet ModuleName +renameFreeHoles fhs insts = + unionManyUniqDSets (map lookup_impl (uniqDSetToList fhs)) + where + hmap = listToUFM insts + lookup_impl mod_name + | Just mod <- lookupUFM hmap mod_name = moduleFreeHoles mod + -- It wasn't actually a hole + | otherwise = emptyUniqDSet + +instance Binary ModIface where + put_ bh (ModIface { + mi_module = mod, + mi_sig_of = sig_of, + mi_hsc_src = hsc_src, + mi_iface_hash= iface_hash, + mi_mod_hash = mod_hash, + mi_flag_hash = flag_hash, + mi_opt_hash = opt_hash, + mi_hpc_hash = hpc_hash, + mi_plugin_hash = plugin_hash, + mi_orphan = orphan, + mi_finsts = hasFamInsts, + mi_deps = deps, + mi_usages = usages, + mi_exports = exports, + mi_exp_hash = exp_hash, + mi_used_th = used_th, + mi_fixities = fixities, + mi_warns = warns, + mi_anns = anns, + mi_decls = decls, + mi_insts = insts, + mi_fam_insts = fam_insts, + mi_rules = rules, + mi_orphan_hash = orphan_hash, + mi_hpc = hpc_info, + mi_trust = trust, + mi_trust_pkg = trust_pkg, + mi_complete_sigs = complete_sigs, + mi_doc_hdr = doc_hdr, + mi_decl_docs = decl_docs, + mi_arg_docs = arg_docs }) = do + put_ bh mod + put_ bh sig_of + put_ bh hsc_src + put_ bh iface_hash + put_ bh mod_hash + put_ bh flag_hash + put_ bh opt_hash + put_ bh hpc_hash + put_ bh plugin_hash + put_ bh orphan + put_ bh hasFamInsts + lazyPut bh deps + lazyPut bh usages + put_ bh exports + put_ bh exp_hash + put_ bh used_th + put_ bh fixities + lazyPut bh warns + lazyPut bh anns + put_ bh decls + put_ bh insts + put_ bh fam_insts + lazyPut bh rules + put_ bh orphan_hash + put_ bh hpc_info + put_ bh trust + put_ bh trust_pkg + put_ bh complete_sigs + lazyPut bh doc_hdr + lazyPut bh decl_docs + lazyPut bh arg_docs + + get bh = do + mod <- get bh + sig_of <- get bh + hsc_src <- get bh + iface_hash <- get bh + mod_hash <- get bh + flag_hash <- get bh + opt_hash <- get bh + hpc_hash <- get bh + plugin_hash <- get bh + orphan <- get bh + hasFamInsts <- get bh + deps <- lazyGet bh + usages <- {-# SCC "bin_usages" #-} lazyGet bh + exports <- {-# SCC "bin_exports" #-} get bh + exp_hash <- get bh + used_th <- get bh + fixities <- {-# SCC "bin_fixities" #-} get bh + warns <- {-# SCC "bin_warns" #-} lazyGet bh + anns <- {-# SCC "bin_anns" #-} lazyGet bh + decls <- {-# SCC "bin_tycldecls" #-} get bh + insts <- {-# SCC "bin_insts" #-} get bh + fam_insts <- {-# SCC "bin_fam_insts" #-} get bh + rules <- {-# SCC "bin_rules" #-} lazyGet bh + orphan_hash <- get bh + hpc_info <- get bh + trust <- get bh + trust_pkg <- get bh + complete_sigs <- get bh + doc_hdr <- lazyGet bh + decl_docs <- lazyGet bh + arg_docs <- lazyGet bh + return (ModIface { + mi_module = mod, + mi_sig_of = sig_of, + mi_hsc_src = hsc_src, + mi_iface_hash = iface_hash, + mi_mod_hash = mod_hash, + mi_flag_hash = flag_hash, + mi_opt_hash = opt_hash, + mi_hpc_hash = hpc_hash, + mi_plugin_hash = plugin_hash, + mi_orphan = orphan, + mi_finsts = hasFamInsts, + mi_deps = deps, + mi_usages = usages, + mi_exports = exports, + mi_exp_hash = exp_hash, + mi_used_th = used_th, + mi_anns = anns, + mi_fixities = fixities, + mi_warns = warns, + mi_decls = decls, + mi_globals = Nothing, + mi_insts = insts, + mi_fam_insts = fam_insts, + mi_rules = rules, + mi_orphan_hash = orphan_hash, + mi_hpc = hpc_info, + mi_trust = trust, + mi_trust_pkg = trust_pkg, + -- And build the cached values + mi_warn_fn = mkIfaceWarnCache warns, + mi_fix_fn = mkIfaceFixCache fixities, + mi_hash_fn = mkIfaceHashCache decls, + mi_complete_sigs = complete_sigs, + mi_doc_hdr = doc_hdr, + mi_decl_docs = decl_docs, + mi_arg_docs = arg_docs }) + +-- | The original names declared of a certain module that are exported +type IfaceExport = AvailInfo + +-- | Constructs an empty ModIface +emptyModIface :: Module -> ModIface +emptyModIface mod + = ModIface { mi_module = mod, + mi_sig_of = Nothing, + mi_iface_hash = fingerprint0, + mi_mod_hash = fingerprint0, + mi_flag_hash = fingerprint0, + mi_opt_hash = fingerprint0, + mi_hpc_hash = fingerprint0, + mi_plugin_hash = fingerprint0, + mi_orphan = False, + mi_finsts = False, + mi_hsc_src = HsSrcFile, + mi_deps = noDependencies, + mi_usages = [], + mi_exports = [], + mi_exp_hash = fingerprint0, + mi_used_th = False, + mi_fixities = [], + mi_warns = NoWarnings, + mi_anns = [], + mi_insts = [], + mi_fam_insts = [], + mi_rules = [], + mi_decls = [], + mi_globals = Nothing, + mi_orphan_hash = fingerprint0, + mi_warn_fn = emptyIfaceWarnCache, + mi_fix_fn = emptyIfaceFixCache, + mi_hash_fn = emptyIfaceHashCache, + mi_hpc = False, + mi_trust = noIfaceTrustInfo, + mi_trust_pkg = False, + mi_complete_sigs = [], + mi_doc_hdr = Nothing, + mi_decl_docs = emptyDeclDocMap, + mi_arg_docs = emptyArgDocMap } + + +-- | Constructs cache for the 'mi_hash_fn' field of a 'ModIface' +mkIfaceHashCache :: [(Fingerprint,IfaceDecl)] + -> (OccName -> Maybe (OccName, Fingerprint)) +mkIfaceHashCache pairs + = \occ -> lookupOccEnv env occ + where + env = foldl' add_decl emptyOccEnv pairs + add_decl env0 (v,d) = foldl' add env0 (ifaceDeclFingerprints v d) + where + add env0 (occ,hash) = extendOccEnv env0 occ (occ,hash) + +emptyIfaceHashCache :: OccName -> Maybe (OccName, Fingerprint) +emptyIfaceHashCache _occ = Nothing + + +-- | The 'ModDetails' is essentially a cache for information in the 'ModIface' +-- for home modules only. Information relating to packages will be loaded into +-- global environments in 'ExternalPackageState'. +data ModDetails + = ModDetails { + -- The next two fields are created by the typechecker + md_exports :: [AvailInfo], + md_types :: !TypeEnv, -- ^ Local type environment for this particular module + -- Includes Ids, TyCons, PatSyns + md_insts :: ![ClsInst], -- ^ 'DFunId's for the instances in this module + md_fam_insts :: ![FamInst], + md_rules :: ![CoreRule], -- ^ Domain may include 'Id's from other modules + md_anns :: ![Annotation], -- ^ Annotations present in this module: currently + -- they only annotate things also declared in this module + md_complete_sigs :: [CompleteMatch] + -- ^ Complete match pragmas for this module + } + +-- | Constructs an empty ModDetails +emptyModDetails :: ModDetails +emptyModDetails + = ModDetails { md_types = emptyTypeEnv, + md_exports = [], + md_insts = [], + md_rules = [], + md_fam_insts = [], + md_anns = [], + md_complete_sigs = [] } + +-- | Records the modules directly imported by a module for extracting e.g. +-- usage information, and also to give better error message +type ImportedMods = ModuleEnv [ImportedBy] + +-- | If a module was "imported" by the user, we associate it with +-- more detailed usage information 'ImportedModsVal'; a module +-- imported by the system only gets used for usage information. +data ImportedBy + = ImportedByUser ImportedModsVal + | ImportedBySystem + +importedByUser :: [ImportedBy] -> [ImportedModsVal] +importedByUser (ImportedByUser imv : bys) = imv : importedByUser bys +importedByUser (ImportedBySystem : bys) = importedByUser bys +importedByUser [] = [] + +data ImportedModsVal + = ImportedModsVal { + imv_name :: ModuleName, -- ^ The name the module is imported with + imv_span :: SrcSpan, -- ^ the source span of the whole import + imv_is_safe :: IsSafeImport, -- ^ whether this is a safe import + imv_is_hiding :: Bool, -- ^ whether this is an "hiding" import + imv_all_exports :: !GlobalRdrEnv, -- ^ all the things the module could provide + -- NB. BangPattern here: otherwise this leaks. (#15111) + imv_qualified :: Bool -- ^ whether this is a qualified import + } + +-- | A ModGuts is carried through the compiler, accumulating stuff as it goes +-- There is only one ModGuts at any time, the one for the module +-- being compiled right now. Once it is compiled, a 'ModIface' and +-- 'ModDetails' are extracted and the ModGuts is discarded. +data ModGuts + = ModGuts { + mg_module :: !Module, -- ^ Module being compiled + mg_hsc_src :: HscSource, -- ^ Whether it's an hs-boot module + mg_loc :: SrcSpan, -- ^ For error messages from inner passes + mg_exports :: ![AvailInfo], -- ^ What it exports + mg_deps :: !Dependencies, -- ^ What it depends on, directly or + -- otherwise + mg_usages :: ![Usage], -- ^ What was used? Used for interfaces. + + mg_used_th :: !Bool, -- ^ Did we run a TH splice? + mg_rdr_env :: !GlobalRdrEnv, -- ^ Top-level lexical environment + + -- These fields all describe the things **declared in this module** + mg_fix_env :: !FixityEnv, -- ^ Fixities declared in this module. + -- Used for creating interface files. + mg_tcs :: ![TyCon], -- ^ TyCons declared in this module + -- (includes TyCons for classes) + mg_insts :: ![ClsInst], -- ^ Class instances declared in this module + mg_fam_insts :: ![FamInst], + -- ^ Family instances declared in this module + mg_patsyns :: ![PatSyn], -- ^ Pattern synonyms declared in this module + mg_rules :: ![CoreRule], -- ^ Before the core pipeline starts, contains + -- See Note [Overall plumbing for rules] in Rules.hs + mg_binds :: !CoreProgram, -- ^ Bindings for this module + mg_foreign :: !ForeignStubs, -- ^ Foreign exports declared in this module + mg_foreign_files :: ![(ForeignSrcLang, FilePath)], + -- ^ Files to be compiled with the C compiler + mg_warns :: !Warnings, -- ^ Warnings declared in the module + mg_anns :: [Annotation], -- ^ Annotations declared in this module + mg_complete_sigs :: [CompleteMatch], -- ^ Complete Matches + mg_hpc_info :: !HpcInfo, -- ^ Coverage tick boxes in the module + mg_modBreaks :: !(Maybe ModBreaks), -- ^ Breakpoints for the module + + -- The next two fields are unusual, because they give instance + -- environments for *all* modules in the home package, including + -- this module, rather than for *just* this module. + -- Reason: when looking up an instance we don't want to have to + -- look at each module in the home package in turn + mg_inst_env :: InstEnv, -- ^ Class instance environment for + -- /home-package/ modules (including this + -- one); c.f. 'tcg_inst_env' + mg_fam_inst_env :: FamInstEnv, -- ^ Type-family instance environment for + -- /home-package/ modules (including this + -- one); c.f. 'tcg_fam_inst_env' + + mg_safe_haskell :: SafeHaskellMode, -- ^ Safe Haskell mode + mg_trust_pkg :: Bool, -- ^ Do we need to trust our + -- own package for Safe Haskell? + -- See Note [RnNames . Trust Own Package] + + mg_doc_hdr :: !(Maybe HsDocString), -- ^ Module header. + mg_decl_docs :: !DeclDocMap, -- ^ Docs on declarations. + mg_arg_docs :: !ArgDocMap -- ^ Docs on arguments. + } + +-- The ModGuts takes on several slightly different forms: +-- +-- After simplification, the following fields change slightly: +-- mg_rules Orphan rules only (local ones now attached to binds) +-- mg_binds With rules attached + +--------------------------------------------------------- +-- The Tidy pass forks the information about this module: +-- * one lot goes to interface file generation (ModIface) +-- and later compilations (ModDetails) +-- * the other lot goes to code generation (CgGuts) + +-- | A restricted form of 'ModGuts' for code generation purposes +data CgGuts + = CgGuts { + cg_module :: !Module, + -- ^ Module being compiled + + cg_tycons :: [TyCon], + -- ^ Algebraic data types (including ones that started + -- life as classes); generate constructors and info + -- tables. Includes newtypes, just for the benefit of + -- External Core + + cg_binds :: CoreProgram, + -- ^ The tidied main bindings, including + -- previously-implicit bindings for record and class + -- selectors, and data constructor wrappers. But *not* + -- data constructor workers; reason: we regard them + -- as part of the code-gen of tycons + + cg_foreign :: !ForeignStubs, -- ^ Foreign export stubs + cg_foreign_files :: ![(ForeignSrcLang, FilePath)], + cg_dep_pkgs :: ![InstalledUnitId], -- ^ Dependent packages, used to + -- generate #includes for C code gen + cg_hpc_info :: !HpcInfo, -- ^ Program coverage tick box information + cg_modBreaks :: !(Maybe ModBreaks), -- ^ Module breakpoints + cg_spt_entries :: [SptEntry] + -- ^ Static pointer table entries for static forms defined in + -- the module. + -- See Note [Grand plan for static forms] in StaticPtrTable + } + +----------------------------------- +-- | Foreign export stubs +data ForeignStubs + = NoStubs + -- ^ We don't have any stubs + | ForeignStubs SDoc SDoc + -- ^ There are some stubs. Parameters: + -- + -- 1) Header file prototypes for + -- "foreign exported" functions + -- + -- 2) C stubs to use when calling + -- "foreign exported" functions + +appendStubC :: ForeignStubs -> SDoc -> ForeignStubs +appendStubC NoStubs c_code = ForeignStubs empty c_code +appendStubC (ForeignStubs h c) c_code = ForeignStubs h (c $$ c_code) + +-- | An entry to be inserted into a module's static pointer table. +-- See Note [Grand plan for static forms] in StaticPtrTable. +data SptEntry = SptEntry Id Fingerprint + +instance Outputable SptEntry where + ppr (SptEntry id fpr) = ppr id <> colon <+> ppr fpr + +{- +************************************************************************ +* * + The interactive context +* * +************************************************************************ + +Note [The interactive package] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Type, class, and value declarations at the command prompt are treated +as if they were defined in modules + interactive:Ghci1 + interactive:Ghci2 + ...etc... +with each bunch of declarations using a new module, all sharing a +common package 'interactive' (see Module.interactiveUnitId, and +PrelNames.mkInteractiveModule). + +This scheme deals well with shadowing. For example: + + ghci> data T = A + ghci> data T = B + ghci> :i A + data Ghci1.T = A -- Defined at :2:10 + +Here we must display info about constructor A, but its type T has been +shadowed by the second declaration. But it has a respectable +qualified name (Ghci1.T), and its source location says where it was +defined. + +So the main invariant continues to hold, that in any session an +original name M.T only refers to one unique thing. (In a previous +iteration both the T's above were called :Interactive.T, albeit with +different uniques, which gave rise to all sorts of trouble.) + +The details are a bit tricky though: + + * The field ic_mod_index counts which Ghci module we've got up to. + It is incremented when extending ic_tythings + + * ic_tythings contains only things from the 'interactive' package. + + * Module from the 'interactive' package (Ghci1, Ghci2 etc) never go + in the Home Package Table (HPT). When you say :load, that's when we + extend the HPT. + + * The 'thisPackage' field of DynFlags is *not* set to 'interactive'. + It stays as 'main' (or whatever -this-unit-id says), and is the + package to which :load'ed modules are added to. + + * So how do we arrange that declarations at the command prompt get to + be in the 'interactive' package? Simply by setting the tcg_mod + field of the TcGblEnv to "interactive:Ghci1". This is done by the + call to initTc in initTcInteractive, which in turn get the module + from it 'icInteractiveModule' field of the interactive context. + + The 'thisPackage' field stays as 'main' (or whatever -this-unit-id says. + + * The main trickiness is that the type environment (tcg_type_env) and + fixity envt (tcg_fix_env), now contain entities from all the + interactive-package modules (Ghci1, Ghci2, ...) together, rather + than just a single module as is usually the case. So you can't use + "nameIsLocalOrFrom" to decide whether to look in the TcGblEnv vs + the HPT/PTE. This is a change, but not a problem provided you + know. + +* However, the tcg_binds, tcg_sigs, tcg_insts, tcg_fam_insts, etc fields + of the TcGblEnv, which collect "things defined in this module", all + refer to stuff define in a single GHCi command, *not* all the commands + so far. + + In contrast, tcg_inst_env, tcg_fam_inst_env, have instances from + all GhciN modules, which makes sense -- they are all "home package" + modules. + + +Note [Interactively-bound Ids in GHCi] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The Ids bound by previous Stmts in GHCi are currently + a) GlobalIds, with + b) An External Name, like Ghci4.foo + See Note [The interactive package] above + c) A tidied type + + (a) They must be GlobalIds (not LocalIds) otherwise when we come to + compile an expression using these ids later, the byte code + generator will consider the occurrences to be free rather than + global. + + (b) Having an External Name is important because of Note + [GlobalRdrEnv shadowing] in RdrName + + (c) Their types are tidied. This is important, because :info may ask + to look at them, and :info expects the things it looks up to have + tidy types + +Where do interactively-bound Ids come from? + + - GHCi REPL Stmts e.g. + ghci> let foo x = x+1 + These start with an Internal Name because a Stmt is a local + construct, so the renamer naturally builds an Internal name for + each of its binders. Then in tcRnStmt they are externalised via + TcRnDriver.externaliseAndTidyId, so they get Names like Ghic4.foo. + + - Ids bound by the debugger etc have Names constructed by + IfaceEnv.newInteractiveBinder; at the call sites it is followed by + mkVanillaGlobal or mkVanillaGlobalWithInfo. So again, they are + all Global, External. + + - TyCons, Classes, and Ids bound by other top-level declarations in + GHCi (eg foreign import, record selectors) also get External + Names, with Ghci9 (or 8, or 7, etc) as the module name. + + +Note [ic_tythings] +~~~~~~~~~~~~~~~~~~ +The ic_tythings field contains + * The TyThings declared by the user at the command prompt + (eg Ids, TyCons, Classes) + + * The user-visible Ids that arise from such things, which + *don't* come from 'implicitTyThings', notably: + - record selectors + - class ops + The implicitTyThings are readily obtained from the TyThings + but record selectors etc are not + +It does *not* contain + * DFunIds (they can be gotten from ic_instances) + * CoAxioms (ditto) + +See also Note [Interactively-bound Ids in GHCi] + +Note [Override identical instances in GHCi] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If you declare a new instance in GHCi that is identical to a previous one, +we simply override the previous one; we don't regard it as overlapping. +e.g. Prelude> data T = A | B + Prelude> instance Eq T where ... + Prelude> instance Eq T where ... -- This one overrides + +It's exactly the same for type-family instances. See #7102 +-} + +-- | Interactive context, recording information about the state of the +-- context in which statements are executed in a GHCi session. +data InteractiveContext + = InteractiveContext { + ic_dflags :: DynFlags, + -- ^ The 'DynFlags' used to evaluate interative expressions + -- and statements. + + ic_mod_index :: Int, + -- ^ Each GHCi stmt or declaration brings some new things into + -- scope. We give them names like interactive:Ghci9.T, + -- where the ic_index is the '9'. The ic_mod_index is + -- incremented whenever we add something to ic_tythings + -- See Note [The interactive package] + + ic_imports :: [InteractiveImport], + -- ^ The GHCi top-level scope (ic_rn_gbl_env) is extended with + -- these imports + -- + -- This field is only stored here so that the client + -- can retrieve it with GHC.getContext. GHC itself doesn't + -- use it, but does reset it to empty sometimes (such + -- as before a GHC.load). The context is set with GHC.setContext. + + ic_tythings :: [TyThing], + -- ^ TyThings defined by the user, in reverse order of + -- definition (ie most recent at the front) + -- See Note [ic_tythings] + + ic_rn_gbl_env :: GlobalRdrEnv, + -- ^ The cached 'GlobalRdrEnv', built by + -- 'InteractiveEval.setContext' and updated regularly + -- It contains everything in scope at the command line, + -- including everything in ic_tythings + + ic_instances :: ([ClsInst], [FamInst]), + -- ^ All instances and family instances created during + -- this session. These are grabbed en masse after each + -- update to be sure that proper overlapping is retained. + -- That is, rather than re-check the overlapping each + -- time we update the context, we just take the results + -- from the instance code that already does that. + + ic_fix_env :: FixityEnv, + -- ^ Fixities declared in let statements + + ic_default :: Maybe [Type], + -- ^ The current default types, set by a 'default' declaration + + ic_resume :: [Resume], + -- ^ The stack of breakpoint contexts + + ic_monad :: Name, + -- ^ The monad that GHCi is executing in + + ic_int_print :: Name, + -- ^ The function that is used for printing results + -- of expressions in ghci and -e mode. + + ic_cwd :: Maybe FilePath + -- virtual CWD of the program + } + +data InteractiveImport + = IIDecl (ImportDecl GhcPs) + -- ^ Bring the exports of a particular module + -- (filtered by an import decl) into scope + + | IIModule ModuleName + -- ^ Bring into scope the entire top-level envt of + -- of this module, including the things imported + -- into it. + + +-- | Constructs an empty InteractiveContext. +emptyInteractiveContext :: DynFlags -> InteractiveContext +emptyInteractiveContext dflags + = InteractiveContext { + ic_dflags = dflags, + ic_imports = [], + ic_rn_gbl_env = emptyGlobalRdrEnv, + ic_mod_index = 1, + ic_tythings = [], + ic_instances = ([],[]), + ic_fix_env = emptyNameEnv, + ic_monad = ioTyConName, -- IO monad by default + ic_int_print = printName, -- System.IO.print by default + ic_default = Nothing, + ic_resume = [], + ic_cwd = Nothing } + +icInteractiveModule :: InteractiveContext -> Module +icInteractiveModule (InteractiveContext { ic_mod_index = index }) + = mkInteractiveModule index + +-- | This function returns the list of visible TyThings (useful for +-- e.g. showBindings) +icInScopeTTs :: InteractiveContext -> [TyThing] +icInScopeTTs = ic_tythings + +-- | Get the PrintUnqualified function based on the flags and this InteractiveContext +icPrintUnqual :: DynFlags -> InteractiveContext -> PrintUnqualified +icPrintUnqual dflags InteractiveContext{ ic_rn_gbl_env = grenv } = + mkPrintUnqualified dflags grenv + +-- | extendInteractiveContext is called with new TyThings recently defined to update the +-- InteractiveContext to include them. Ids are easily removed when shadowed, +-- but Classes and TyCons are not. Some work could be done to determine +-- whether they are entirely shadowed, but as you could still have references +-- to them (e.g. instances for classes or values of the type for TyCons), it's +-- not clear whether removing them is even the appropriate behavior. +extendInteractiveContext :: InteractiveContext + -> [TyThing] + -> [ClsInst] -> [FamInst] + -> Maybe [Type] + -> FixityEnv + -> InteractiveContext +extendInteractiveContext ictxt new_tythings new_cls_insts new_fam_insts defaults fix_env + = ictxt { ic_mod_index = ic_mod_index ictxt + 1 + -- Always bump this; even instances should create + -- a new mod_index (#9426) + , ic_tythings = new_tythings ++ old_tythings + , ic_rn_gbl_env = ic_rn_gbl_env ictxt `icExtendGblRdrEnv` new_tythings + , ic_instances = ( new_cls_insts ++ old_cls_insts + , new_fam_insts ++ fam_insts ) + -- we don't shadow old family instances (#7102), + -- so don't need to remove them here + , ic_default = defaults + , ic_fix_env = fix_env -- See Note [Fixity declarations in GHCi] + } + where + new_ids = [id | AnId id <- new_tythings] + old_tythings = filterOut (shadowed_by new_ids) (ic_tythings ictxt) + + -- Discard old instances that have been fully overridden + -- See Note [Override identical instances in GHCi] + (cls_insts, fam_insts) = ic_instances ictxt + old_cls_insts = filterOut (\i -> any (identicalClsInstHead i) new_cls_insts) cls_insts + +extendInteractiveContextWithIds :: InteractiveContext -> [Id] -> InteractiveContext +-- Just a specialised version +extendInteractiveContextWithIds ictxt new_ids + | null new_ids = ictxt + | otherwise = ictxt { ic_mod_index = ic_mod_index ictxt + 1 + , ic_tythings = new_tythings ++ old_tythings + , ic_rn_gbl_env = ic_rn_gbl_env ictxt `icExtendGblRdrEnv` new_tythings } + where + new_tythings = map AnId new_ids + old_tythings = filterOut (shadowed_by new_ids) (ic_tythings ictxt) + +shadowed_by :: [Id] -> TyThing -> Bool +shadowed_by ids = shadowed + where + shadowed id = getOccName id `elemOccSet` new_occs + new_occs = mkOccSet (map getOccName ids) + +setInteractivePackage :: HscEnv -> HscEnv +-- Set the 'thisPackage' DynFlag to 'interactive' +setInteractivePackage hsc_env + = hsc_env { hsc_dflags = (hsc_dflags hsc_env) + { thisInstalledUnitId = toInstalledUnitId interactiveUnitId } } + +setInteractivePrintName :: InteractiveContext -> Name -> InteractiveContext +setInteractivePrintName ic n = ic{ic_int_print = n} + + -- ToDo: should not add Ids to the gbl env here + +-- | Add TyThings to the GlobalRdrEnv, earlier ones in the list shadowing +-- later ones, and shadowing existing entries in the GlobalRdrEnv. +icExtendGblRdrEnv :: GlobalRdrEnv -> [TyThing] -> GlobalRdrEnv +icExtendGblRdrEnv env tythings + = foldr add env tythings -- Foldr makes things in the front of + -- the list shadow things at the back + where + -- One at a time, to ensure each shadows the previous ones + add thing env + | is_sub_bndr thing + = env + | otherwise + = foldl' extendGlobalRdrEnv env1 (concatMap localGREsFromAvail avail) + where + env1 = shadowNames env (concatMap availNames avail) + avail = tyThingAvailInfo thing + + -- Ugh! The new_tythings may include record selectors, since they + -- are not implicit-ids, and must appear in the TypeEnv. But they + -- will also be brought into scope by the corresponding (ATyCon + -- tc). And we want the latter, because that has the correct + -- parent (#10520) + is_sub_bndr (AnId f) = case idDetails f of + RecSelId {} -> True + ClassOpId {} -> True + _ -> False + is_sub_bndr _ = False + +substInteractiveContext :: InteractiveContext -> TCvSubst -> InteractiveContext +substInteractiveContext ictxt@InteractiveContext{ ic_tythings = tts } subst + | isEmptyTCvSubst subst = ictxt + | otherwise = ictxt { ic_tythings = map subst_ty tts } + where + subst_ty (AnId id) + = AnId $ id `setIdType` substTyAddInScope subst (idType id) + -- Variables in the interactive context *can* mention free type variables + -- because of the runtime debugger. Otherwise you'd expect all + -- variables bound in the interactive context to be closed. + subst_ty tt + = tt + +instance Outputable InteractiveImport where + ppr (IIModule m) = char '*' <> ppr m + ppr (IIDecl d) = ppr d + +{- +************************************************************************ +* * + Building a PrintUnqualified +* * +************************************************************************ + +Note [Printing original names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Deciding how to print names is pretty tricky. We are given a name +P:M.T, where P is the package name, M is the defining module, and T is +the occurrence name, and we have to decide in which form to display +the name given a GlobalRdrEnv describing the current scope. + +Ideally we want to display the name in the form in which it is in +scope. However, the name might not be in scope at all, and that's +where it gets tricky. Here are the cases: + + 1. T uniquely maps to P:M.T ---> "T" NameUnqual + 2. There is an X for which X.T + uniquely maps to P:M.T ---> "X.T" NameQual X + 3. There is no binding for "M.T" ---> "M.T" NameNotInScope1 + 4. Otherwise ---> "P:M.T" NameNotInScope2 + +(3) and (4) apply when the entity P:M.T is not in the GlobalRdrEnv at +all. In these cases we still want to refer to the name as "M.T", *but* +"M.T" might mean something else in the current scope (e.g. if there's +an "import X as M"), so to avoid confusion we avoid using "M.T" if +there's already a binding for it. Instead we write P:M.T. + +There's one further subtlety: in case (3), what if there are two +things around, P1:M.T and P2:M.T? Then we don't want to print both of +them as M.T! However only one of the modules P1:M and P2:M can be +exposed (say P2), so we use M.T for that, and P1:M.T for the other one. +This is handled by the qual_mod component of PrintUnqualified, inside +the (ppr mod) of case (3), in Name.pprModulePrefix + +Note [Printing unit ids] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the old days, original names were tied to PackageIds, which directly +corresponded to the entities that users wrote in Cabal files, and were perfectly +suitable for printing when we need to disambiguate packages. However, with +UnitId, the situation can be different: if the key is instantiated with +some holes, we should try to give the user some more useful information. +-} + +-- | Creates some functions that work out the best ways to format +-- names for the user according to a set of heuristics. +mkPrintUnqualified :: DynFlags -> GlobalRdrEnv -> PrintUnqualified +mkPrintUnqualified dflags env = QueryQualify qual_name + (mkQualModule dflags) + (mkQualPackage dflags) + where + qual_name mod occ + | [gre] <- unqual_gres + , right_name gre + = NameUnqual -- If there's a unique entity that's in scope + -- unqualified with 'occ' AND that entity is + -- the right one, then we can use the unqualified name + + | [] <- unqual_gres + , any is_name forceUnqualNames + , not (isDerivedOccName occ) + = NameUnqual -- Don't qualify names that come from modules + -- that come with GHC, often appear in error messages, + -- but aren't typically in scope. Doing this does not + -- cause ambiguity, and it reduces the amount of + -- qualification in error messages thus improving + -- readability. + -- + -- A motivating example is 'Constraint'. It's often not + -- in scope, but printing GHC.Prim.Constraint seems + -- overkill. + + | [gre] <- qual_gres + = NameQual (greQualModName gre) + + | null qual_gres + = if null (lookupGRE_RdrName (mkRdrQual (moduleName mod) occ) env) + then NameNotInScope1 + else NameNotInScope2 + + | otherwise + = NameNotInScope1 -- Can happen if 'f' is bound twice in the module + -- Eg f = True; g = 0; f = False + where + is_name :: Name -> Bool + is_name name = ASSERT2( isExternalName name, ppr name ) + nameModule name == mod && nameOccName name == occ + + forceUnqualNames :: [Name] + forceUnqualNames = + map tyConName [ constraintKindTyCon, heqTyCon, coercibleTyCon ] + ++ [ eqTyConName ] + + right_name gre = nameModule_maybe (gre_name gre) == Just mod + + unqual_gres = lookupGRE_RdrName (mkRdrUnqual occ) env + qual_gres = filter right_name (lookupGlobalRdrEnv env occ) + + -- we can mention a module P:M without the P: qualifier iff + -- "import M" would resolve unambiguously to P:M. (if P is the + -- current package we can just assume it is unqualified). + +-- | Creates a function for formatting modules based on two heuristics: +-- (1) if the module is the current module, don't qualify, and (2) if there +-- is only one exposed package which exports this module, don't qualify. +mkQualModule :: DynFlags -> QueryQualifyModule +mkQualModule dflags mod + | moduleUnitId mod == thisPackage dflags = False + + | [(_, pkgconfig)] <- lookup, + packageConfigId pkgconfig == moduleUnitId mod + -- this says: we are given a module P:M, is there just one exposed package + -- that exposes a module M, and is it package P? + = False + + | otherwise = True + where lookup = lookupModuleInAllPackages dflags (moduleName mod) + +-- | Creates a function for formatting packages based on two heuristics: +-- (1) don't qualify if the package in question is "main", and (2) only qualify +-- with a unit id if the package ID would be ambiguous. +mkQualPackage :: DynFlags -> QueryQualifyPackage +mkQualPackage dflags pkg_key + | pkg_key == mainUnitId || pkg_key == interactiveUnitId + -- Skip the lookup if it's main, since it won't be in the package + -- database! + = False + | Just pkgid <- mb_pkgid + , searchPackageId dflags pkgid `lengthIs` 1 + -- this says: we are given a package pkg-0.1@MMM, are there only one + -- exposed packages whose package ID is pkg-0.1? + = False + | otherwise + = True + where mb_pkgid = fmap sourcePackageId (lookupPackage dflags pkg_key) + +-- | A function which only qualifies package names if necessary; but +-- qualifies all other identifiers. +pkgQual :: DynFlags -> PrintUnqualified +pkgQual dflags = alwaysQualify { + queryQualifyPackage = mkQualPackage dflags + } + +{- +************************************************************************ +* * + Implicit TyThings +* * +************************************************************************ + +Note [Implicit TyThings] +~~~~~~~~~~~~~~~~~~~~~~~~ + DEFINITION: An "implicit" TyThing is one that does not have its own + IfaceDecl in an interface file. Instead, its binding in the type + environment is created as part of typechecking the IfaceDecl for + some other thing. + +Examples: + * All DataCons are implicit, because they are generated from the + IfaceDecl for the data/newtype. Ditto class methods. + + * Record selectors are *not* implicit, because they get their own + free-standing IfaceDecl. + + * Associated data/type families are implicit because they are + included in the IfaceDecl of the parent class. (NB: the + IfaceClass decl happens to use IfaceDecl recursively for the + associated types, but that's irrelevant here.) + + * Dictionary function Ids are not implicit. + + * Axioms for newtypes are implicit (same as above), but axioms + for data/type family instances are *not* implicit (like DFunIds). +-} + +-- | Determine the 'TyThing's brought into scope by another 'TyThing' +-- /other/ than itself. For example, Id's don't have any implicit TyThings +-- as they just bring themselves into scope, but classes bring their +-- dictionary datatype, type constructor and some selector functions into +-- scope, just for a start! + +-- N.B. the set of TyThings returned here *must* match the set of +-- names returned by LoadIface.ifaceDeclImplicitBndrs, in the sense that +-- TyThing.getOccName should define a bijection between the two lists. +-- This invariant is used in LoadIface.loadDecl (see note [Tricky iface loop]) +-- The order of the list does not matter. +implicitTyThings :: TyThing -> [TyThing] +implicitTyThings (AnId _) = [] +implicitTyThings (ACoAxiom _cc) = [] +implicitTyThings (ATyCon tc) = implicitTyConThings tc +implicitTyThings (AConLike cl) = implicitConLikeThings cl + +implicitConLikeThings :: ConLike -> [TyThing] +implicitConLikeThings (RealDataCon dc) + = dataConImplicitTyThings dc + +implicitConLikeThings (PatSynCon {}) + = [] -- Pattern synonyms have no implicit Ids; the wrapper and matcher + -- are not "implicit"; they are simply new top-level bindings, + -- and they have their own declaration in an interface file + -- Unless a record pat syn when there are implicit selectors + -- They are still not included here as `implicitConLikeThings` is + -- used by `tcTyClsDecls` whilst pattern synonyms are typed checked + -- by `tcTopValBinds`. + +implicitClassThings :: Class -> [TyThing] +implicitClassThings cl + = -- Does not include default methods, because those Ids may have + -- their own pragmas, unfoldings etc, not derived from the Class object + + -- associated types + -- No recursive call for the classATs, because they + -- are only the family decls; they have no implicit things + map ATyCon (classATs cl) ++ + + -- superclass and operation selectors + map AnId (classAllSelIds cl) + +implicitTyConThings :: TyCon -> [TyThing] +implicitTyConThings tc + = class_stuff ++ + -- fields (names of selectors) + + -- (possibly) implicit newtype axioms + -- or type family axioms + implicitCoTyCon tc ++ + + -- for each data constructor in order, + -- the constructor, worker, and (possibly) wrapper + [ thing | dc <- tyConDataCons tc + , thing <- AConLike (RealDataCon dc) : dataConImplicitTyThings dc ] + -- NB. record selectors are *not* implicit, they have fully-fledged + -- bindings that pass through the compilation pipeline as normal. + where + class_stuff = case tyConClass_maybe tc of + Nothing -> [] + Just cl -> implicitClassThings cl + +-- For newtypes and closed type families (only) add the implicit coercion tycon +implicitCoTyCon :: TyCon -> [TyThing] +implicitCoTyCon tc + | Just co <- newTyConCo_maybe tc = [ACoAxiom $ toBranchedAxiom co] + | Just co <- isClosedSynFamilyTyConWithAxiom_maybe tc + = [ACoAxiom co] + | otherwise = [] + +-- | Returns @True@ if there should be no interface-file declaration +-- for this thing on its own: either it is built-in, or it is part +-- of some other declaration, or it is generated implicitly by some +-- other declaration. +isImplicitTyThing :: TyThing -> Bool +isImplicitTyThing (AConLike cl) = case cl of + RealDataCon {} -> True + PatSynCon {} -> False +isImplicitTyThing (AnId id) = isImplicitId id +isImplicitTyThing (ATyCon tc) = isImplicitTyCon tc +isImplicitTyThing (ACoAxiom ax) = isImplicitCoAxiom ax + +-- | tyThingParent_maybe x returns (Just p) +-- when pprTyThingInContext should print a declaration for p +-- (albeit with some "..." in it) when asked to show x +-- It returns the *immediate* parent. So a datacon returns its tycon +-- but the tycon could be the associated type of a class, so it in turn +-- might have a parent. +tyThingParent_maybe :: TyThing -> Maybe TyThing +tyThingParent_maybe (AConLike cl) = case cl of + RealDataCon dc -> Just (ATyCon (dataConTyCon dc)) + PatSynCon{} -> Nothing +tyThingParent_maybe (ATyCon tc) = case tyConAssoc_maybe tc of + Just tc -> Just (ATyCon tc) + Nothing -> Nothing +tyThingParent_maybe (AnId id) = case idDetails id of + RecSelId { sel_tycon = RecSelData tc } -> + Just (ATyCon tc) + ClassOpId cls -> + Just (ATyCon (classTyCon cls)) + _other -> Nothing +tyThingParent_maybe _other = Nothing + +tyThingsTyCoVars :: [TyThing] -> TyCoVarSet +tyThingsTyCoVars tts = + unionVarSets $ map ttToVarSet tts + where + ttToVarSet (AnId id) = tyCoVarsOfType $ idType id + ttToVarSet (AConLike cl) = case cl of + RealDataCon dc -> tyCoVarsOfType $ dataConRepType dc + PatSynCon{} -> emptyVarSet + ttToVarSet (ATyCon tc) + = case tyConClass_maybe tc of + Just cls -> (mkVarSet . fst . classTvsFds) cls + Nothing -> tyCoVarsOfType $ tyConKind tc + ttToVarSet (ACoAxiom _) = emptyVarSet + +-- | The Names that a TyThing should bring into scope. Used to build +-- the GlobalRdrEnv for the InteractiveContext. +tyThingAvailInfo :: TyThing -> [AvailInfo] +tyThingAvailInfo (ATyCon t) + = case tyConClass_maybe t of + Just c -> [AvailTC n (n : map getName (classMethods c) + ++ map getName (classATs c)) + [] ] + where n = getName c + Nothing -> [AvailTC n (n : map getName dcs) flds] + where n = getName t + dcs = tyConDataCons t + flds = tyConFieldLabels t +tyThingAvailInfo (AConLike (PatSynCon p)) + = map avail ((getName p) : map flSelector (patSynFieldLabels p)) +tyThingAvailInfo t + = [avail (getName t)] + +{- +************************************************************************ +* * + TypeEnv +* * +************************************************************************ +-} + +-- | A map from 'Name's to 'TyThing's, constructed by typechecking +-- local declarations or interface files +type TypeEnv = NameEnv TyThing + +emptyTypeEnv :: TypeEnv +typeEnvElts :: TypeEnv -> [TyThing] +typeEnvTyCons :: TypeEnv -> [TyCon] +typeEnvCoAxioms :: TypeEnv -> [CoAxiom Branched] +typeEnvIds :: TypeEnv -> [Id] +typeEnvPatSyns :: TypeEnv -> [PatSyn] +typeEnvDataCons :: TypeEnv -> [DataCon] +typeEnvClasses :: TypeEnv -> [Class] +lookupTypeEnv :: TypeEnv -> Name -> Maybe TyThing + +emptyTypeEnv = emptyNameEnv +typeEnvElts env = nameEnvElts env +typeEnvTyCons env = [tc | ATyCon tc <- typeEnvElts env] +typeEnvCoAxioms env = [ax | ACoAxiom ax <- typeEnvElts env] +typeEnvIds env = [id | AnId id <- typeEnvElts env] +typeEnvPatSyns env = [ps | AConLike (PatSynCon ps) <- typeEnvElts env] +typeEnvDataCons env = [dc | AConLike (RealDataCon dc) <- typeEnvElts env] +typeEnvClasses env = [cl | tc <- typeEnvTyCons env, + Just cl <- [tyConClass_maybe tc]] + +mkTypeEnv :: [TyThing] -> TypeEnv +mkTypeEnv things = extendTypeEnvList emptyTypeEnv things + +mkTypeEnvWithImplicits :: [TyThing] -> TypeEnv +mkTypeEnvWithImplicits things = + mkTypeEnv things + `plusNameEnv` + mkTypeEnv (concatMap implicitTyThings things) + +typeEnvFromEntities :: [Id] -> [TyCon] -> [FamInst] -> TypeEnv +typeEnvFromEntities ids tcs famInsts = + mkTypeEnv ( map AnId ids + ++ map ATyCon all_tcs + ++ concatMap implicitTyConThings all_tcs + ++ map (ACoAxiom . toBranchedAxiom . famInstAxiom) famInsts + ) + where + all_tcs = tcs ++ famInstsRepTyCons famInsts + +lookupTypeEnv = lookupNameEnv + +-- Extend the type environment +extendTypeEnv :: TypeEnv -> TyThing -> TypeEnv +extendTypeEnv env thing = extendNameEnv env (getName thing) thing + +extendTypeEnvList :: TypeEnv -> [TyThing] -> TypeEnv +extendTypeEnvList env things = foldl' extendTypeEnv env things + +extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv +extendTypeEnvWithIds env ids + = extendNameEnvList env [(getName id, AnId id) | id <- ids] + +plusTypeEnv :: TypeEnv -> TypeEnv -> TypeEnv +plusTypeEnv env1 env2 = plusNameEnv env1 env2 + +-- | Find the 'TyThing' for the given 'Name' by using all the resources +-- at our disposal: the compiled modules in the 'HomePackageTable' and the +-- compiled modules in other packages that live in 'PackageTypeEnv'. Note +-- that this does NOT look up the 'TyThing' in the module being compiled: you +-- have to do that yourself, if desired +lookupType :: DynFlags + -> HomePackageTable + -> PackageTypeEnv + -> Name + -> Maybe TyThing + +lookupType dflags hpt pte name + | isOneShot (ghcMode dflags) -- in one-shot, we don't use the HPT + = lookupNameEnv pte name + | otherwise + = case lookupHptByModule hpt mod of + Just hm -> lookupNameEnv (md_types (hm_details hm)) name + Nothing -> lookupNameEnv pte name + where + mod = ASSERT2( isExternalName name, ppr name ) + if isHoleName name + then mkModule (thisPackage dflags) (moduleName (nameModule name)) + else nameModule name + +-- | As 'lookupType', but with a marginally easier-to-use interface +-- if you have a 'HscEnv' +lookupTypeHscEnv :: HscEnv -> Name -> IO (Maybe TyThing) +lookupTypeHscEnv hsc_env name = do + eps <- readIORef (hsc_EPS hsc_env) + return $! lookupType dflags hpt (eps_PTE eps) name + where + dflags = hsc_dflags hsc_env + hpt = hsc_HPT hsc_env + +-- | Get the 'TyCon' from a 'TyThing' if it is a type constructor thing. Panics otherwise +tyThingTyCon :: TyThing -> TyCon +tyThingTyCon (ATyCon tc) = tc +tyThingTyCon other = pprPanic "tyThingTyCon" (ppr other) + +-- | Get the 'CoAxiom' from a 'TyThing' if it is a coercion axiom thing. Panics otherwise +tyThingCoAxiom :: TyThing -> CoAxiom Branched +tyThingCoAxiom (ACoAxiom ax) = ax +tyThingCoAxiom other = pprPanic "tyThingCoAxiom" (ppr other) + +-- | Get the 'DataCon' from a 'TyThing' if it is a data constructor thing. Panics otherwise +tyThingDataCon :: TyThing -> DataCon +tyThingDataCon (AConLike (RealDataCon dc)) = dc +tyThingDataCon other = pprPanic "tyThingDataCon" (ppr other) + +-- | Get the 'ConLike' from a 'TyThing' if it is a data constructor thing. +-- Panics otherwise +tyThingConLike :: TyThing -> ConLike +tyThingConLike (AConLike dc) = dc +tyThingConLike other = pprPanic "tyThingConLike" (ppr other) + +-- | Get the 'Id' from a 'TyThing' if it is a id *or* data constructor thing. Panics otherwise +tyThingId :: TyThing -> Id +tyThingId (AnId id) = id +tyThingId (AConLike (RealDataCon dc)) = dataConWrapId dc +tyThingId other = pprPanic "tyThingId" (ppr other) + +{- +************************************************************************ +* * +\subsection{MonadThings and friends} +* * +************************************************************************ +-} + +-- | Class that abstracts out the common ability of the monads in GHC +-- to lookup a 'TyThing' in the monadic environment by 'Name'. Provides +-- a number of related convenience functions for accessing particular +-- kinds of 'TyThing' +class Monad m => MonadThings m where + lookupThing :: Name -> m TyThing + + lookupId :: Name -> m Id + lookupId = liftM tyThingId . lookupThing + + lookupDataCon :: Name -> m DataCon + lookupDataCon = liftM tyThingDataCon . lookupThing + + lookupTyCon :: Name -> m TyCon + lookupTyCon = liftM tyThingTyCon . lookupThing + +{- +************************************************************************ +* * +\subsection{Auxiliary types} +* * +************************************************************************ + +These types are defined here because they are mentioned in ModDetails, +but they are mostly elaborated elsewhere +-} + +------------------ Warnings ------------------------- +-- | Warning information for a module +data Warnings + = NoWarnings -- ^ Nothing deprecated + | WarnAll WarningTxt -- ^ Whole module deprecated + | WarnSome [(OccName,WarningTxt)] -- ^ Some specific things deprecated + + -- Only an OccName is needed because + -- (1) a deprecation always applies to a binding + -- defined in the module in which the deprecation appears. + -- (2) deprecations are only reported outside the defining module. + -- this is important because, otherwise, if we saw something like + -- + -- {-# DEPRECATED f "" #-} + -- f = ... + -- h = f + -- g = let f = undefined in f + -- + -- we'd need more information than an OccName to know to say something + -- about the use of f in h but not the use of the locally bound f in g + -- + -- however, because we only report about deprecations from the outside, + -- and a module can only export one value called f, + -- an OccName suffices. + -- + -- this is in contrast with fixity declarations, where we need to map + -- a Name to its fixity declaration. + deriving( Eq ) + +instance Binary Warnings where + put_ bh NoWarnings = putByte bh 0 + put_ bh (WarnAll t) = do + putByte bh 1 + put_ bh t + put_ bh (WarnSome ts) = do + putByte bh 2 + put_ bh ts + + get bh = do + h <- getByte bh + case h of + 0 -> return NoWarnings + 1 -> do aa <- get bh + return (WarnAll aa) + _ -> do aa <- get bh + return (WarnSome aa) + +-- | Constructs the cache for the 'mi_warn_fn' field of a 'ModIface' +mkIfaceWarnCache :: Warnings -> OccName -> Maybe WarningTxt +mkIfaceWarnCache NoWarnings = \_ -> Nothing +mkIfaceWarnCache (WarnAll t) = \_ -> Just t +mkIfaceWarnCache (WarnSome pairs) = lookupOccEnv (mkOccEnv pairs) + +emptyIfaceWarnCache :: OccName -> Maybe WarningTxt +emptyIfaceWarnCache _ = Nothing + +plusWarns :: Warnings -> Warnings -> Warnings +plusWarns d NoWarnings = d +plusWarns NoWarnings d = d +plusWarns _ (WarnAll t) = WarnAll t +plusWarns (WarnAll t) _ = WarnAll t +plusWarns (WarnSome v1) (WarnSome v2) = WarnSome (v1 ++ v2) + +-- | Creates cached lookup for the 'mi_fix_fn' field of 'ModIface' +mkIfaceFixCache :: [(OccName, Fixity)] -> OccName -> Maybe Fixity +mkIfaceFixCache pairs + = \n -> lookupOccEnv env n + where + env = mkOccEnv pairs + +emptyIfaceFixCache :: OccName -> Maybe Fixity +emptyIfaceFixCache _ = Nothing + +-- | Fixity environment mapping names to their fixities +type FixityEnv = NameEnv FixItem + +-- | Fixity information for an 'Name'. We keep the OccName in the range +-- so that we can generate an interface from it +data FixItem = FixItem OccName Fixity + +instance Outputable FixItem where + ppr (FixItem occ fix) = ppr fix <+> ppr occ + +emptyFixityEnv :: FixityEnv +emptyFixityEnv = emptyNameEnv + +lookupFixity :: FixityEnv -> Name -> Fixity +lookupFixity env n = case lookupNameEnv env n of + Just (FixItem _ fix) -> fix + Nothing -> defaultFixity + +{- +************************************************************************ +* * +\subsection{WhatsImported} +* * +************************************************************************ +-} + +-- | Records whether a module has orphans. An \"orphan\" is one of: +-- +-- * An instance declaration in a module other than the definition +-- module for one of the type constructors or classes in the instance head +-- +-- * A transformation rule in a module other than the one defining +-- the function in the head of the rule +-- +type WhetherHasOrphans = Bool + +-- | Does this module define family instances? +type WhetherHasFamInst = Bool + +-- | Did this module originate from a *-boot file? +type IsBootInterface = Bool + +-- | Dependency information about ALL modules and packages below this one +-- in the import hierarchy. +-- +-- Invariant: the dependencies of a module @M@ never includes @M@. +-- +-- Invariant: none of the lists contain duplicates. +data Dependencies + = Deps { dep_mods :: [(ModuleName, IsBootInterface)] + -- ^ All home-package modules transitively below this one + -- I.e. modules that this one imports, or that are in the + -- dep_mods of those directly-imported modules + + , dep_pkgs :: [(InstalledUnitId, Bool)] + -- ^ All packages transitively below this module + -- I.e. packages to which this module's direct imports belong, + -- or that are in the dep_pkgs of those modules + -- The bool indicates if the package is required to be + -- trusted when the module is imported as a safe import + -- (Safe Haskell). See Note [RnNames . Tracking Trust Transitively] + + , dep_orphs :: [Module] + -- ^ Transitive closure of orphan modules (whether + -- home or external pkg). + -- + -- (Possible optimization: don't include family + -- instance orphans as they are anyway included in + -- 'dep_finsts'. But then be careful about code + -- which relies on dep_orphs having the complete list!) + -- This does NOT include us, unlike 'imp_orphs'. + + , dep_finsts :: [Module] + -- ^ Transitive closure of depended upon modules which + -- contain family instances (whether home or external). + -- This is used by 'checkFamInstConsistency'. This + -- does NOT include us, unlike 'imp_finsts'. See Note + -- [The type family instance consistency story]. + + , dep_plgins :: [ModuleName] + -- ^ All the plugins used while compiling this module. + } + deriving( Eq ) + -- Equality used only for old/new comparison in MkIface.addFingerprints + -- See 'TcRnTypes.ImportAvails' for details on dependencies. + +instance Binary Dependencies where + put_ bh deps = do put_ bh (dep_mods deps) + put_ bh (dep_pkgs deps) + put_ bh (dep_orphs deps) + put_ bh (dep_finsts deps) + put_ bh (dep_plgins deps) + + get bh = do ms <- get bh + ps <- get bh + os <- get bh + fis <- get bh + pl <- get bh + return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os, + dep_finsts = fis, dep_plgins = pl }) + +noDependencies :: Dependencies +noDependencies = Deps [] [] [] [] [] + +-- | Records modules for which changes may force recompilation of this module +-- See wiki: https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance +-- +-- This differs from Dependencies. A module X may be in the dep_mods of this +-- module (via an import chain) but if we don't use anything from X it won't +-- appear in our Usage +data Usage + -- | Module from another package + = UsagePackageModule { + usg_mod :: Module, + -- ^ External package module depended on + usg_mod_hash :: Fingerprint, + -- ^ Cached module fingerprint + usg_safe :: IsSafeImport + -- ^ Was this module imported as a safe import + } + -- | Module from the current package + | UsageHomeModule { + usg_mod_name :: ModuleName, + -- ^ Name of the module + usg_mod_hash :: Fingerprint, + -- ^ Cached module fingerprint + usg_entities :: [(OccName,Fingerprint)], + -- ^ Entities we depend on, sorted by occurrence name and fingerprinted. + -- NB: usages are for parent names only, e.g. type constructors + -- but not the associated data constructors. + usg_exports :: Maybe Fingerprint, + -- ^ Fingerprint for the export list of this module, + -- if we directly imported it (and hence we depend on its export list) + usg_safe :: IsSafeImport + -- ^ Was this module imported as a safe import + } -- ^ Module from the current package + -- | A file upon which the module depends, e.g. a CPP #include, or using TH's + -- 'addDependentFile' + | UsageFile { + usg_file_path :: FilePath, + -- ^ External file dependency. From a CPP #include or TH + -- addDependentFile. Should be absolute. + usg_file_hash :: Fingerprint + -- ^ 'Fingerprint' of the file contents. + + -- Note: We don't consider things like modification timestamps + -- here, because there's no reason to recompile if the actual + -- contents don't change. This previously lead to odd + -- recompilation behaviors; see #8114 + } + -- | A requirement which was merged into this one. + | UsageMergedRequirement { + usg_mod :: Module, + usg_mod_hash :: Fingerprint + } + deriving( Eq ) + -- The export list field is (Just v) if we depend on the export list: + -- i.e. we imported the module directly, whether or not we + -- enumerated the things we imported, or just imported + -- everything + -- We need to recompile if M's exports change, because + -- if the import was import M, we might now have a name clash + -- in the importing module. + -- if the import was import M(x) M might no longer export x + -- The only way we don't depend on the export list is if we have + -- import M() + -- And of course, for modules that aren't imported directly we don't + -- depend on their export lists + +instance Binary Usage where + put_ bh usg@UsagePackageModule{} = do + putByte bh 0 + put_ bh (usg_mod usg) + put_ bh (usg_mod_hash usg) + put_ bh (usg_safe usg) + + put_ bh usg@UsageHomeModule{} = do + putByte bh 1 + put_ bh (usg_mod_name usg) + put_ bh (usg_mod_hash usg) + put_ bh (usg_exports usg) + put_ bh (usg_entities usg) + put_ bh (usg_safe usg) + + put_ bh usg@UsageFile{} = do + putByte bh 2 + put_ bh (usg_file_path usg) + put_ bh (usg_file_hash usg) + + put_ bh usg@UsageMergedRequirement{} = do + putByte bh 3 + put_ bh (usg_mod usg) + put_ bh (usg_mod_hash usg) + + get bh = do + h <- getByte bh + case h of + 0 -> do + nm <- get bh + mod <- get bh + safe <- get bh + return UsagePackageModule { usg_mod = nm, usg_mod_hash = mod, usg_safe = safe } + 1 -> do + nm <- get bh + mod <- get bh + exps <- get bh + ents <- get bh + safe <- get bh + return UsageHomeModule { usg_mod_name = nm, usg_mod_hash = mod, + usg_exports = exps, usg_entities = ents, usg_safe = safe } + 2 -> do + fp <- get bh + hash <- get bh + return UsageFile { usg_file_path = fp, usg_file_hash = hash } + 3 -> do + mod <- get bh + hash <- get bh + return UsageMergedRequirement { usg_mod = mod, usg_mod_hash = hash } + i -> error ("Binary.get(Usage): " ++ show i) + +{- +************************************************************************ +* * + The External Package State +* * +************************************************************************ +-} + +type PackageTypeEnv = TypeEnv +type PackageRuleBase = RuleBase +type PackageInstEnv = InstEnv +type PackageFamInstEnv = FamInstEnv +type PackageAnnEnv = AnnEnv +type PackageCompleteMatchMap = CompleteMatchMap + +-- | Information about other packages that we have slurped in by reading +-- their interface files +data ExternalPackageState + = EPS { + eps_is_boot :: !(ModuleNameEnv (ModuleName, IsBootInterface)), + -- ^ In OneShot mode (only), home-package modules + -- accumulate in the external package state, and are + -- sucked in lazily. For these home-pkg modules + -- (only) we need to record which are boot modules. + -- We set this field after loading all the + -- explicitly-imported interfaces, but before doing + -- anything else + -- + -- The 'ModuleName' part is not necessary, but it's useful for + -- debug prints, and it's convenient because this field comes + -- direct from 'TcRnTypes.imp_dep_mods' + + eps_PIT :: !PackageIfaceTable, + -- ^ The 'ModIface's for modules in external packages + -- whose interfaces we have opened. + -- The declarations in these interface files are held in the + -- 'eps_decls', 'eps_inst_env', 'eps_fam_inst_env' and 'eps_rules' + -- fields of this record, not in the 'mi_decls' fields of the + -- interface we have sucked in. + -- + -- What /is/ in the PIT is: + -- + -- * The Module + -- + -- * Fingerprint info + -- + -- * Its exports + -- + -- * Fixities + -- + -- * Deprecations and warnings + + eps_free_holes :: InstalledModuleEnv (UniqDSet ModuleName), + -- ^ Cache for 'mi_free_holes'. Ordinarily, we can rely on + -- the 'eps_PIT' for this information, EXCEPT that when + -- we do dependency analysis, we need to look at the + -- 'Dependencies' of our imports to determine what their + -- precise free holes are ('moduleFreeHolesPrecise'). We + -- don't want to repeatedly reread in the interface + -- for every import, so cache it here. When the PIT + -- gets filled in we can drop these entries. + + eps_PTE :: !PackageTypeEnv, + -- ^ Result of typechecking all the external package + -- interface files we have sucked in. The domain of + -- the mapping is external-package modules + + eps_inst_env :: !PackageInstEnv, -- ^ The total 'InstEnv' accumulated + -- from all the external-package modules + eps_fam_inst_env :: !PackageFamInstEnv,-- ^ The total 'FamInstEnv' accumulated + -- from all the external-package modules + eps_rule_base :: !PackageRuleBase, -- ^ The total 'RuleEnv' accumulated + -- from all the external-package modules + eps_ann_env :: !PackageAnnEnv, -- ^ The total 'AnnEnv' accumulated + -- from all the external-package modules + eps_complete_matches :: !PackageCompleteMatchMap, + -- ^ The total 'CompleteMatchMap' accumulated + -- from all the external-package modules + + eps_mod_fam_inst_env :: !(ModuleEnv FamInstEnv), -- ^ The family instances accumulated from external + -- packages, keyed off the module that declared them + + eps_stats :: !EpsStats -- ^ Stastics about what was loaded from external packages + } + +-- | Accumulated statistics about what we are putting into the 'ExternalPackageState'. +-- \"In\" means stuff that is just /read/ from interface files, +-- \"Out\" means actually sucked in and type-checked +data EpsStats = EpsStats { n_ifaces_in + , n_decls_in, n_decls_out + , n_rules_in, n_rules_out + , n_insts_in, n_insts_out :: !Int } + +addEpsInStats :: EpsStats -> Int -> Int -> Int -> EpsStats +-- ^ Add stats for one newly-read interface +addEpsInStats stats n_decls n_insts n_rules + = stats { n_ifaces_in = n_ifaces_in stats + 1 + , n_decls_in = n_decls_in stats + n_decls + , n_insts_in = n_insts_in stats + n_insts + , n_rules_in = n_rules_in stats + n_rules } + +{- +Names in a NameCache are always stored as a Global, and have the SrcLoc +of their binding locations. + +Actually that's not quite right. When we first encounter the original +name, we might not be at its binding site (e.g. we are reading an +interface file); so we give it 'noSrcLoc' then. Later, when we find +its binding site, we fix it up. +-} + +updNameCache :: IORef NameCache + -> (NameCache -> (NameCache, c)) -- The updating function + -> IO c +updNameCache ncRef upd_fn + = atomicModifyIORef' ncRef upd_fn + +mkSOName :: Platform -> FilePath -> FilePath +mkSOName platform root + = case platformOS platform of + OSMinGW32 -> root <.> soExt platform + _ -> ("lib" ++ root) <.> soExt platform + +mkHsSOName :: Platform -> FilePath -> FilePath +mkHsSOName platform root = ("lib" ++ root) <.> soExt platform + +soExt :: Platform -> FilePath +soExt platform + = case platformOS platform of + OSDarwin -> "dylib" + OSMinGW32 -> "dll" + _ -> "so" + +{- +************************************************************************ +* * + The module graph and ModSummary type + A ModSummary is a node in the compilation manager's + dependency graph, and it's also passed to hscMain +* * +************************************************************************ +-} + +-- | A ModuleGraph contains all the nodes from the home package (only). +-- There will be a node for each source module, plus a node for each hi-boot +-- module. +-- +-- The graph is not necessarily stored in topologically-sorted order. Use +-- 'GHC.topSortModuleGraph' and 'Digraph.flattenSCC' to achieve this. +data ModuleGraph = ModuleGraph + { mg_mss :: [ModSummary] + , mg_non_boot :: ModuleEnv ModSummary + -- a map of all non-boot ModSummaries keyed by Modules + , mg_boot :: ModuleSet + -- a set of boot Modules + , mg_needs_th_or_qq :: !Bool + -- does any of the modules in mg_mss require TemplateHaskell or + -- QuasiQuotes? + } + +-- | Determines whether a set of modules requires Template Haskell or +-- Quasi Quotes +-- +-- Note that if the session's 'DynFlags' enabled Template Haskell when +-- 'depanal' was called, then each module in the returned module graph will +-- have Template Haskell enabled whether it is actually needed or not. +needsTemplateHaskellOrQQ :: ModuleGraph -> Bool +needsTemplateHaskellOrQQ mg = mg_needs_th_or_qq mg + +-- | Map a function 'f' over all the 'ModSummaries'. +-- To preserve invariants 'f' can't change the isBoot status. +mapMG :: (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph +mapMG f mg@ModuleGraph{..} = mg + { mg_mss = map f mg_mss + , mg_non_boot = mapModuleEnv f mg_non_boot + } + +mgBootModules :: ModuleGraph -> ModuleSet +mgBootModules ModuleGraph{..} = mg_boot + +mgModSummaries :: ModuleGraph -> [ModSummary] +mgModSummaries = mg_mss + +mgElemModule :: ModuleGraph -> Module -> Bool +mgElemModule ModuleGraph{..} m = elemModuleEnv m mg_non_boot + +-- | Look up a ModSummary in the ModuleGraph +mgLookupModule :: ModuleGraph -> Module -> Maybe ModSummary +mgLookupModule ModuleGraph{..} m = lookupModuleEnv mg_non_boot m + +emptyMG :: ModuleGraph +emptyMG = ModuleGraph [] emptyModuleEnv emptyModuleSet False + +isTemplateHaskellOrQQNonBoot :: ModSummary -> Bool +isTemplateHaskellOrQQNonBoot ms = + (xopt LangExt.TemplateHaskell (ms_hspp_opts ms) + || xopt LangExt.QuasiQuotes (ms_hspp_opts ms)) && + not (isBootSummary ms) + +-- | Add a ModSummary to ModuleGraph. Assumes that the new ModSummary is +-- not an element of the ModuleGraph. +extendMG :: ModuleGraph -> ModSummary -> ModuleGraph +extendMG ModuleGraph{..} ms = ModuleGraph + { mg_mss = ms:mg_mss + , mg_non_boot = if isBootSummary ms + then mg_non_boot + else extendModuleEnv mg_non_boot (ms_mod ms) ms + , mg_boot = if isBootSummary ms + then extendModuleSet mg_boot (ms_mod ms) + else mg_boot + , mg_needs_th_or_qq = mg_needs_th_or_qq || isTemplateHaskellOrQQNonBoot ms + } + +mkModuleGraph :: [ModSummary] -> ModuleGraph +mkModuleGraph = foldr (flip extendMG) emptyMG + +-- | A single node in a 'ModuleGraph'. The nodes of the module graph +-- are one of: +-- +-- * A regular Haskell source module +-- * A hi-boot source module +-- +data ModSummary + = ModSummary { + ms_mod :: Module, + -- ^ Identity of the module + ms_hsc_src :: HscSource, + -- ^ The module source either plain Haskell or hs-boot + ms_location :: ModLocation, + -- ^ Location of the various files belonging to the module + ms_hs_date :: UTCTime, + -- ^ Timestamp of source file + ms_obj_date :: Maybe UTCTime, + -- ^ Timestamp of object, if we have one + ms_iface_date :: Maybe UTCTime, + -- ^ Timestamp of hi file, if we *only* are typechecking (it is + -- 'Nothing' otherwise. + -- See Note [Recompilation checking in -fno-code mode] and #9243 + ms_hie_date :: Maybe UTCTime, + -- ^ Timestamp of hie file, if we have one + ms_srcimps :: [(Maybe FastString, Located ModuleName)], + -- ^ Source imports of the module + ms_textual_imps :: [(Maybe FastString, Located ModuleName)], + -- ^ Non-source imports of the module from the module *text* + ms_parsed_mod :: Maybe HsParsedModule, + -- ^ The parsed, nonrenamed source, if we have it. This is also + -- used to support "inline module syntax" in Backpack files. + ms_hspp_file :: FilePath, + -- ^ Filename of preprocessed source file + ms_hspp_opts :: DynFlags, + -- ^ Cached flags from @OPTIONS@, @INCLUDE@ and @LANGUAGE@ + -- pragmas in the modules source code + ms_hspp_buf :: Maybe StringBuffer + -- ^ The actual preprocessed source, if we have it + } + +ms_installed_mod :: ModSummary -> InstalledModule +ms_installed_mod = fst . splitModuleInsts . ms_mod + +ms_mod_name :: ModSummary -> ModuleName +ms_mod_name = moduleName . ms_mod + +ms_imps :: ModSummary -> [(Maybe FastString, Located ModuleName)] +ms_imps ms = + ms_textual_imps ms ++ + map mk_additional_import (dynFlagDependencies (ms_hspp_opts ms)) + where + mk_additional_import mod_nm = (Nothing, noLoc mod_nm) + +-- The ModLocation contains both the original source filename and the +-- filename of the cleaned-up source file after all preprocessing has been +-- done. The point is that the summariser will have to cpp/unlit/whatever +-- all files anyway, and there's no point in doing this twice -- just +-- park the result in a temp file, put the name of it in the location, +-- and let @compile@ read from that file on the way back up. + +-- The ModLocation is stable over successive up-sweeps in GHCi, wheres +-- the ms_hs_date and imports can, of course, change + +msHsFilePath, msHiFilePath, msObjFilePath :: ModSummary -> FilePath +msHsFilePath ms = expectJust "msHsFilePath" (ml_hs_file (ms_location ms)) +msHiFilePath ms = ml_hi_file (ms_location ms) +msObjFilePath ms = ml_obj_file (ms_location ms) + +-- | Did this 'ModSummary' originate from a hs-boot file? +isBootSummary :: ModSummary -> Bool +isBootSummary ms = ms_hsc_src ms == HsBootFile + +instance Outputable ModSummary where + ppr ms + = sep [text "ModSummary {", + nest 3 (sep [text "ms_hs_date = " <> text (show (ms_hs_date ms)), + text "ms_mod =" <+> ppr (ms_mod ms) + <> text (hscSourceString (ms_hsc_src ms)) <> comma, + text "ms_textual_imps =" <+> ppr (ms_textual_imps ms), + text "ms_srcimps =" <+> ppr (ms_srcimps ms)]), + char '}' + ] + +showModMsg :: DynFlags -> HscTarget -> Bool -> ModSummary -> String +showModMsg dflags target recomp mod_summary = showSDoc dflags $ + if gopt Opt_HideSourcePaths dflags + then text mod_str + else hsep + [ text (mod_str ++ replicate (max 0 (16 - length mod_str)) ' ') + , char '(' + , text (op $ msHsFilePath mod_summary) <> char ',' + , case target of + HscInterpreted | recomp -> text "interpreted" + HscNothing -> text "nothing" + _ -> text (op $ msObjFilePath mod_summary) + , char ')' + ] + where + op = normalise + mod = moduleName (ms_mod mod_summary) + mod_str = showPpr dflags mod ++ hscSourceString (ms_hsc_src mod_summary) + +{- +************************************************************************ +* * +\subsection{Recompilation} +* * +************************************************************************ +-} + +-- | Indicates whether a given module's source has been modified since it +-- was last compiled. +data SourceModified + = SourceModified + -- ^ the source has been modified + | SourceUnmodified + -- ^ the source has not been modified. Compilation may or may + -- not be necessary, depending on whether any dependencies have + -- changed since we last compiled. + | SourceUnmodifiedAndStable + -- ^ the source has not been modified, and furthermore all of + -- its (transitive) dependencies are up to date; it definitely + -- does not need to be recompiled. This is important for two + -- reasons: (a) we can omit the version check in checkOldIface, + -- and (b) if the module used TH splices we don't need to force + -- recompilation. + +{- +************************************************************************ +* * +\subsection{Hpc Support} +* * +************************************************************************ +-} + +-- | Information about a modules use of Haskell Program Coverage +data HpcInfo + = HpcInfo + { hpcInfoTickCount :: Int + , hpcInfoHash :: Int + } + | NoHpcInfo + { hpcUsed :: AnyHpcUsage -- ^ Is hpc used anywhere on the module \*tree\*? + } + +-- | This is used to signal if one of my imports used HPC instrumentation +-- even if there is no module-local HPC usage +type AnyHpcUsage = Bool + +emptyHpcInfo :: AnyHpcUsage -> HpcInfo +emptyHpcInfo = NoHpcInfo + +-- | Find out if HPC is used by this module or any of the modules +-- it depends upon +isHpcUsed :: HpcInfo -> AnyHpcUsage +isHpcUsed (HpcInfo {}) = True +isHpcUsed (NoHpcInfo { hpcUsed = used }) = used + +{- +************************************************************************ +* * +\subsection{Safe Haskell Support} +* * +************************************************************************ + +This stuff here is related to supporting the Safe Haskell extension, +primarily about storing under what trust type a module has been compiled. +-} + +-- | Is an import a safe import? +type IsSafeImport = Bool + +-- | Safe Haskell information for 'ModIface' +-- Simply a wrapper around SafeHaskellMode to sepperate iface and flags +newtype IfaceTrustInfo = TrustInfo SafeHaskellMode + +getSafeMode :: IfaceTrustInfo -> SafeHaskellMode +getSafeMode (TrustInfo x) = x + +setSafeMode :: SafeHaskellMode -> IfaceTrustInfo +setSafeMode = TrustInfo + +noIfaceTrustInfo :: IfaceTrustInfo +noIfaceTrustInfo = setSafeMode Sf_None + +trustInfoToNum :: IfaceTrustInfo -> Word8 +trustInfoToNum it + = case getSafeMode it of + Sf_None -> 0 + Sf_Unsafe -> 1 + Sf_Trustworthy -> 2 + Sf_Safe -> 3 + Sf_Ignore -> 0 + +numToTrustInfo :: Word8 -> IfaceTrustInfo +numToTrustInfo 0 = setSafeMode Sf_None +numToTrustInfo 1 = setSafeMode Sf_Unsafe +numToTrustInfo 2 = setSafeMode Sf_Trustworthy +numToTrustInfo 3 = setSafeMode Sf_Safe +numToTrustInfo 4 = setSafeMode Sf_Safe -- retained for backwards compat, used + -- to be Sf_SafeInfered but we no longer + -- differentiate. +numToTrustInfo n = error $ "numToTrustInfo: bad input number! (" ++ show n ++ ")" + +instance Outputable IfaceTrustInfo where + ppr (TrustInfo Sf_None) = text "none" + ppr (TrustInfo Sf_Ignore) = text "none" + ppr (TrustInfo Sf_Unsafe) = text "unsafe" + ppr (TrustInfo Sf_Trustworthy) = text "trustworthy" + ppr (TrustInfo Sf_Safe) = text "safe" + +instance Binary IfaceTrustInfo where + put_ bh iftrust = putByte bh $ trustInfoToNum iftrust + get bh = getByte bh >>= (return . numToTrustInfo) + +{- +************************************************************************ +* * +\subsection{Parser result} +* * +************************************************************************ +-} + +data HsParsedModule = HsParsedModule { + hpm_module :: Located (HsModule GhcPs), + hpm_src_files :: [FilePath], + -- ^ extra source files (e.g. from #includes). The lexer collects + -- these from '# ' pragmas, which the C preprocessor + -- leaves behind. These files and their timestamps are stored in + -- the .hi file, so that we can force recompilation if any of + -- them change (#3589) + hpm_annotations :: ApiAnns + -- See note [Api annotations] in ApiAnnotation.hs + } + +{- +************************************************************************ +* * +\subsection{Linkable stuff} +* * +************************************************************************ + +This stuff is in here, rather than (say) in Linker.hs, because the Linker.hs +stuff is the *dynamic* linker, and isn't present in a stage-1 compiler +-} + +-- | Information we can use to dynamically link modules into the compiler +data Linkable = LM { + linkableTime :: UTCTime, -- ^ Time at which this linkable was built + -- (i.e. when the bytecodes were produced, + -- or the mod date on the files) + linkableModule :: Module, -- ^ The linkable module itself + linkableUnlinked :: [Unlinked] + -- ^ Those files and chunks of code we have yet to link. + -- + -- INVARIANT: A valid linkable always has at least one 'Unlinked' item. + -- If this list is empty, the Linkable represents a fake linkable, which + -- is generated in HscNothing mode to avoid recompiling modules. + -- + -- ToDo: Do items get removed from this list when they get linked? + } + +isObjectLinkable :: Linkable -> Bool +isObjectLinkable l = not (null unlinked) && all isObject unlinked + where unlinked = linkableUnlinked l + -- A linkable with no Unlinked's is treated as a BCO. We can + -- generate a linkable with no Unlinked's as a result of + -- compiling a module in HscNothing mode, and this choice + -- happens to work well with checkStability in module GHC. + +linkableObjs :: Linkable -> [FilePath] +linkableObjs l = [ f | DotO f <- linkableUnlinked l ] + +instance Outputable Linkable where + ppr (LM when_made mod unlinkeds) + = (text "LinkableM" <+> parens (text (show when_made)) <+> ppr mod) + $$ nest 3 (ppr unlinkeds) + +------------------------------------------- + +-- | Objects which have yet to be linked by the compiler +data Unlinked + = DotO FilePath -- ^ An object file (.o) + | DotA FilePath -- ^ Static archive file (.a) + | DotDLL FilePath -- ^ Dynamically linked library file (.so, .dll, .dylib) + | BCOs CompiledByteCode + [SptEntry] -- ^ A byte-code object, lives only in memory. Also + -- carries some static pointer table entries which + -- should be loaded along with the BCOs. + -- See Note [Grant plan for static forms] in + -- StaticPtrTable. + +instance Outputable Unlinked where + ppr (DotO path) = text "DotO" <+> text path + ppr (DotA path) = text "DotA" <+> text path + ppr (DotDLL path) = text "DotDLL" <+> text path + ppr (BCOs bcos spt) = text "BCOs" <+> ppr bcos <+> ppr spt + +-- | Is this an actual file on disk we can link in somehow? +isObject :: Unlinked -> Bool +isObject (DotO _) = True +isObject (DotA _) = True +isObject (DotDLL _) = True +isObject _ = False + +-- | Is this a bytecode linkable with no file on disk? +isInterpretable :: Unlinked -> Bool +isInterpretable = not . isObject + +-- | Retrieve the filename of the linkable if possible. Panic if it is a byte-code object +nameOfObject :: Unlinked -> FilePath +nameOfObject (DotO fn) = fn +nameOfObject (DotA fn) = fn +nameOfObject (DotDLL fn) = fn +nameOfObject other = pprPanic "nameOfObject" (ppr other) + +-- | Retrieve the compiled byte-code if possible. Panic if it is a file-based linkable +byteCodeOfObject :: Unlinked -> CompiledByteCode +byteCodeOfObject (BCOs bc _) = bc +byteCodeOfObject other = pprPanic "byteCodeOfObject" (ppr other) + + +------------------------------------------- + +-- | A list of conlikes which represents a complete pattern match. +-- These arise from @COMPLETE@ signatures. + +-- See Note [Implementation of COMPLETE signatures] +data CompleteMatch = CompleteMatch { + completeMatchConLikes :: [Name] + -- ^ The ConLikes that form a covering family + -- (e.g. Nothing, Just) + , completeMatchTyCon :: Name + -- ^ The TyCon that they cover (e.g. Maybe) + } + +instance Outputable CompleteMatch where + ppr (CompleteMatch cl ty) = text "CompleteMatch:" <+> ppr cl + <+> dcolon <+> ppr ty + +-- | A map keyed by the 'completeMatchTyCon'. + +-- See Note [Implementation of COMPLETE signatures] +type CompleteMatchMap = UniqFM [CompleteMatch] + +mkCompleteMatchMap :: [CompleteMatch] -> CompleteMatchMap +mkCompleteMatchMap = extendCompleteMatchMap emptyUFM + +extendCompleteMatchMap :: CompleteMatchMap -> [CompleteMatch] + -> CompleteMatchMap +extendCompleteMatchMap = foldl' insertMatch + where + insertMatch :: CompleteMatchMap -> CompleteMatch -> CompleteMatchMap + insertMatch ufm c@(CompleteMatch _ t) = addToUFM_C (++) ufm t [c] + +{- +Note [Implementation of COMPLETE signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A COMPLETE signature represents a set of conlikes (i.e., constructors or +pattern synonyms) such that if they are all pattern-matched against in a +function, it gives rise to a total function. An example is: + + newtype Boolean = Boolean Int + pattern F, T :: Boolean + pattern F = Boolean 0 + pattern T = Boolean 1 + {-# COMPLETE F, T #-} + + -- This is a total function + booleanToInt :: Boolean -> Int + booleanToInt F = 0 + booleanToInt T = 1 + +COMPLETE sets are represented internally in GHC with the CompleteMatch data +type. For example, {-# COMPLETE F, T #-} would be represented as: + + CompleteMatch { complateMatchConLikes = [F, T] + , completeMatchTyCon = Boolean } + +Note that GHC was able to infer the completeMatchTyCon (Boolean), but for the +cases in which it's ambiguous, you can also explicitly specify it in the source +language by writing this: + + {-# COMPLETE F, T :: Boolean #-} + +For efficiency purposes, GHC collects all of the CompleteMatches that it knows +about into a CompleteMatchMap, which is a map that is keyed by the +completeMatchTyCon. In other words, you could have a multiple COMPLETE sets +for the same TyCon: + + {-# COMPLETE F, T1 :: Boolean #-} + {-# COMPLETE F, T2 :: Boolean #-} + +And looking up the values in the CompleteMatchMap associated with Boolean +would give you [CompleteMatch [F, T1] Boolean, CompleteMatch [F, T2] Boolean]. +dsGetCompleteMatches in DsMeta accomplishes this lookup. + +Also see Note [Typechecking Complete Matches] in TcBinds for a more detailed +explanation for how GHC ensures that all the conlikes in a COMPLETE set are +consistent. +-} diff --git a/compiler/main/InteractiveEvalTypes.hs b/compiler/main/InteractiveEvalTypes.hs new file mode 100644 --- /dev/null +++ b/compiler/main/InteractiveEvalTypes.hs @@ -0,0 +1,89 @@ +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow, 2005-2007 +-- +-- Running statements interactively +-- +-- ----------------------------------------------------------------------------- + +module InteractiveEvalTypes ( + Resume(..), History(..), ExecResult(..), + SingleStep(..), isStep, ExecOptions(..), + BreakInfo(..) + ) where + +import GhcPrelude + +import GHCi.RemoteTypes +import GHCi.Message (EvalExpr, ResumeContext) +import Id +import Name +import Module +import RdrName +import Type +import SrcLoc +import Exception + +import Data.Word +import GHC.Stack.CCS + +data ExecOptions + = ExecOptions + { execSingleStep :: SingleStep -- ^ stepping mode + , execSourceFile :: String -- ^ filename (for errors) + , execLineNumber :: Int -- ^ line number (for errors) + , execWrap :: ForeignHValue -> EvalExpr ForeignHValue + } + +data SingleStep + = RunToCompletion + | SingleStep + | RunAndLogSteps + +isStep :: SingleStep -> Bool +isStep RunToCompletion = False +isStep _ = True + +data ExecResult + = ExecComplete + { execResult :: Either SomeException [Name] + , execAllocation :: Word64 + } + | ExecBreak + { breakNames :: [Name] + , breakInfo :: Maybe BreakInfo + } + +data BreakInfo = BreakInfo + { breakInfo_module :: Module + , breakInfo_number :: Int + } + +data Resume = Resume + { resumeStmt :: String -- the original statement + , resumeContext :: ForeignRef (ResumeContext [HValueRef]) + , resumeBindings :: ([TyThing], GlobalRdrEnv) + , resumeFinalIds :: [Id] -- [Id] to bind on completion + , resumeApStack :: ForeignHValue -- The object from which we can get + -- value of the free variables. + , resumeBreakInfo :: Maybe BreakInfo + -- the breakpoint we stopped at + -- (module, index) + -- (Nothing <=> exception) + , resumeSpan :: SrcSpan -- just a copy of the SrcSpan + -- from the ModBreaks, + -- otherwise it's a pain to + -- fetch the ModDetails & + -- ModBreaks to get this. + , resumeDecl :: String -- ditto + , resumeCCS :: RemotePtr CostCentreStack + , resumeHistory :: [History] + , resumeHistoryIx :: Int -- 0 <==> at the top of the history + } + +data History + = History { + historyApStack :: ForeignHValue, + historyBreakInfo :: BreakInfo, + historyEnclosingDecls :: [String] -- declarations enclosing the breakpoint + } diff --git a/compiler/main/PackageConfig.hs b/compiler/main/PackageConfig.hs new file mode 100644 --- /dev/null +++ b/compiler/main/PackageConfig.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE CPP, RecordWildCards, FlexibleInstances, MultiParamTypeClasses #-} + +-- | +-- Package configuration information: essentially the interface to Cabal, with +-- some utilities +-- +-- (c) The University of Glasgow, 2004 +-- +module PackageConfig ( + -- $package_naming + + -- * UnitId + packageConfigId, + expandedPackageConfigId, + definitePackageConfigId, + installedPackageConfigId, + + -- * The PackageConfig type: information about a package + PackageConfig, + InstalledPackageInfo(..), + ComponentId(..), + SourcePackageId(..), + PackageName(..), + Version(..), + defaultPackageConfig, + sourcePackageIdString, + packageNameString, + pprPackageConfig, + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.PackageDb +import Data.Version + +import FastString +import Outputable +import Module +import Unique + +-- ----------------------------------------------------------------------------- +-- Our PackageConfig type is the InstalledPackageInfo from ghc-boot, +-- which is similar to a subset of the InstalledPackageInfo type from Cabal. + +type PackageConfig = InstalledPackageInfo + ComponentId + SourcePackageId + PackageName + Module.InstalledUnitId + Module.UnitId + Module.ModuleName + Module.Module + +-- TODO: there's no need for these to be FastString, as we don't need the uniq +-- feature, but ghc doesn't currently have convenient support for any +-- other compact string types, e.g. plain ByteString or Text. + +newtype SourcePackageId = SourcePackageId FastString deriving (Eq, Ord) +newtype PackageName = PackageName FastString deriving (Eq, Ord) + +instance BinaryStringRep SourcePackageId where + fromStringRep = SourcePackageId . mkFastStringByteString + toStringRep (SourcePackageId s) = bytesFS s + +instance BinaryStringRep PackageName where + fromStringRep = PackageName . mkFastStringByteString + toStringRep (PackageName s) = bytesFS s + +instance Uniquable SourcePackageId where + getUnique (SourcePackageId n) = getUnique n + +instance Uniquable PackageName where + getUnique (PackageName n) = getUnique n + +instance Outputable SourcePackageId where + ppr (SourcePackageId str) = ftext str + +instance Outputable PackageName where + ppr (PackageName str) = ftext str + +defaultPackageConfig :: PackageConfig +defaultPackageConfig = emptyInstalledPackageInfo + +sourcePackageIdString :: PackageConfig -> String +sourcePackageIdString pkg = unpackFS str + where + SourcePackageId str = sourcePackageId pkg + +packageNameString :: PackageConfig -> String +packageNameString pkg = unpackFS str + where + PackageName str = packageName pkg + +pprPackageConfig :: PackageConfig -> SDoc +pprPackageConfig InstalledPackageInfo {..} = + vcat [ + field "name" (ppr packageName), + field "version" (text (showVersion packageVersion)), + field "id" (ppr unitId), + field "exposed" (ppr exposed), + field "exposed-modules" (ppr exposedModules), + field "hidden-modules" (fsep (map ppr hiddenModules)), + field "trusted" (ppr trusted), + field "import-dirs" (fsep (map text importDirs)), + field "library-dirs" (fsep (map text libraryDirs)), + field "dynamic-library-dirs" (fsep (map text libraryDynDirs)), + field "hs-libraries" (fsep (map text hsLibraries)), + field "extra-libraries" (fsep (map text extraLibraries)), + field "extra-ghci-libraries" (fsep (map text extraGHCiLibraries)), + field "include-dirs" (fsep (map text includeDirs)), + field "includes" (fsep (map text includes)), + field "depends" (fsep (map ppr depends)), + field "cc-options" (fsep (map text ccOptions)), + field "ld-options" (fsep (map text ldOptions)), + field "framework-dirs" (fsep (map text frameworkDirs)), + field "frameworks" (fsep (map text frameworks)), + field "haddock-interfaces" (fsep (map text haddockInterfaces)), + field "haddock-html" (fsep (map text haddockHTMLs)) + ] + where + field name body = text name <> colon <+> nest 4 body + +-- ----------------------------------------------------------------------------- +-- UnitId (package names, versions and dep hash) + +-- $package_naming +-- #package_naming# +-- Mostly the compiler deals in terms of 'UnitId's, which are md5 hashes +-- of a package ID, keys of its dependencies, and Cabal flags. You're expected +-- to pass in the unit id in the @-this-unit-id@ flag. However, for +-- wired-in packages like @base@ & @rts@, we don't necessarily know what the +-- version is, so these are handled specially; see #wired_in_packages#. + +-- | Get the GHC 'UnitId' right out of a Cabalish 'PackageConfig' +installedPackageConfigId :: PackageConfig -> InstalledUnitId +installedPackageConfigId = unitId + +packageConfigId :: PackageConfig -> UnitId +packageConfigId p = + if indefinite p + then newUnitId (componentId p) (instantiatedWith p) + else DefiniteUnitId (DefUnitId (unitId p)) + +expandedPackageConfigId :: PackageConfig -> UnitId +expandedPackageConfigId p = + newUnitId (componentId p) (instantiatedWith p) + +definitePackageConfigId :: PackageConfig -> Maybe DefUnitId +definitePackageConfigId p = + case packageConfigId p of + DefiniteUnitId def_uid -> Just def_uid + _ -> Nothing diff --git a/compiler/main/PackageConfig.hs-boot b/compiler/main/PackageConfig.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/main/PackageConfig.hs-boot @@ -0,0 +1,7 @@ +module PackageConfig where +import FastString +import {-# SOURCE #-} Module +import GHC.PackageDb +newtype PackageName = PackageName FastString +newtype SourcePackageId = SourcePackageId FastString +type PackageConfig = InstalledPackageInfo ComponentId SourcePackageId PackageName UnitId ModuleName Module diff --git a/compiler/main/Packages.hs b/compiler/main/Packages.hs new file mode 100644 --- /dev/null +++ b/compiler/main/Packages.hs @@ -0,0 +1,2193 @@ +-- (c) The University of Glasgow, 2006 + +{-# LANGUAGE CPP, ScopedTypeVariables, BangPatterns, FlexibleContexts #-} + +-- | Package manipulation +module Packages ( + module PackageConfig, + + -- * Reading the package config, and processing cmdline args + PackageState(preloadPackages, explicitPackages, moduleToPkgConfAll, requirementContext), + PackageConfigMap, + emptyPackageState, + initPackages, + readPackageConfigs, + getPackageConfRefs, + resolvePackageConfig, + readPackageConfig, + listPackageConfigMap, + + -- * Querying the package config + lookupPackage, + lookupPackage', + lookupInstalledPackage, + lookupPackageName, + improveUnitId, + searchPackageId, + getPackageDetails, + getInstalledPackageDetails, + componentIdString, + displayInstalledUnitId, + listVisibleModuleNames, + lookupModuleInAllPackages, + lookupModuleWithSuggestions, + lookupPluginModuleWithSuggestions, + LookupResult(..), + ModuleSuggestion(..), + ModuleOrigin(..), + UnusablePackageReason(..), + pprReason, + + -- * Inspecting the set of packages in scope + getPackageIncludePath, + getPackageLibraryPath, + getPackageLinkOpts, + getPackageExtraCcOpts, + getPackageFrameworkPath, + getPackageFrameworks, + getPackageConfigMap, + getPreloadPackagesAnd, + + collectArchives, + collectIncludeDirs, collectLibraryPaths, collectLinkOpts, + packageHsLibs, getLibs, + + -- * Utils + unwireUnitId, + pprFlag, + pprPackages, + pprPackagesSimple, + pprModuleMap, + isIndefinite, + isDllName + ) +where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.PackageDb +import PackageConfig +import DynFlags +import Name ( Name, nameModule_maybe ) +import UniqFM +import UniqDFM +import UniqSet +import Module +import Util +import Panic +import Platform +import Outputable +import Maybes + +import System.Environment ( getEnv ) +import FastString +import ErrUtils ( debugTraceMsg, MsgDoc, dumpIfSet_dyn ) +import Exception + +import System.Directory +import System.FilePath as FilePath +import qualified System.FilePath.Posix as FilePath.Posix +import Control.Monad +import Data.Graph (stronglyConnComp, SCC(..)) +import Data.Char ( toUpper ) +import Data.List as List +import Data.Map (Map) +import Data.Set (Set) +import Data.Monoid (First(..)) +import qualified Data.Semigroup as Semigroup +import qualified Data.Map as Map +import qualified Data.Map.Strict as MapStrict +import qualified Data.Set as Set +import Data.Version + +-- --------------------------------------------------------------------------- +-- The Package state + +-- | Package state is all stored in 'DynFlags', including the details of +-- all packages, which packages are exposed, and which modules they +-- provide. +-- +-- The package state is computed by 'initPackages', and kept in DynFlags. +-- It is influenced by various package flags: +-- +-- * @-package @ and @-package-id @ cause @@ to become exposed. +-- If @-hide-all-packages@ was not specified, these commands also cause +-- all other packages with the same name to become hidden. +-- +-- * @-hide-package @ causes @@ to become hidden. +-- +-- * (there are a few more flags, check below for their semantics) +-- +-- The package state has the following properties. +-- +-- * Let @exposedPackages@ be the set of packages thus exposed. +-- Let @depExposedPackages@ be the transitive closure from @exposedPackages@ of +-- their dependencies. +-- +-- * When searching for a module from a preload import declaration, +-- only the exposed modules in @exposedPackages@ are valid. +-- +-- * When searching for a module from an implicit import, all modules +-- from @depExposedPackages@ are valid. +-- +-- * When linking in a compilation manager mode, we link in packages the +-- program depends on (the compiler knows this list by the +-- time it gets to the link step). Also, we link in all packages +-- which were mentioned with preload @-package@ flags on the command-line, +-- or are a transitive dependency of same, or are \"base\"\/\"rts\". +-- The reason for this is that we might need packages which don't +-- contain any Haskell modules, and therefore won't be discovered +-- by the normal mechanism of dependency tracking. + +-- Notes on DLLs +-- ~~~~~~~~~~~~~ +-- When compiling module A, which imports module B, we need to +-- know whether B will be in the same DLL as A. +-- If it's in the same DLL, we refer to B_f_closure +-- If it isn't, we refer to _imp__B_f_closure +-- When compiling A, we record in B's Module value whether it's +-- in a different DLL, by setting the DLL flag. + +-- | Given a module name, there may be multiple ways it came into scope, +-- possibly simultaneously. This data type tracks all the possible ways +-- it could have come into scope. Warning: don't use the record functions, +-- they're partial! +data ModuleOrigin = + -- | Module is hidden, and thus never will be available for import. + -- (But maybe the user didn't realize), so we'll still keep track + -- of these modules.) + ModHidden + -- | Module is unavailable because the package is unusable. + | ModUnusable UnusablePackageReason + -- | Module is public, and could have come from some places. + | ModOrigin { + -- | @Just False@ means that this module is in + -- someone's @exported-modules@ list, but that package is hidden; + -- @Just True@ means that it is available; @Nothing@ means neither + -- applies. + fromOrigPackage :: Maybe Bool + -- | Is the module available from a reexport of an exposed package? + -- There could be multiple. + , fromExposedReexport :: [PackageConfig] + -- | Is the module available from a reexport of a hidden package? + , fromHiddenReexport :: [PackageConfig] + -- | Did the module export come from a package flag? (ToDo: track + -- more information. + , fromPackageFlag :: Bool + } + +instance Outputable ModuleOrigin where + ppr ModHidden = text "hidden module" + ppr (ModUnusable _) = text "unusable module" + ppr (ModOrigin e res rhs f) = sep (punctuate comma ( + (case e of + Nothing -> [] + Just False -> [text "hidden package"] + Just True -> [text "exposed package"]) ++ + (if null res + then [] + else [text "reexport by" <+> + sep (map (ppr . packageConfigId) res)]) ++ + (if null rhs + then [] + else [text "hidden reexport by" <+> + sep (map (ppr . packageConfigId) res)]) ++ + (if f then [text "package flag"] else []) + )) + +-- | Smart constructor for a module which is in @exposed-modules@. Takes +-- as an argument whether or not the defining package is exposed. +fromExposedModules :: Bool -> ModuleOrigin +fromExposedModules e = ModOrigin (Just e) [] [] False + +-- | Smart constructor for a module which is in @reexported-modules@. Takes +-- as an argument whether or not the reexporting package is expsed, and +-- also its 'PackageConfig'. +fromReexportedModules :: Bool -> PackageConfig -> ModuleOrigin +fromReexportedModules True pkg = ModOrigin Nothing [pkg] [] False +fromReexportedModules False pkg = ModOrigin Nothing [] [pkg] False + +-- | Smart constructor for a module which was bound by a package flag. +fromFlag :: ModuleOrigin +fromFlag = ModOrigin Nothing [] [] True + +instance Semigroup ModuleOrigin where + ModOrigin e res rhs f <> ModOrigin e' res' rhs' f' = + ModOrigin (g e e') (res ++ res') (rhs ++ rhs') (f || f') + where g (Just b) (Just b') + | b == b' = Just b + | otherwise = panic "ModOrigin: package both exposed/hidden" + g Nothing x = x + g x Nothing = x + _x <> _y = panic "ModOrigin: hidden module redefined" + +instance Monoid ModuleOrigin where + mempty = ModOrigin Nothing [] [] False + mappend = (Semigroup.<>) + +-- | Is the name from the import actually visible? (i.e. does it cause +-- ambiguity, or is it only relevant when we're making suggestions?) +originVisible :: ModuleOrigin -> Bool +originVisible ModHidden = False +originVisible (ModUnusable _) = False +originVisible (ModOrigin b res _ f) = b == Just True || not (null res) || f + +-- | Are there actually no providers for this module? This will never occur +-- except when we're filtering based on package imports. +originEmpty :: ModuleOrigin -> Bool +originEmpty (ModOrigin Nothing [] [] False) = True +originEmpty _ = False + +-- | 'UniqFM' map from 'InstalledUnitId' +type InstalledUnitIdMap = UniqDFM + +-- | 'UniqFM' map from 'UnitId' to 'PackageConfig', plus +-- the transitive closure of preload packages. +data PackageConfigMap = PackageConfigMap { + unPackageConfigMap :: InstalledUnitIdMap PackageConfig, + -- | The set of transitively reachable packages according + -- to the explicitly provided command line arguments. + -- See Note [UnitId to InstalledUnitId improvement] + preloadClosure :: UniqSet InstalledUnitId + } + +-- | 'UniqFM' map from 'UnitId' to a 'UnitVisibility'. +type VisibilityMap = Map UnitId UnitVisibility + +-- | 'UnitVisibility' records the various aspects of visibility of a particular +-- 'UnitId'. +data UnitVisibility = UnitVisibility + { uv_expose_all :: Bool + -- ^ Should all modules in exposed-modules should be dumped into scope? + , uv_renamings :: [(ModuleName, ModuleName)] + -- ^ Any custom renamings that should bring extra 'ModuleName's into + -- scope. + , uv_package_name :: First FastString + -- ^ The package name is associated with the 'UnitId'. This is used + -- to implement legacy behavior where @-package foo-0.1@ implicitly + -- hides any packages named @foo@ + , uv_requirements :: Map ModuleName (Set IndefModule) + -- ^ The signatures which are contributed to the requirements context + -- from this unit ID. + , uv_explicit :: Bool + -- ^ Whether or not this unit was explicitly brought into scope, + -- as opposed to implicitly via the 'exposed' fields in the + -- package database (when @-hide-all-packages@ is not passed.) + } + +instance Outputable UnitVisibility where + ppr (UnitVisibility { + uv_expose_all = b, + uv_renamings = rns, + uv_package_name = First mb_pn, + uv_requirements = reqs, + uv_explicit = explicit + }) = ppr (b, rns, mb_pn, reqs, explicit) + +instance Semigroup UnitVisibility where + uv1 <> uv2 + = UnitVisibility + { uv_expose_all = uv_expose_all uv1 || uv_expose_all uv2 + , uv_renamings = uv_renamings uv1 ++ uv_renamings uv2 + , uv_package_name = mappend (uv_package_name uv1) (uv_package_name uv2) + , uv_requirements = Map.unionWith Set.union (uv_requirements uv1) (uv_requirements uv2) + , uv_explicit = uv_explicit uv1 || uv_explicit uv2 + } + +instance Monoid UnitVisibility where + mempty = UnitVisibility + { uv_expose_all = False + , uv_renamings = [] + , uv_package_name = First Nothing + , uv_requirements = Map.empty + , uv_explicit = False + } + mappend = (Semigroup.<>) + +type WiredUnitId = DefUnitId +type PreloadUnitId = InstalledUnitId + +-- | Map from 'ModuleName' to 'Module' to all the origins of the bindings +-- in scope. The 'PackageConf' is not cached, mostly for convenience reasons +-- (since this is the slow path, we'll just look it up again). +type ModuleToPkgConfAll = + Map ModuleName (Map Module ModuleOrigin) + +data PackageState = PackageState { + -- | A mapping of 'UnitId' to 'PackageConfig'. This list is adjusted + -- so that only valid packages are here. 'PackageConfig' reflects + -- what was stored *on disk*, except for the 'trusted' flag, which + -- is adjusted at runtime. (In particular, some packages in this map + -- may have the 'exposed' flag be 'False'.) + pkgIdMap :: PackageConfigMap, + + -- | A mapping of 'PackageName' to 'ComponentId'. This is used when + -- users refer to packages in Backpack includes. + packageNameMap :: Map PackageName ComponentId, + + -- | A mapping from wired in names to the original names from the + -- package database. + unwireMap :: Map WiredUnitId WiredUnitId, + + -- | The packages we're going to link in eagerly. This list + -- should be in reverse dependency order; that is, a package + -- is always mentioned before the packages it depends on. + preloadPackages :: [PreloadUnitId], + + -- | Packages which we explicitly depend on (from a command line flag). + -- We'll use this to generate version macros. + explicitPackages :: [UnitId], + + -- | This is a full map from 'ModuleName' to all modules which may possibly + -- be providing it. These providers may be hidden (but we'll still want + -- to report them in error messages), or it may be an ambiguous import. + moduleToPkgConfAll :: !ModuleToPkgConfAll, + + -- | A map, like 'moduleToPkgConfAll', but controlling plugin visibility. + pluginModuleToPkgConfAll :: !ModuleToPkgConfAll, + + -- | A map saying, for each requirement, what interfaces must be merged + -- together when we use them. For example, if our dependencies + -- are @p[A=]@ and @q[A=,B=r[C=]:B]@, then the interfaces + -- to merge for A are @p[A=]:A@, @q[A=,B=r[C=]:B]:A@ + -- and @r[C=]:C@. + -- + -- There's an entry in this map for each hole in our home library. + requirementContext :: Map ModuleName [IndefModule] + } + +emptyPackageState :: PackageState +emptyPackageState = PackageState { + pkgIdMap = emptyPackageConfigMap, + packageNameMap = Map.empty, + unwireMap = Map.empty, + preloadPackages = [], + explicitPackages = [], + moduleToPkgConfAll = Map.empty, + pluginModuleToPkgConfAll = Map.empty, + requirementContext = Map.empty + } + +type InstalledPackageIndex = Map InstalledUnitId PackageConfig + +-- | Empty package configuration map +emptyPackageConfigMap :: PackageConfigMap +emptyPackageConfigMap = PackageConfigMap emptyUDFM emptyUniqSet + +-- | Find the package we know about with the given unit id, if any +lookupPackage :: DynFlags -> UnitId -> Maybe PackageConfig +lookupPackage dflags = lookupPackage' (isIndefinite dflags) (pkgIdMap (pkgState dflags)) + +-- | A more specialized interface, which takes a boolean specifying +-- whether or not to look for on-the-fly renamed interfaces, and +-- just a 'PackageConfigMap' rather than a 'DynFlags' (so it can +-- be used while we're initializing 'DynFlags' +lookupPackage' :: Bool -> PackageConfigMap -> UnitId -> Maybe PackageConfig +lookupPackage' False (PackageConfigMap pkg_map _) uid = lookupUDFM pkg_map uid +lookupPackage' True m@(PackageConfigMap pkg_map _) uid = + case splitUnitIdInsts uid of + (iuid, Just indef) -> + fmap (renamePackage m (indefUnitIdInsts indef)) + (lookupUDFM pkg_map iuid) + (_, Nothing) -> lookupUDFM pkg_map uid + +{- +-- | Find the indefinite package for a given 'ComponentId'. +-- The way this works is just by fiat'ing that every indefinite package's +-- unit key is precisely its component ID; and that they share uniques. +lookupComponentId :: DynFlags -> ComponentId -> Maybe PackageConfig +lookupComponentId dflags (ComponentId cid_fs) = lookupUDFM pkg_map cid_fs + where + PackageConfigMap pkg_map = pkgIdMap (pkgState dflags) +-} + +-- | Find the package we know about with the given package name (e.g. @foo@), if any +-- (NB: there might be a locally defined unit name which overrides this) +lookupPackageName :: DynFlags -> PackageName -> Maybe ComponentId +lookupPackageName dflags n = Map.lookup n (packageNameMap (pkgState dflags)) + +-- | Search for packages with a given package ID (e.g. \"foo-0.1\") +searchPackageId :: DynFlags -> SourcePackageId -> [PackageConfig] +searchPackageId dflags pid = filter ((pid ==) . sourcePackageId) + (listPackageConfigMap dflags) + +-- | Extends the package configuration map with a list of package configs. +extendPackageConfigMap + :: PackageConfigMap -> [PackageConfig] -> PackageConfigMap +extendPackageConfigMap (PackageConfigMap pkg_map closure) new_pkgs + = PackageConfigMap (foldl' add pkg_map new_pkgs) closure + -- We also add the expanded version of the packageConfigId, so that + -- 'improveUnitId' can find it. + where add pkg_map p = addToUDFM (addToUDFM pkg_map (expandedPackageConfigId p) p) + (installedPackageConfigId p) p + +-- | Looks up the package with the given id in the package state, panicing if it is +-- not found +getPackageDetails :: DynFlags -> UnitId -> PackageConfig +getPackageDetails dflags pid = + expectJust "getPackageDetails" (lookupPackage dflags pid) + +lookupInstalledPackage :: DynFlags -> InstalledUnitId -> Maybe PackageConfig +lookupInstalledPackage dflags uid = lookupInstalledPackage' (pkgIdMap (pkgState dflags)) uid + +lookupInstalledPackage' :: PackageConfigMap -> InstalledUnitId -> Maybe PackageConfig +lookupInstalledPackage' (PackageConfigMap db _) uid = lookupUDFM db uid + +getInstalledPackageDetails :: DynFlags -> InstalledUnitId -> PackageConfig +getInstalledPackageDetails dflags uid = + expectJust "getInstalledPackageDetails" $ + lookupInstalledPackage dflags uid + +-- | Get a list of entries from the package database. NB: be careful with +-- this function, although all packages in this map are "visible", this +-- does not imply that the exposed-modules of the package are available +-- (they may have been thinned or renamed). +listPackageConfigMap :: DynFlags -> [PackageConfig] +listPackageConfigMap dflags = eltsUDFM pkg_map + where + PackageConfigMap pkg_map _ = pkgIdMap (pkgState dflags) + +-- ---------------------------------------------------------------------------- +-- Loading the package db files and building up the package state + +-- | Call this after 'DynFlags.parseDynFlags'. It reads the package +-- database files, and sets up various internal tables of package +-- information, according to the package-related flags on the +-- command-line (@-package@, @-hide-package@ etc.) +-- +-- Returns a list of packages to link in if we're doing dynamic linking. +-- This list contains the packages that the user explicitly mentioned with +-- @-package@ flags. +-- +-- 'initPackages' can be called again subsequently after updating the +-- 'packageFlags' field of the 'DynFlags', and it will update the +-- 'pkgState' in 'DynFlags' and return a list of packages to +-- link in. +initPackages :: DynFlags -> IO (DynFlags, [PreloadUnitId]) +initPackages dflags0 = do + dflags <- interpretPackageEnv dflags0 + pkg_db <- + case pkgDatabase dflags of + Nothing -> readPackageConfigs dflags + Just db -> return $ map (\(p, pkgs) + -> (p, setBatchPackageFlags dflags pkgs)) db + (pkg_state, preload, insts) + <- mkPackageState dflags pkg_db [] + return (dflags{ pkgDatabase = Just pkg_db, + pkgState = pkg_state, + thisUnitIdInsts_ = insts }, + preload) + +-- ----------------------------------------------------------------------------- +-- Reading the package database(s) + +readPackageConfigs :: DynFlags -> IO [(FilePath, [PackageConfig])] +readPackageConfigs dflags = do + conf_refs <- getPackageConfRefs dflags + confs <- liftM catMaybes $ mapM (resolvePackageConfig dflags) conf_refs + mapM (readPackageConfig dflags) confs + + +getPackageConfRefs :: DynFlags -> IO [PkgConfRef] +getPackageConfRefs dflags = do + let system_conf_refs = [UserPkgConf, GlobalPkgConf] + + e_pkg_path <- tryIO (getEnv $ map toUpper (programName dflags) ++ "_PACKAGE_PATH") + let base_conf_refs = case e_pkg_path of + Left _ -> system_conf_refs + Right path + | not (null path) && isSearchPathSeparator (last path) + -> map PkgConfFile (splitSearchPath (init path)) ++ system_conf_refs + | otherwise + -> map PkgConfFile (splitSearchPath path) + + -- Apply the package DB-related flags from the command line to get the + -- final list of package DBs. + -- + -- Notes on ordering: + -- * The list of flags is reversed (later ones first) + -- * We work with the package DB list in "left shadows right" order + -- * and finally reverse it at the end, to get "right shadows left" + -- + return $ reverse (foldr doFlag base_conf_refs (packageDBFlags dflags)) + where + doFlag (PackageDB p) dbs = p : dbs + doFlag NoUserPackageDB dbs = filter isNotUser dbs + doFlag NoGlobalPackageDB dbs = filter isNotGlobal dbs + doFlag ClearPackageDBs _ = [] + + isNotUser UserPkgConf = False + isNotUser _ = True + + isNotGlobal GlobalPkgConf = False + isNotGlobal _ = True + +resolvePackageConfig :: DynFlags -> PkgConfRef -> IO (Maybe FilePath) +resolvePackageConfig dflags GlobalPkgConf = return $ Just (systemPackageConfig dflags) +-- NB: This logic is reimplemented in Cabal, so if you change it, +-- make sure you update Cabal. (Or, better yet, dump it in the +-- compiler info so Cabal can use the info.) +resolvePackageConfig dflags UserPkgConf = runMaybeT $ do + dir <- versionedAppDir dflags + let pkgconf = dir "package.conf.d" + exist <- tryMaybeT $ doesDirectoryExist pkgconf + if exist then return pkgconf else mzero +resolvePackageConfig _ (PkgConfFile name) = return $ Just name + +readPackageConfig :: DynFlags -> FilePath -> IO (FilePath, [PackageConfig]) +readPackageConfig dflags conf_file = do + isdir <- doesDirectoryExist conf_file + + proto_pkg_configs <- + if isdir + then readDirStylePackageConfig conf_file + else do + isfile <- doesFileExist conf_file + if isfile + then do + mpkgs <- tryReadOldFileStylePackageConfig + case mpkgs of + Just pkgs -> return pkgs + Nothing -> throwGhcExceptionIO $ InstallationError $ + "ghc no longer supports single-file style package " ++ + "databases (" ++ conf_file ++ + ") use 'ghc-pkg init' to create the database with " ++ + "the correct format." + else throwGhcExceptionIO $ InstallationError $ + "can't find a package database at " ++ conf_file + + let + top_dir = topDir dflags + pkgroot = takeDirectory conf_file + pkg_configs1 = map (mungePackageConfig top_dir pkgroot) + proto_pkg_configs + pkg_configs2 = setBatchPackageFlags dflags pkg_configs1 + -- + return (conf_file, pkg_configs2) + where + readDirStylePackageConfig conf_dir = do + let filename = conf_dir "package.cache" + cache_exists <- doesFileExist filename + if cache_exists + then do + debugTraceMsg dflags 2 $ text "Using binary package database:" + <+> text filename + readPackageDbForGhc filename + else do + -- If there is no package.cache file, we check if the database is not + -- empty by inspecting if the directory contains any .conf file. If it + -- does, something is wrong and we fail. Otherwise we assume that the + -- database is empty. + debugTraceMsg dflags 2 $ text "There is no package.cache in" + <+> text conf_dir + <> text ", checking if the database is empty" + db_empty <- all (not . isSuffixOf ".conf") + <$> getDirectoryContents conf_dir + if db_empty + then do + debugTraceMsg dflags 3 $ text "There are no .conf files in" + <+> text conf_dir <> text ", treating" + <+> text "package database as empty" + return [] + else do + throwGhcExceptionIO $ InstallationError $ + "there is no package.cache in " ++ conf_dir ++ + " even though package database is not empty" + + + -- Single-file style package dbs have been deprecated for some time, but + -- it turns out that Cabal was using them in one place. So this is a + -- workaround to allow older Cabal versions to use this newer ghc. + -- We check if the file db contains just "[]" and if so, we look for a new + -- dir-style db in conf_file.d/, ie in a dir next to the given file. + -- We cannot just replace the file with a new dir style since Cabal still + -- assumes it's a file and tries to overwrite with 'writeFile'. + -- ghc-pkg also cooperates with this workaround. + tryReadOldFileStylePackageConfig = do + content <- readFile conf_file `catchIO` \_ -> return "" + if take 2 content == "[]" + then do + let conf_dir = conf_file <.> "d" + direxists <- doesDirectoryExist conf_dir + if direxists + then do debugTraceMsg dflags 2 (text "Ignoring old file-style db and trying:" <+> text conf_dir) + liftM Just (readDirStylePackageConfig conf_dir) + else return (Just []) -- ghc-pkg will create it when it's updated + else return Nothing + +setBatchPackageFlags :: DynFlags -> [PackageConfig] -> [PackageConfig] +setBatchPackageFlags dflags pkgs = maybeDistrustAll pkgs + where + maybeDistrustAll pkgs' + | gopt Opt_DistrustAllPackages dflags = map distrust pkgs' + | otherwise = pkgs' + + distrust pkg = pkg{ trusted = False } + +mungePackageConfig :: FilePath -> FilePath + -> PackageConfig -> PackageConfig +mungePackageConfig top_dir pkgroot = + mungeDynLibFields + . mungePackagePaths top_dir pkgroot + +mungeDynLibFields :: PackageConfig -> PackageConfig +mungeDynLibFields pkg = + pkg { + libraryDynDirs = libraryDynDirs pkg + `orIfNull` libraryDirs pkg + } + where + orIfNull [] flags = flags + orIfNull flags _ = flags + +-- TODO: This code is duplicated in utils/ghc-pkg/Main.hs +mungePackagePaths :: FilePath -> FilePath -> PackageConfig -> PackageConfig +-- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec +-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html) +-- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}. +-- The "pkgroot" is the directory containing the package database. +-- +-- Also perform a similar substitution for the older GHC-specific +-- "$topdir" variable. The "topdir" is the location of the ghc +-- installation (obtained from the -B option). +mungePackagePaths top_dir pkgroot pkg = + pkg { + importDirs = munge_paths (importDirs pkg), + includeDirs = munge_paths (includeDirs pkg), + libraryDirs = munge_paths (libraryDirs pkg), + libraryDynDirs = munge_paths (libraryDynDirs pkg), + frameworkDirs = munge_paths (frameworkDirs pkg), + haddockInterfaces = munge_paths (haddockInterfaces pkg), + haddockHTMLs = munge_urls (haddockHTMLs pkg) + } + where + munge_paths = map munge_path + munge_urls = map munge_url + + munge_path p + | Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p' + | Just p' <- stripVarPrefix "$topdir" p = top_dir ++ p' + | otherwise = p + + munge_url p + | Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p' + | Just p' <- stripVarPrefix "$httptopdir" p = toUrlPath top_dir p' + | otherwise = p + + toUrlPath r p = "file:///" + -- URLs always use posix style '/' separators: + ++ FilePath.Posix.joinPath + (r : -- We need to drop a leading "/" or "\\" + -- if there is one: + dropWhile (all isPathSeparator) + (FilePath.splitDirectories p)) + + -- We could drop the separator here, and then use above. However, + -- by leaving it in and using ++ we keep the same path separator + -- rather than letting FilePath change it to use \ as the separator + stripVarPrefix var path = case stripPrefix var path of + Just [] -> Just [] + Just cs@(c : _) | isPathSeparator c -> Just cs + _ -> Nothing + + +-- ----------------------------------------------------------------------------- +-- Modify our copy of the package database based on trust flags, +-- -trust and -distrust. + +applyTrustFlag + :: DynFlags + -> PackagePrecedenceIndex + -> UnusablePackages + -> [PackageConfig] + -> TrustFlag + -> IO [PackageConfig] +applyTrustFlag dflags prec_map unusable pkgs flag = + case flag of + -- we trust all matching packages. Maybe should only trust first one? + -- and leave others the same or set them untrusted + TrustPackage str -> + case selectPackages prec_map (PackageArg str) pkgs unusable of + Left ps -> trustFlagErr dflags flag ps + Right (ps,qs) -> return (map trust ps ++ qs) + where trust p = p {trusted=True} + + DistrustPackage str -> + case selectPackages prec_map (PackageArg str) pkgs unusable of + Left ps -> trustFlagErr dflags flag ps + Right (ps,qs) -> return (map distrust ps ++ qs) + where distrust p = p {trusted=False} + +-- | A little utility to tell if the 'thisPackage' is indefinite +-- (if it is not, we should never use on-the-fly renaming.) +isIndefinite :: DynFlags -> Bool +isIndefinite dflags = not (unitIdIsDefinite (thisPackage dflags)) + +applyPackageFlag + :: DynFlags + -> PackagePrecedenceIndex + -> PackageConfigMap + -> UnusablePackages + -> Bool -- if False, if you expose a package, it implicitly hides + -- any previously exposed packages with the same name + -> [PackageConfig] + -> VisibilityMap -- Initially exposed + -> PackageFlag -- flag to apply + -> IO VisibilityMap -- Now exposed + +applyPackageFlag dflags prec_map pkg_db unusable no_hide_others pkgs vm flag = + case flag of + ExposePackage _ arg (ModRenaming b rns) -> + case findPackages prec_map pkg_db arg pkgs unusable of + Left ps -> packageFlagErr dflags flag ps + Right (p:_) -> return vm' + where + n = fsPackageName p + + -- If a user says @-unit-id p[A=]@, this imposes + -- a requirement on us: whatever our signature A is, + -- it must fulfill all of p[A=]:A's requirements. + -- This method is responsible for computing what our + -- inherited requirements are. + reqs | UnitIdArg orig_uid <- arg = collectHoles orig_uid + | otherwise = Map.empty + + collectHoles uid = case splitUnitIdInsts uid of + (_, Just indef) -> + let local = [ Map.singleton + (moduleName mod) + (Set.singleton $ IndefModule indef mod_name) + | (mod_name, mod) <- indefUnitIdInsts indef + , isHoleModule mod ] + recurse = [ collectHoles (moduleUnitId mod) + | (_, mod) <- indefUnitIdInsts indef ] + in Map.unionsWith Set.union $ local ++ recurse + -- Other types of unit identities don't have holes + (_, Nothing) -> Map.empty + + + uv = UnitVisibility + { uv_expose_all = b + , uv_renamings = rns + , uv_package_name = First (Just n) + , uv_requirements = reqs + , uv_explicit = True + } + vm' = Map.insertWith mappend (packageConfigId p) uv vm_cleared + -- In the old days, if you said `ghc -package p-0.1 -package p-0.2` + -- (or if p-0.1 was registered in the pkgdb as exposed: True), + -- the second package flag would override the first one and you + -- would only see p-0.2 in exposed modules. This is good for + -- usability. + -- + -- However, with thinning and renaming (or Backpack), there might be + -- situations where you legitimately want to see two versions of a + -- package at the same time, and this behavior would make it + -- impossible to do so. So we decided that if you pass + -- -hide-all-packages, this should turn OFF the overriding behavior + -- where an exposed package hides all other packages with the same + -- name. This should not affect Cabal at all, which only ever + -- exposes one package at a time. + -- + -- NB: Why a variable no_hide_others? We have to apply this logic to + -- -plugin-package too, and it's more consistent if the switch in + -- behavior is based off of + -- -hide-all-packages/-hide-all-plugin-packages depending on what + -- flag is in question. + vm_cleared | no_hide_others = vm + -- NB: renamings never clear + | (_:_) <- rns = vm + | otherwise = Map.filterWithKey + (\k uv -> k == packageConfigId p + || First (Just n) /= uv_package_name uv) vm + _ -> panic "applyPackageFlag" + + HidePackage str -> + case findPackages prec_map pkg_db (PackageArg str) pkgs unusable of + Left ps -> packageFlagErr dflags flag ps + Right ps -> return vm' + where vm' = foldl' (flip Map.delete) vm (map packageConfigId ps) + +-- | Like 'selectPackages', but doesn't return a list of unmatched +-- packages. Furthermore, any packages it returns are *renamed* +-- if the 'UnitArg' has a renaming associated with it. +findPackages :: PackagePrecedenceIndex + -> PackageConfigMap -> PackageArg -> [PackageConfig] + -> UnusablePackages + -> Either [(PackageConfig, UnusablePackageReason)] + [PackageConfig] +findPackages prec_map pkg_db arg pkgs unusable + = let ps = mapMaybe (finder arg) pkgs + in if null ps + then Left (mapMaybe (\(x,y) -> finder arg x >>= \x' -> return (x',y)) + (Map.elems unusable)) + else Right (sortByPreference prec_map ps) + where + finder (PackageArg str) p + = if str == sourcePackageIdString p || str == packageNameString p + then Just p + else Nothing + finder (UnitIdArg uid) p + = let (iuid, mb_indef) = splitUnitIdInsts uid + in if iuid == installedPackageConfigId p + then Just (case mb_indef of + Nothing -> p + Just indef -> renamePackage pkg_db (indefUnitIdInsts indef) p) + else Nothing + +selectPackages :: PackagePrecedenceIndex -> PackageArg -> [PackageConfig] + -> UnusablePackages + -> Either [(PackageConfig, UnusablePackageReason)] + ([PackageConfig], [PackageConfig]) +selectPackages prec_map arg pkgs unusable + = let matches = matching arg + (ps,rest) = partition matches pkgs + in if null ps + then Left (filter (matches.fst) (Map.elems unusable)) + else Right (sortByPreference prec_map ps, rest) + +-- | Rename a 'PackageConfig' according to some module instantiation. +renamePackage :: PackageConfigMap -> [(ModuleName, Module)] + -> PackageConfig -> PackageConfig +renamePackage pkg_map insts conf = + let hsubst = listToUFM insts + smod = renameHoleModule' pkg_map hsubst + new_insts = map (\(k,v) -> (k,smod v)) (instantiatedWith conf) + in conf { + instantiatedWith = new_insts, + exposedModules = map (\(mod_name, mb_mod) -> (mod_name, fmap smod mb_mod)) + (exposedModules conf) + } + + +-- A package named on the command line can either include the +-- version, or just the name if it is unambiguous. +matchingStr :: String -> PackageConfig -> Bool +matchingStr str p + = str == sourcePackageIdString p + || str == packageNameString p + +matchingId :: InstalledUnitId -> PackageConfig -> Bool +matchingId uid p = uid == installedPackageConfigId p + +matching :: PackageArg -> PackageConfig -> Bool +matching (PackageArg str) = matchingStr str +matching (UnitIdArg (DefiniteUnitId (DefUnitId uid))) = matchingId uid +matching (UnitIdArg _) = \_ -> False -- TODO: warn in this case + +-- | This sorts a list of packages, putting "preferred" packages first. +-- See 'compareByPreference' for the semantics of "preference". +sortByPreference :: PackagePrecedenceIndex -> [PackageConfig] -> [PackageConfig] +sortByPreference prec_map = sortBy (flip (compareByPreference prec_map)) + +-- | Returns 'GT' if @pkg@ should be preferred over @pkg'@ when picking +-- which should be "active". Here is the order of preference: +-- +-- 1. First, prefer the latest version +-- 2. If the versions are the same, prefer the package that +-- came in the latest package database. +-- +-- Pursuant to #12518, we could change this policy to, for example, remove +-- the version preference, meaning that we would always prefer the packages +-- in later package database. +-- +-- Instead, we use that preference based policy only when one of the packages +-- is integer-gmp and the other is integer-simple. +-- This currently only happens when we're looking up which concrete +-- package to use in place of @integer-wired-in@ and that two different +-- package databases supply a different integer library. For more about +-- the fake @integer-wired-in@ package, see Note [The integer library] +-- in the @PrelNames@ module. +compareByPreference + :: PackagePrecedenceIndex + -> PackageConfig + -> PackageConfig + -> Ordering +compareByPreference prec_map pkg pkg' + | Just prec <- Map.lookup (unitId pkg) prec_map + , Just prec' <- Map.lookup (unitId pkg') prec_map + , differentIntegerPkgs pkg pkg' + = compare prec prec' + + | otherwise + = case comparing packageVersion pkg pkg' of + GT -> GT + EQ | Just prec <- Map.lookup (unitId pkg) prec_map + , Just prec' <- Map.lookup (unitId pkg') prec_map + -- Prefer the package from the later DB flag (i.e., higher + -- precedence) + -> compare prec prec' + | otherwise + -> EQ + LT -> LT + + where isIntegerPkg p = packageNameString p `elem` + ["integer-simple", "integer-gmp"] + differentIntegerPkgs p p' = + isIntegerPkg p && isIntegerPkg p' && + (packageName p /= packageName p') + +comparing :: Ord a => (t -> a) -> t -> t -> Ordering +comparing f a b = f a `compare` f b + +packageFlagErr :: DynFlags + -> PackageFlag + -> [(PackageConfig, UnusablePackageReason)] + -> IO a +packageFlagErr dflags flag reasons + = packageFlagErr' dflags (pprFlag flag) reasons + +trustFlagErr :: DynFlags + -> TrustFlag + -> [(PackageConfig, UnusablePackageReason)] + -> IO a +trustFlagErr dflags flag reasons + = packageFlagErr' dflags (pprTrustFlag flag) reasons + +packageFlagErr' :: DynFlags + -> SDoc + -> [(PackageConfig, UnusablePackageReason)] + -> IO a +packageFlagErr' dflags flag_doc reasons + = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ err)) + where err = text "cannot satisfy " <> flag_doc <> + (if null reasons then Outputable.empty else text ": ") $$ + nest 4 (ppr_reasons $$ + text "(use -v for more information)") + ppr_reasons = vcat (map ppr_reason reasons) + ppr_reason (p, reason) = + pprReason (ppr (unitId p) <+> text "is") reason + +pprFlag :: PackageFlag -> SDoc +pprFlag flag = case flag of + HidePackage p -> text "-hide-package " <> text p + ExposePackage doc _ _ -> text doc + +pprTrustFlag :: TrustFlag -> SDoc +pprTrustFlag flag = case flag of + TrustPackage p -> text "-trust " <> text p + DistrustPackage p -> text "-distrust " <> text p + +-- ----------------------------------------------------------------------------- +-- Wired-in packages +-- +-- See Note [Wired-in packages] in Module + +type WiredInUnitId = String +type WiredPackagesMap = Map WiredUnitId WiredUnitId + +wired_in_pkgids :: [WiredInUnitId] +wired_in_pkgids = map unitIdString wiredInUnitIds + +findWiredInPackages + :: DynFlags + -> PackagePrecedenceIndex + -> [PackageConfig] -- database + -> VisibilityMap -- info on what packages are visible + -- for wired in selection + -> IO ([PackageConfig], -- package database updated for wired in + WiredPackagesMap) -- map from unit id to wired identity + +findWiredInPackages dflags prec_map pkgs vis_map = do + -- Now we must find our wired-in packages, and rename them to + -- their canonical names (eg. base-1.0 ==> base), as described + -- in Note [Wired-in packages] in Module + let + matches :: PackageConfig -> WiredInUnitId -> Bool + pc `matches` pid + -- See Note [The integer library] in PrelNames + | pid == unitIdString integerUnitId + = packageNameString pc `elem` ["integer-gmp", "integer-simple"] + pc `matches` pid = packageNameString pc == pid + + -- find which package corresponds to each wired-in package + -- delete any other packages with the same name + -- update the package and any dependencies to point to the new + -- one. + -- + -- When choosing which package to map to a wired-in package + -- name, we try to pick the latest version of exposed packages. + -- However, if there are no exposed wired in packages available + -- (e.g. -hide-all-packages was used), we can't bail: we *have* + -- to assign a package for the wired-in package: so we try again + -- with hidden packages included to (and pick the latest + -- version). + -- + -- You can also override the default choice by using -ignore-package: + -- this works even when there is no exposed wired in package + -- available. + -- + findWiredInPackage :: [PackageConfig] -> WiredInUnitId + -> IO (Maybe (WiredInUnitId, PackageConfig)) + findWiredInPackage pkgs wired_pkg = + let all_ps = [ p | p <- pkgs, p `matches` wired_pkg ] + all_exposed_ps = + [ p | p <- all_ps + , Map.member (packageConfigId p) vis_map ] in + case all_exposed_ps of + [] -> case all_ps of + [] -> notfound + many -> pick (head (sortByPreference prec_map many)) + many -> pick (head (sortByPreference prec_map many)) + where + notfound = do + debugTraceMsg dflags 2 $ + text "wired-in package " + <> text wired_pkg + <> text " not found." + return Nothing + pick :: PackageConfig + -> IO (Maybe (WiredInUnitId, PackageConfig)) + pick pkg = do + debugTraceMsg dflags 2 $ + text "wired-in package " + <> text wired_pkg + <> text " mapped to " + <> ppr (unitId pkg) + return (Just (wired_pkg, pkg)) + + + mb_wired_in_pkgs <- mapM (findWiredInPackage pkgs) wired_in_pkgids + let + wired_in_pkgs = catMaybes mb_wired_in_pkgs + + -- this is old: we used to assume that if there were + -- multiple versions of wired-in packages installed that + -- they were mutually exclusive. Now we're assuming that + -- you have one "main" version of each wired-in package + -- (the latest version), and the others are backward-compat + -- wrappers that depend on this one. e.g. base-4.0 is the + -- latest, base-3.0 is a compat wrapper depending on base-4.0. + {- + deleteOtherWiredInPackages pkgs = filterOut bad pkgs + where bad p = any (p `matches`) wired_in_pkgids + && package p `notElem` map fst wired_in_ids + -} + + wiredInMap :: Map WiredUnitId WiredUnitId + wiredInMap = Map.fromList + [ (key, DefUnitId (stringToInstalledUnitId wiredInUnitId)) + | (wiredInUnitId, pkg) <- wired_in_pkgs + , Just key <- pure $ definitePackageConfigId pkg + ] + + updateWiredInDependencies pkgs = map (upd_deps . upd_pkg) pkgs + where upd_pkg pkg + | Just def_uid <- definitePackageConfigId pkg + , Just wiredInUnitId <- Map.lookup def_uid wiredInMap + = let fs = installedUnitIdFS (unDefUnitId wiredInUnitId) + in pkg { + unitId = fsToInstalledUnitId fs, + componentId = ComponentId fs + } + | otherwise + = pkg + upd_deps pkg = pkg { + -- temporary harmless DefUnitId invariant violation + depends = map (unDefUnitId . upd_wired_in wiredInMap . DefUnitId) (depends pkg), + exposedModules + = map (\(k,v) -> (k, fmap (upd_wired_in_mod wiredInMap) v)) + (exposedModules pkg) + } + + + return (updateWiredInDependencies pkgs, wiredInMap) + +-- Helper functions for rewiring Module and UnitId. These +-- rewrite UnitIds of modules in wired-in packages to the form known to the +-- compiler, as described in Note [Wired-in packages] in Module. +-- +-- For instance, base-4.9.0.0 will be rewritten to just base, to match +-- what appears in PrelNames. + +upd_wired_in_mod :: WiredPackagesMap -> Module -> Module +upd_wired_in_mod wiredInMap (Module uid m) = Module (upd_wired_in_uid wiredInMap uid) m + +upd_wired_in_uid :: WiredPackagesMap -> UnitId -> UnitId +upd_wired_in_uid wiredInMap (DefiniteUnitId def_uid) = + DefiniteUnitId (upd_wired_in wiredInMap def_uid) +upd_wired_in_uid wiredInMap (IndefiniteUnitId indef_uid) = + IndefiniteUnitId $ newIndefUnitId + (indefUnitIdComponentId indef_uid) + (map (\(x,y) -> (x,upd_wired_in_mod wiredInMap y)) (indefUnitIdInsts indef_uid)) + +upd_wired_in :: WiredPackagesMap -> DefUnitId -> DefUnitId +upd_wired_in wiredInMap key + | Just key' <- Map.lookup key wiredInMap = key' + | otherwise = key + +updateVisibilityMap :: WiredPackagesMap -> VisibilityMap -> VisibilityMap +updateVisibilityMap wiredInMap vis_map = foldl' f vis_map (Map.toList wiredInMap) + where f vm (from, to) = case Map.lookup (DefiniteUnitId from) vis_map of + Nothing -> vm + Just r -> Map.insert (DefiniteUnitId to) r + (Map.delete (DefiniteUnitId from) vm) + + +-- ---------------------------------------------------------------------------- + +-- | The reason why a package is unusable. +data UnusablePackageReason + = -- | We ignored it explicitly using @-ignore-package@. + IgnoredWithFlag + -- | This package transitively depends on a package that was never present + -- in any of the provided databases. + | BrokenDependencies [InstalledUnitId] + -- | This package transitively depends on a package involved in a cycle. + -- Note that the list of 'InstalledUnitId' reports the direct dependencies + -- of this package that (transitively) depended on the cycle, and not + -- the actual cycle itself (which we report separately at high verbosity.) + | CyclicDependencies [InstalledUnitId] + -- | This package transitively depends on a package which was ignored. + | IgnoredDependencies [InstalledUnitId] + -- | This package transitively depends on a package which was + -- shadowed by an ABI-incompatible package. + | ShadowedDependencies [InstalledUnitId] + +instance Outputable UnusablePackageReason where + ppr IgnoredWithFlag = text "[ignored with flag]" + ppr (BrokenDependencies uids) = brackets (text "broken" <+> ppr uids) + ppr (CyclicDependencies uids) = brackets (text "cyclic" <+> ppr uids) + ppr (IgnoredDependencies uids) = brackets (text "ignored" <+> ppr uids) + ppr (ShadowedDependencies uids) = brackets (text "shadowed" <+> ppr uids) + +type UnusablePackages = Map InstalledUnitId + (PackageConfig, UnusablePackageReason) + +pprReason :: SDoc -> UnusablePackageReason -> SDoc +pprReason pref reason = case reason of + IgnoredWithFlag -> + pref <+> text "ignored due to an -ignore-package flag" + BrokenDependencies deps -> + pref <+> text "unusable due to missing dependencies:" $$ + nest 2 (hsep (map ppr deps)) + CyclicDependencies deps -> + pref <+> text "unusable due to cyclic dependencies:" $$ + nest 2 (hsep (map ppr deps)) + IgnoredDependencies deps -> + pref <+> text ("unusable because the -ignore-package flag was used to " ++ + "ignore at least one of its dependencies:") $$ + nest 2 (hsep (map ppr deps)) + ShadowedDependencies deps -> + pref <+> text "unusable due to shadowed dependencies:" $$ + nest 2 (hsep (map ppr deps)) + +reportCycles :: DynFlags -> [SCC PackageConfig] -> IO () +reportCycles dflags sccs = mapM_ report sccs + where + report (AcyclicSCC _) = return () + report (CyclicSCC vs) = + debugTraceMsg dflags 2 $ + text "these packages are involved in a cycle:" $$ + nest 2 (hsep (map (ppr . unitId) vs)) + +reportUnusable :: DynFlags -> UnusablePackages -> IO () +reportUnusable dflags pkgs = mapM_ report (Map.toList pkgs) + where + report (ipid, (_, reason)) = + debugTraceMsg dflags 2 $ + pprReason + (text "package" <+> ppr ipid <+> text "is") reason + +-- ---------------------------------------------------------------------------- +-- +-- Utilities on the database +-- + +-- | A reverse dependency index, mapping an 'InstalledUnitId' to +-- the 'InstalledUnitId's which have a dependency on it. +type RevIndex = Map InstalledUnitId [InstalledUnitId] + +-- | Compute the reverse dependency index of a package database. +reverseDeps :: InstalledPackageIndex -> RevIndex +reverseDeps db = Map.foldl' go Map.empty db + where + go r pkg = foldl' (go' (unitId pkg)) r (depends pkg) + go' from r to = Map.insertWith (++) to [from] r + +-- | Given a list of 'InstalledUnitId's to remove, a database, +-- and a reverse dependency index (as computed by 'reverseDeps'), +-- remove those packages, plus any packages which depend on them. +-- Returns the pruned database, as well as a list of 'PackageConfig's +-- that was removed. +removePackages :: [InstalledUnitId] -> RevIndex + -> InstalledPackageIndex + -> (InstalledPackageIndex, [PackageConfig]) +removePackages uids index m = go uids (m,[]) + where + go [] (m,pkgs) = (m,pkgs) + go (uid:uids) (m,pkgs) + | Just pkg <- Map.lookup uid m + = case Map.lookup uid index of + Nothing -> go uids (Map.delete uid m, pkg:pkgs) + Just rdeps -> go (rdeps ++ uids) (Map.delete uid m, pkg:pkgs) + | otherwise + = go uids (m,pkgs) + +-- | Given a 'PackageConfig' from some 'InstalledPackageIndex', +-- return all entries in 'depends' which correspond to packages +-- that do not exist in the index. +depsNotAvailable :: InstalledPackageIndex + -> PackageConfig + -> [InstalledUnitId] +depsNotAvailable pkg_map pkg = filter (not . (`Map.member` pkg_map)) (depends pkg) + +-- | Given a 'PackageConfig' from some 'InstalledPackageIndex' +-- return all entries in 'abiDepends' which correspond to packages +-- that do not exist, OR have mismatching ABIs. +depsAbiMismatch :: InstalledPackageIndex + -> PackageConfig + -> [InstalledUnitId] +depsAbiMismatch pkg_map pkg = map fst . filter (not . abiMatch) $ abiDepends pkg + where + abiMatch (dep_uid, abi) + | Just dep_pkg <- Map.lookup dep_uid pkg_map + = abiHash dep_pkg == abi + | otherwise + = False + +-- ----------------------------------------------------------------------------- +-- Ignore packages + +ignorePackages :: [IgnorePackageFlag] -> [PackageConfig] -> UnusablePackages +ignorePackages flags pkgs = Map.fromList (concatMap doit flags) + where + doit (IgnorePackage str) = + case partition (matchingStr str) pkgs of + (ps, _) -> [ (unitId p, (p, IgnoredWithFlag)) + | p <- ps ] + -- missing package is not an error for -ignore-package, + -- because a common usage is to -ignore-package P as + -- a preventative measure just in case P exists. + +-- ---------------------------------------------------------------------------- +-- +-- Merging databases +-- + +-- | For each package, a mapping from uid -> i indicates that this +-- package was brought into GHC by the ith @-package-db@ flag on +-- the command line. We use this mapping to make sure we prefer +-- packages that were defined later on the command line, if there +-- is an ambiguity. +type PackagePrecedenceIndex = Map InstalledUnitId Int + +-- | Given a list of databases, merge them together, where +-- packages with the same unit id in later databases override +-- earlier ones. This does NOT check if the resulting database +-- makes sense (that's done by 'validateDatabase'). +mergeDatabases :: DynFlags -> [(FilePath, [PackageConfig])] + -> IO (InstalledPackageIndex, PackagePrecedenceIndex) +mergeDatabases dflags = foldM merge (Map.empty, Map.empty) . zip [1..] + where + merge (pkg_map, prec_map) (i, (db_path, db)) = do + debugTraceMsg dflags 2 $ + text "loading package database" <+> text db_path + forM_ (Set.toList override_set) $ \pkg -> + debugTraceMsg dflags 2 $ + text "package" <+> ppr pkg <+> + text "overrides a previously defined package" + return (pkg_map', prec_map') + where + db_map = mk_pkg_map db + mk_pkg_map = Map.fromList . map (\p -> (unitId p, p)) + + -- The set of UnitIds which appear in both db and pkgs. These are the + -- ones that get overridden. Compute this just to give some + -- helpful debug messages at -v2 + override_set :: Set InstalledUnitId + override_set = Set.intersection (Map.keysSet db_map) + (Map.keysSet pkg_map) + + -- Now merge the sets together (NB: in case of duplicate, + -- first argument preferred) + pkg_map' :: InstalledPackageIndex + pkg_map' = Map.union db_map pkg_map + + prec_map' :: PackagePrecedenceIndex + prec_map' = Map.union (Map.map (const i) db_map) prec_map + +-- | Validates a database, removing unusable packages from it +-- (this includes removing packages that the user has explicitly +-- ignored.) Our general strategy: +-- +-- 1. Remove all broken packages (dangling dependencies) +-- 2. Remove all packages that are cyclic +-- 3. Apply ignore flags +-- 4. Remove all packages which have deps with mismatching ABIs +-- +validateDatabase :: DynFlags -> InstalledPackageIndex + -> (InstalledPackageIndex, UnusablePackages, [SCC PackageConfig]) +validateDatabase dflags pkg_map1 = + (pkg_map5, unusable, sccs) + where + ignore_flags = reverse (ignorePackageFlags dflags) + + -- Compute the reverse dependency index + index = reverseDeps pkg_map1 + + -- Helper function + mk_unusable mk_err dep_matcher m uids = + Map.fromList [ (unitId pkg, (pkg, mk_err (dep_matcher m pkg))) + | pkg <- uids ] + + -- Find broken packages + directly_broken = filter (not . null . depsNotAvailable pkg_map1) + (Map.elems pkg_map1) + (pkg_map2, broken) = removePackages (map unitId directly_broken) index pkg_map1 + unusable_broken = mk_unusable BrokenDependencies depsNotAvailable pkg_map2 broken + + -- Find recursive packages + sccs = stronglyConnComp [ (pkg, unitId pkg, depends pkg) + | pkg <- Map.elems pkg_map2 ] + getCyclicSCC (CyclicSCC vs) = map unitId vs + getCyclicSCC (AcyclicSCC _) = [] + (pkg_map3, cyclic) = removePackages (concatMap getCyclicSCC sccs) index pkg_map2 + unusable_cyclic = mk_unusable CyclicDependencies depsNotAvailable pkg_map3 cyclic + + -- Apply ignore flags + directly_ignored = ignorePackages ignore_flags (Map.elems pkg_map3) + (pkg_map4, ignored) = removePackages (Map.keys directly_ignored) index pkg_map3 + unusable_ignored = mk_unusable IgnoredDependencies depsNotAvailable pkg_map4 ignored + + -- Knock out packages whose dependencies don't agree with ABI + -- (i.e., got invalidated due to shadowing) + directly_shadowed = filter (not . null . depsAbiMismatch pkg_map4) + (Map.elems pkg_map4) + (pkg_map5, shadowed) = removePackages (map unitId directly_shadowed) index pkg_map4 + unusable_shadowed = mk_unusable ShadowedDependencies depsAbiMismatch pkg_map5 shadowed + + unusable = directly_ignored `Map.union` unusable_ignored + `Map.union` unusable_broken + `Map.union` unusable_cyclic + `Map.union` unusable_shadowed + +-- ----------------------------------------------------------------------------- +-- When all the command-line options are in, we can process our package +-- settings and populate the package state. + +mkPackageState + :: DynFlags + -- initial databases, in the order they were specified on + -- the command line (later databases shadow earlier ones) + -> [(FilePath, [PackageConfig])] + -> [PreloadUnitId] -- preloaded packages + -> IO (PackageState, + [PreloadUnitId], -- new packages to preload + Maybe [(ModuleName, Module)]) + +mkPackageState dflags dbs preload0 = do +{- + Plan. + + There are two main steps for making the package state: + + 1. We want to build a single, unified package database based + on all of the input databases, which upholds the invariant that + there is only one package per any UnitId and there are no + dangling dependencies. We'll do this by merging, and + then successively filtering out bad dependencies. + + a) Merge all the databases together. + If an input database defines unit ID that is already in + the unified database, that package SHADOWS the existing + package in the current unified database. Note that + order is important: packages defined later in the list of + command line arguments shadow those defined earlier. + + b) Remove all packages with missing dependencies, or + mutually recursive dependencies. + + b) Remove packages selected by -ignore-package from input database + + c) Remove all packages which depended on packages that are now + shadowed by an ABI-incompatible package + + d) report (with -v) any packages that were removed by steps 1-3 + + 2. We want to look at the flags controlling package visibility, + and build a mapping of what module names are in scope and + where they live. + + a) on the final, unified database, we apply -trust/-distrust + flags directly, modifying the database so that the 'trusted' + field has the correct value. + + b) we use the -package/-hide-package flags to compute a + visibility map, stating what packages are "exposed" for + the purposes of computing the module map. + * if any flag refers to a package which was removed by 1-5, then + we can give an error message explaining why + * if -hide-all-packages what not specified, this step also + hides packages which are superseded by later exposed packages + * this step is done TWICE if -plugin-package/-hide-all-plugin-packages + are used + + c) based on the visibility map, we pick wired packages and rewrite + them to have the expected unitId. + + d) finally, using the visibility map and the package database, + we build a mapping saying what every in scope module name points to. +-} + + -- This, and the other reverse's that you will see, are due to the face that + -- packageFlags, pluginPackageFlags, etc. are all specified in *reverse* order + -- than they are on the command line. + let other_flags = reverse (packageFlags dflags) + debugTraceMsg dflags 2 $ + text "package flags" <+> ppr other_flags + + -- Merge databases together, without checking validity + (pkg_map1, prec_map) <- mergeDatabases dflags dbs + + -- Now that we've merged everything together, prune out unusable + -- packages. + let (pkg_map2, unusable, sccs) = validateDatabase dflags pkg_map1 + + reportCycles dflags sccs + reportUnusable dflags unusable + + -- Apply trust flags (these flags apply regardless of whether + -- or not packages are visible or not) + pkgs1 <- foldM (applyTrustFlag dflags prec_map unusable) + (Map.elems pkg_map2) (reverse (trustFlags dflags)) + let prelim_pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs1 + + -- + -- Calculate the initial set of units from package databases, prior to any package flags. + -- + -- Conceptually, we select the latest versions of all valid (not unusable) *packages* + -- (not units). This is empty if we have -hide-all-packages. + -- + -- Then we create an initial visibility map with default visibilities for all + -- exposed, definite units which belong to the latest valid packages. + -- + let preferLater unit unit' = + case compareByPreference prec_map unit unit' of + GT -> unit + _ -> unit' + addIfMorePreferable m unit = addToUDFM_C preferLater m (fsPackageName unit) unit + -- This is the set of maximally preferable packages. In fact, it is a set of + -- most preferable *units* keyed by package name, which act as stand-ins in + -- for "a package in a database". We use units here because we don't have + -- "a package in a database" as a type currently. + mostPreferablePackageReps = if gopt Opt_HideAllPackages dflags + then emptyUDFM + else foldl' addIfMorePreferable emptyUDFM pkgs1 + -- When exposing units, we want to consider all of those in the most preferable + -- packages. We can implement that by looking for units that are equi-preferable + -- with the most preferable unit for package. Being equi-preferable means that + -- they must be in the same database, with the same version, and the same pacakge name. + -- + -- We must take care to consider all these units and not just the most + -- preferable one, otherwise we can end up with problems like #16228. + mostPreferable u = + case lookupUDFM mostPreferablePackageReps (fsPackageName u) of + Nothing -> False + Just u' -> compareByPreference prec_map u u' == EQ + vis_map1 = foldl' (\vm p -> + -- Note: we NEVER expose indefinite packages by + -- default, because it's almost assuredly not + -- what you want (no mix-in linking has occurred). + if exposed p && unitIdIsDefinite (packageConfigId p) && mostPreferable p + then Map.insert (packageConfigId p) + UnitVisibility { + uv_expose_all = True, + uv_renamings = [], + uv_package_name = First (Just (fsPackageName p)), + uv_requirements = Map.empty, + uv_explicit = False + } + vm + else vm) + Map.empty pkgs1 + + -- + -- Compute a visibility map according to the command-line flags (-package, + -- -hide-package). This needs to know about the unusable packages, since if a + -- user tries to enable an unusable package, we should let them know. + -- + vis_map2 <- foldM (applyPackageFlag dflags prec_map prelim_pkg_db unusable + (gopt Opt_HideAllPackages dflags) pkgs1) + vis_map1 other_flags + + -- + -- Sort out which packages are wired in. This has to be done last, since + -- it modifies the unit ids of wired in packages, but when we process + -- package arguments we need to key against the old versions. + -- + (pkgs2, wired_map) <- findWiredInPackages dflags prec_map pkgs1 vis_map2 + let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs2 + + -- Update the visibility map, so we treat wired packages as visible. + let vis_map = updateVisibilityMap wired_map vis_map2 + + let hide_plugin_pkgs = gopt Opt_HideAllPluginPackages dflags + plugin_vis_map <- + case pluginPackageFlags dflags of + -- common case; try to share the old vis_map + [] | not hide_plugin_pkgs -> return vis_map + | otherwise -> return Map.empty + _ -> do let plugin_vis_map1 + | hide_plugin_pkgs = Map.empty + -- Use the vis_map PRIOR to wired in, + -- because otherwise applyPackageFlag + -- won't work. + | otherwise = vis_map2 + plugin_vis_map2 + <- foldM (applyPackageFlag dflags prec_map prelim_pkg_db unusable + (gopt Opt_HideAllPluginPackages dflags) pkgs1) + plugin_vis_map1 + (reverse (pluginPackageFlags dflags)) + -- Updating based on wired in packages is mostly + -- good hygiene, because it won't matter: no wired in + -- package has a compiler plugin. + -- TODO: If a wired in package had a compiler plugin, + -- and you tried to pick different wired in packages + -- with the plugin flags and the normal flags... what + -- would happen? I don't know! But this doesn't seem + -- likely to actually happen. + return (updateVisibilityMap wired_map plugin_vis_map2) + + -- + -- Here we build up a set of the packages mentioned in -package + -- flags on the command line; these are called the "preload" + -- packages. we link these packages in eagerly. The preload set + -- should contain at least rts & base, which is why we pretend that + -- the command line contains -package rts & -package base. + -- + -- NB: preload IS important even for type-checking, because we + -- need the correct include path to be set. + -- + let preload1 = Map.keys (Map.filter uv_explicit vis_map) + + let pkgname_map = foldl' add Map.empty pkgs2 + where add pn_map p + = Map.insert (packageName p) (componentId p) pn_map + + -- The explicitPackages accurately reflects the set of packages we have turned + -- on; as such, it also is the only way one can come up with requirements. + -- The requirement context is directly based off of this: we simply + -- look for nested unit IDs that are directly fed holes: the requirements + -- of those units are precisely the ones we need to track + let explicit_pkgs = Map.keys vis_map + req_ctx = Map.map (Set.toList) + $ Map.unionsWith Set.union (map uv_requirements (Map.elems vis_map)) + + + let preload2 = preload1 + + let + -- add base & rts to the preload packages + basicLinkedPackages + | gopt Opt_AutoLinkPackages dflags + = filter (flip elemUDFM (unPackageConfigMap pkg_db)) + [baseUnitId, rtsUnitId] + | otherwise = [] + -- but in any case remove the current package from the set of + -- preloaded packages so that base/rts does not end up in the + -- set up preloaded package when we are just building it + -- (NB: since this is only relevant for base/rts it doesn't matter + -- that thisUnitIdInsts_ is not wired yet) + -- + preload3 = nub $ filter (/= thisPackage dflags) + $ (basicLinkedPackages ++ preload2) + + -- Close the preload packages with their dependencies + dep_preload <- closeDeps dflags pkg_db (zip (map toInstalledUnitId preload3) (repeat Nothing)) + let new_dep_preload = filter (`notElem` preload0) dep_preload + + let mod_map1 = mkModuleToPkgConfAll dflags pkg_db vis_map + mod_map2 = mkUnusableModuleToPkgConfAll unusable + mod_map = Map.union mod_map1 mod_map2 + + dumpIfSet_dyn (dflags { pprCols = 200 }) Opt_D_dump_mod_map "Mod Map" + (pprModuleMap mod_map) + + -- Force pstate to avoid leaking the dflags0 passed to mkPackageState + let !pstate = PackageState{ + preloadPackages = dep_preload, + explicitPackages = explicit_pkgs, + pkgIdMap = pkg_db, + moduleToPkgConfAll = mod_map, + pluginModuleToPkgConfAll = mkModuleToPkgConfAll dflags pkg_db plugin_vis_map, + packageNameMap = pkgname_map, + unwireMap = Map.fromList [ (v,k) | (k,v) <- Map.toList wired_map ], + requirementContext = req_ctx + } + let new_insts = fmap (map (fmap (upd_wired_in_mod wired_map))) (thisUnitIdInsts_ dflags) + return (pstate, new_dep_preload, new_insts) + +-- | Given a wired-in 'UnitId', "unwire" it into the 'UnitId' +-- that it was recorded as in the package database. +unwireUnitId :: DynFlags -> UnitId -> UnitId +unwireUnitId dflags uid@(DefiniteUnitId def_uid) = + maybe uid DefiniteUnitId (Map.lookup def_uid (unwireMap (pkgState dflags))) +unwireUnitId _ uid = uid + +-- ----------------------------------------------------------------------------- +-- | Makes the mapping from module to package info + +-- Slight irritation: we proceed by leafing through everything +-- in the installed package database, which makes handling indefinite +-- packages a bit bothersome. + +mkModuleToPkgConfAll + :: DynFlags + -> PackageConfigMap + -> VisibilityMap + -> ModuleToPkgConfAll +mkModuleToPkgConfAll dflags pkg_db vis_map = + -- What should we fold on? Both situations are awkward: + -- + -- * Folding on the visibility map means that we won't create + -- entries for packages that aren't mentioned in vis_map + -- (e.g., hidden packages, causing #14717) + -- + -- * Folding on pkg_db is awkward because if we have an + -- Backpack instantiation, we need to possibly add a + -- package from pkg_db multiple times to the actual + -- ModuleToPkgConfAll. Also, we don't really want + -- definite package instantiations to show up in the + -- list of possibilities. + -- + -- So what will we do instead? We'll extend vis_map with + -- entries for every definite (for non-Backpack) and + -- indefinite (for Backpack) package, so that we get the + -- hidden entries we need. + Map.foldlWithKey extend_modmap emptyMap vis_map_extended + where + vis_map_extended = Map.union vis_map {- preferred -} default_vis + + default_vis = Map.fromList + [ (packageConfigId pkg, mempty) + | pkg <- eltsUDFM (unPackageConfigMap pkg_db) + -- Exclude specific instantiations of an indefinite + -- package + , indefinite pkg || null (instantiatedWith pkg) + ] + + emptyMap = Map.empty + setOrigins m os = fmap (const os) m + extend_modmap modmap uid + UnitVisibility { uv_expose_all = b, uv_renamings = rns } + = addListTo modmap theBindings + where + pkg = pkg_lookup uid + + theBindings :: [(ModuleName, Map Module ModuleOrigin)] + theBindings = newBindings b rns + + newBindings :: Bool + -> [(ModuleName, ModuleName)] + -> [(ModuleName, Map Module ModuleOrigin)] + newBindings e rns = es e ++ hiddens ++ map rnBinding rns + + rnBinding :: (ModuleName, ModuleName) + -> (ModuleName, Map Module ModuleOrigin) + rnBinding (orig, new) = (new, setOrigins origEntry fromFlag) + where origEntry = case lookupUFM esmap orig of + Just r -> r + Nothing -> throwGhcException (CmdLineError (showSDoc dflags + (text "package flag: could not find module name" <+> + ppr orig <+> text "in package" <+> ppr pk))) + + es :: Bool -> [(ModuleName, Map Module ModuleOrigin)] + es e = do + (m, exposedReexport) <- exposed_mods + let (pk', m', origin') = + case exposedReexport of + Nothing -> (pk, m, fromExposedModules e) + Just (Module pk' m') -> + let pkg' = pkg_lookup pk' + in (pk', m', fromReexportedModules e pkg') + return (m, mkModMap pk' m' origin') + + esmap :: UniqFM (Map Module ModuleOrigin) + esmap = listToUFM (es False) -- parameter here doesn't matter, orig will + -- be overwritten + + hiddens = [(m, mkModMap pk m ModHidden) | m <- hidden_mods] + + pk = packageConfigId pkg + pkg_lookup uid = lookupPackage' (isIndefinite dflags) pkg_db uid + `orElse` pprPanic "pkg_lookup" (ppr uid) + + exposed_mods = exposedModules pkg + hidden_mods = hiddenModules pkg + +-- | Make a 'ModuleToPkgConfAll' covering a set of unusable packages. +mkUnusableModuleToPkgConfAll :: UnusablePackages -> ModuleToPkgConfAll +mkUnusableModuleToPkgConfAll unusables = + Map.foldl' extend_modmap Map.empty unusables + where + extend_modmap modmap (pkg, reason) = addListTo modmap bindings + where bindings :: [(ModuleName, Map Module ModuleOrigin)] + bindings = exposed ++ hidden + + origin = ModUnusable reason + pkg_id = packageConfigId pkg + + exposed = map get_exposed exposed_mods + hidden = [(m, mkModMap pkg_id m origin) | m <- hidden_mods] + + get_exposed (mod, Just mod') = (mod, Map.singleton mod' origin) + get_exposed (mod, _) = (mod, mkModMap pkg_id mod origin) + + exposed_mods = exposedModules pkg + hidden_mods = hiddenModules pkg + +-- | Add a list of key/value pairs to a nested map. +-- +-- The outer map is processed with 'Data.Map.Strict' to prevent memory leaks +-- when reloading modules in GHCi (see #4029). This ensures that each +-- value is forced before installing into the map. +addListTo :: (Monoid a, Ord k1, Ord k2) + => Map k1 (Map k2 a) + -> [(k1, Map k2 a)] + -> Map k1 (Map k2 a) +addListTo = foldl' merge + where merge m (k, v) = MapStrict.insertWith (Map.unionWith mappend) k v m + +-- | Create a singleton module mapping +mkModMap :: UnitId -> ModuleName -> ModuleOrigin -> Map Module ModuleOrigin +mkModMap pkg mod = Map.singleton (mkModule pkg mod) + +-- ----------------------------------------------------------------------------- +-- Extracting information from the packages in scope + +-- Many of these functions take a list of packages: in those cases, +-- the list is expected to contain the "dependent packages", +-- i.e. those packages that were found to be depended on by the +-- current module/program. These can be auto or non-auto packages, it +-- doesn't really matter. The list is always combined with the list +-- of preload (command-line) packages to determine which packages to +-- use. + +-- | Find all the include directories in these and the preload packages +getPackageIncludePath :: DynFlags -> [PreloadUnitId] -> IO [String] +getPackageIncludePath dflags pkgs = + collectIncludeDirs `fmap` getPreloadPackagesAnd dflags pkgs + +collectIncludeDirs :: [PackageConfig] -> [FilePath] +collectIncludeDirs ps = nub (filter notNull (concatMap includeDirs ps)) + +-- | Find all the library paths in these and the preload packages +getPackageLibraryPath :: DynFlags -> [PreloadUnitId] -> IO [String] +getPackageLibraryPath dflags pkgs = + collectLibraryPaths dflags `fmap` getPreloadPackagesAnd dflags pkgs + +collectLibraryPaths :: DynFlags -> [PackageConfig] -> [FilePath] +collectLibraryPaths dflags = nub . filter notNull + . concatMap (libraryDirsForWay dflags) + +-- | Find all the link options in these and the preload packages, +-- returning (package hs lib options, extra library options, other flags) +getPackageLinkOpts :: DynFlags -> [PreloadUnitId] -> IO ([String], [String], [String]) +getPackageLinkOpts dflags pkgs = + collectLinkOpts dflags `fmap` getPreloadPackagesAnd dflags pkgs + +collectLinkOpts :: DynFlags -> [PackageConfig] -> ([String], [String], [String]) +collectLinkOpts dflags ps = + ( + concatMap (map ("-l" ++) . packageHsLibs dflags) ps, + concatMap (map ("-l" ++) . extraLibraries) ps, + concatMap ldOptions ps + ) +collectArchives :: DynFlags -> PackageConfig -> IO [FilePath] +collectArchives dflags pc = + filterM doesFileExist [ searchPath ("lib" ++ lib ++ ".a") + | searchPath <- searchPaths + , lib <- libs ] + where searchPaths = nub . filter notNull . libraryDirsForWay dflags $ pc + libs = packageHsLibs dflags pc ++ extraLibraries pc + +getLibs :: DynFlags -> [PreloadUnitId] -> IO [(String,String)] +getLibs dflags pkgs = do + ps <- getPreloadPackagesAnd dflags pkgs + fmap concat . forM ps $ \p -> do + let candidates = [ (l f, f) | l <- collectLibraryPaths dflags [p] + , f <- (\n -> "lib" ++ n ++ ".a") <$> packageHsLibs dflags p ] + filterM (doesFileExist . fst) candidates + +packageHsLibs :: DynFlags -> PackageConfig -> [String] +packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p) + where + ways0 = ways dflags + + ways1 = filter (/= WayDyn) ways0 + -- the name of a shared library is libHSfoo-ghc.so + -- we leave out the _dyn, because it is superfluous + + -- debug and profiled RTSs include support for -eventlog + ways2 | WayDebug `elem` ways1 || WayProf `elem` ways1 + = filter (/= WayEventLog) ways1 + | otherwise + = ways1 + + tag = mkBuildTag (filter (not . wayRTSOnly) ways2) + rts_tag = mkBuildTag ways2 + + mkDynName x + | WayDyn `notElem` ways dflags = x + | "HS" `isPrefixOf` x = + x ++ '-':programName dflags ++ projectVersion dflags + -- For non-Haskell libraries, we use the name "Cfoo". The .a + -- file is libCfoo.a, and the .so is libfoo.so. That way the + -- linker knows what we mean for the vanilla (-lCfoo) and dyn + -- (-lfoo) ways. We therefore need to strip the 'C' off here. + | Just x' <- stripPrefix "C" x = x' + | otherwise + = panic ("Don't understand library name " ++ x) + + -- Add _thr and other rts suffixes to packages named + -- `rts` or `rts-1.0`. Why both? Traditionally the rts + -- package is called `rts` only. However the tooling + -- usually expects a package name to have a version. + -- As such we will gradually move towards the `rts-1.0` + -- package name, at which point the `rts` package name + -- will eventually be unused. + -- + -- This change elevates the need to add custom hooks + -- and handling specifically for the `rts` package for + -- example in ghc-cabal. + addSuffix rts@"HSrts" = rts ++ (expandTag rts_tag) + addSuffix rts@"HSrts-1.0"= rts ++ (expandTag rts_tag) + addSuffix other_lib = other_lib ++ (expandTag tag) + + expandTag t | null t = "" + | otherwise = '_':t + +-- | Either the 'libraryDirs' or 'libraryDynDirs' as appropriate for the way. +libraryDirsForWay :: DynFlags -> PackageConfig -> [String] +libraryDirsForWay dflags + | WayDyn `elem` ways dflags = libraryDynDirs + | otherwise = libraryDirs + +-- | Find all the C-compiler options in these and the preload packages +getPackageExtraCcOpts :: DynFlags -> [PreloadUnitId] -> IO [String] +getPackageExtraCcOpts dflags pkgs = do + ps <- getPreloadPackagesAnd dflags pkgs + return (concatMap ccOptions ps) + +-- | Find all the package framework paths in these and the preload packages +getPackageFrameworkPath :: DynFlags -> [PreloadUnitId] -> IO [String] +getPackageFrameworkPath dflags pkgs = do + ps <- getPreloadPackagesAnd dflags pkgs + return (nub (filter notNull (concatMap frameworkDirs ps))) + +-- | Find all the package frameworks in these and the preload packages +getPackageFrameworks :: DynFlags -> [PreloadUnitId] -> IO [String] +getPackageFrameworks dflags pkgs = do + ps <- getPreloadPackagesAnd dflags pkgs + return (concatMap frameworks ps) + +-- ----------------------------------------------------------------------------- +-- Package Utils + +-- | Takes a 'ModuleName', and if the module is in any package returns +-- list of modules which take that name. +lookupModuleInAllPackages :: DynFlags + -> ModuleName + -> [(Module, PackageConfig)] +lookupModuleInAllPackages dflags m + = case lookupModuleWithSuggestions dflags m Nothing of + LookupFound a b -> [(a,b)] + LookupMultiple rs -> map f rs + where f (m,_) = (m, expectJust "lookupModule" (lookupPackage dflags + (moduleUnitId m))) + _ -> [] + +-- | The result of performing a lookup +data LookupResult = + -- | Found the module uniquely, nothing else to do + LookupFound Module PackageConfig + -- | Multiple modules with the same name in scope + | LookupMultiple [(Module, ModuleOrigin)] + -- | No modules found, but there were some hidden ones with + -- an exact name match. First is due to package hidden, second + -- is due to module being hidden + | LookupHidden [(Module, ModuleOrigin)] [(Module, ModuleOrigin)] + -- | No modules found, but there were some unusable ones with + -- an exact name match + | LookupUnusable [(Module, ModuleOrigin)] + -- | Nothing found, here are some suggested different names + | LookupNotFound [ModuleSuggestion] -- suggestions + +data ModuleSuggestion = SuggestVisible ModuleName Module ModuleOrigin + | SuggestHidden ModuleName Module ModuleOrigin + +lookupModuleWithSuggestions :: DynFlags + -> ModuleName + -> Maybe FastString + -> LookupResult +lookupModuleWithSuggestions dflags + = lookupModuleWithSuggestions' dflags + (moduleToPkgConfAll (pkgState dflags)) + +lookupPluginModuleWithSuggestions :: DynFlags + -> ModuleName + -> Maybe FastString + -> LookupResult +lookupPluginModuleWithSuggestions dflags + = lookupModuleWithSuggestions' dflags + (pluginModuleToPkgConfAll (pkgState dflags)) + +lookupModuleWithSuggestions' :: DynFlags + -> ModuleToPkgConfAll + -> ModuleName + -> Maybe FastString + -> LookupResult +lookupModuleWithSuggestions' dflags mod_map m mb_pn + = case Map.lookup m mod_map of + Nothing -> LookupNotFound suggestions + Just xs -> + case foldl' classify ([],[],[], []) (Map.toList xs) of + ([], [], [], []) -> LookupNotFound suggestions + (_, _, _, [(m, _)]) -> LookupFound m (mod_pkg m) + (_, _, _, exposed@(_:_)) -> LookupMultiple exposed + ([], [], unusable@(_:_), []) -> LookupUnusable unusable + (hidden_pkg, hidden_mod, _, []) -> + LookupHidden hidden_pkg hidden_mod + where + classify (hidden_pkg, hidden_mod, unusable, exposed) (m, origin0) = + let origin = filterOrigin mb_pn (mod_pkg m) origin0 + x = (m, origin) + in case origin of + ModHidden + -> (hidden_pkg, x:hidden_mod, unusable, exposed) + ModUnusable _ + -> (hidden_pkg, hidden_mod, x:unusable, exposed) + _ | originEmpty origin + -> (hidden_pkg, hidden_mod, unusable, exposed) + | originVisible origin + -> (hidden_pkg, hidden_mod, unusable, x:exposed) + | otherwise + -> (x:hidden_pkg, hidden_mod, unusable, exposed) + + pkg_lookup p = lookupPackage dflags p `orElse` pprPanic "lookupModuleWithSuggestions" (ppr p <+> ppr m) + mod_pkg = pkg_lookup . moduleUnitId + + -- Filters out origins which are not associated with the given package + -- qualifier. No-op if there is no package qualifier. Test if this + -- excluded all origins with 'originEmpty'. + filterOrigin :: Maybe FastString + -> PackageConfig + -> ModuleOrigin + -> ModuleOrigin + filterOrigin Nothing _ o = o + filterOrigin (Just pn) pkg o = + case o of + ModHidden -> if go pkg then ModHidden else mempty + (ModUnusable _) -> if go pkg then o else mempty + ModOrigin { fromOrigPackage = e, fromExposedReexport = res, + fromHiddenReexport = rhs } + -> ModOrigin { + fromOrigPackage = if go pkg then e else Nothing + , fromExposedReexport = filter go res + , fromHiddenReexport = filter go rhs + , fromPackageFlag = False -- always excluded + } + where go pkg = pn == fsPackageName pkg + + suggestions + | gopt Opt_HelpfulErrors dflags = + fuzzyLookup (moduleNameString m) all_mods + | otherwise = [] + + all_mods :: [(String, ModuleSuggestion)] -- All modules + all_mods = sortBy (comparing fst) $ + [ (moduleNameString m, suggestion) + | (m, e) <- Map.toList (moduleToPkgConfAll (pkgState dflags)) + , suggestion <- map (getSuggestion m) (Map.toList e) + ] + getSuggestion name (mod, origin) = + (if originVisible origin then SuggestVisible else SuggestHidden) + name mod origin + +listVisibleModuleNames :: DynFlags -> [ModuleName] +listVisibleModuleNames dflags = + map fst (filter visible (Map.toList (moduleToPkgConfAll (pkgState dflags)))) + where visible (_, ms) = any originVisible (Map.elems ms) + +-- | Find all the 'PackageConfig' in both the preload packages from 'DynFlags' and corresponding to the list of +-- 'PackageConfig's +getPreloadPackagesAnd :: DynFlags -> [PreloadUnitId] -> IO [PackageConfig] +getPreloadPackagesAnd dflags pkgids0 = + let + pkgids = pkgids0 ++ + -- An indefinite package will have insts to HOLE, + -- which is not a real package. Don't look it up. + -- Fixes #14525 + if isIndefinite dflags + then [] + else map (toInstalledUnitId . moduleUnitId . snd) + (thisUnitIdInsts dflags) + state = pkgState dflags + pkg_map = pkgIdMap state + preload = preloadPackages state + pairs = zip pkgids (repeat Nothing) + in do + all_pkgs <- throwErr dflags (foldM (add_package dflags pkg_map) preload pairs) + return (map (getInstalledPackageDetails dflags) all_pkgs) + +-- Takes a list of packages, and returns the list with dependencies included, +-- in reverse dependency order (a package appears before those it depends on). +closeDeps :: DynFlags + -> PackageConfigMap + -> [(InstalledUnitId, Maybe InstalledUnitId)] + -> IO [InstalledUnitId] +closeDeps dflags pkg_map ps + = throwErr dflags (closeDepsErr dflags pkg_map ps) + +throwErr :: DynFlags -> MaybeErr MsgDoc a -> IO a +throwErr dflags m + = case m of + Failed e -> throwGhcExceptionIO (CmdLineError (showSDoc dflags e)) + Succeeded r -> return r + +closeDepsErr :: DynFlags + -> PackageConfigMap + -> [(InstalledUnitId,Maybe InstalledUnitId)] + -> MaybeErr MsgDoc [InstalledUnitId] +closeDepsErr dflags pkg_map ps = foldM (add_package dflags pkg_map) [] ps + +-- internal helper +add_package :: DynFlags + -> PackageConfigMap + -> [PreloadUnitId] + -> (PreloadUnitId,Maybe PreloadUnitId) + -> MaybeErr MsgDoc [PreloadUnitId] +add_package dflags pkg_db ps (p, mb_parent) + | p `elem` ps = return ps -- Check if we've already added this package + | otherwise = + case lookupInstalledPackage' pkg_db p of + Nothing -> Failed (missingPackageMsg p <> + missingDependencyMsg mb_parent) + Just pkg -> do + -- Add the package's dependents also + ps' <- foldM add_unit_key ps (depends pkg) + return (p : ps') + where + add_unit_key ps key + = add_package dflags pkg_db ps (key, Just p) + +missingPackageMsg :: Outputable pkgid => pkgid -> SDoc +missingPackageMsg p = text "unknown package:" <+> ppr p + +missingDependencyMsg :: Maybe InstalledUnitId -> SDoc +missingDependencyMsg Nothing = Outputable.empty +missingDependencyMsg (Just parent) + = space <> parens (text "dependency of" <+> ftext (installedUnitIdFS parent)) + +-- ----------------------------------------------------------------------------- + +componentIdString :: DynFlags -> ComponentId -> Maybe String +componentIdString dflags cid = do + conf <- lookupInstalledPackage dflags (componentIdToInstalledUnitId cid) + return $ + case sourceLibName conf of + Nothing -> sourcePackageIdString conf + Just (PackageName libname) -> + packageNameString conf + ++ "-" ++ showVersion (packageVersion conf) + ++ ":" ++ unpackFS libname + +displayInstalledUnitId :: DynFlags -> InstalledUnitId -> Maybe String +displayInstalledUnitId dflags uid = + fmap sourcePackageIdString (lookupInstalledPackage dflags uid) + +-- | Will the 'Name' come from a dynamically linked library? +isDllName :: DynFlags -> Module -> Name -> Bool +-- Despite the "dll", I think this function just means that +-- the symbol comes from another dynamically-linked package, +-- and applies on all platforms, not just Windows +isDllName dflags this_mod name + | not (gopt Opt_ExternalDynamicRefs dflags) = False + | Just mod <- nameModule_maybe name + -- Issue #8696 - when GHC is dynamically linked, it will attempt + -- to load the dynamic dependencies of object files at compile + -- time for things like QuasiQuotes or + -- TemplateHaskell. Unfortunately, this interacts badly with + -- intra-package linking, because we don't generate indirect + -- (dynamic) symbols for intra-package calls. This means that if a + -- module with an intra-package call is loaded without its + -- dependencies, then GHC fails to link. This is the cause of # + -- + -- In the mean time, always force dynamic indirections to be + -- generated: when the module name isn't the module being + -- compiled, references are dynamic. + = case platformOS $ targetPlatform dflags of + -- On Windows the hack for #8696 makes it unlinkable. + -- As the entire setup of the code from Cmm down to the RTS expects + -- the use of trampolines for the imported functions only when + -- doing intra-package linking, e.g. refering to a symbol defined in the same + -- package should not use a trampoline. + -- I much rather have dynamic TH not supported than the entire Dynamic linking + -- not due to a hack. + -- Also not sure this would break on Windows anyway. + OSMinGW32 -> moduleUnitId mod /= moduleUnitId this_mod + + -- For the other platforms, still perform the hack + _ -> mod /= this_mod + + | otherwise = False -- no, it is not even an external name + +-- ----------------------------------------------------------------------------- +-- Displaying packages + +-- | Show (very verbose) package info +pprPackages :: DynFlags -> SDoc +pprPackages = pprPackagesWith pprPackageConfig + +pprPackagesWith :: (PackageConfig -> SDoc) -> DynFlags -> SDoc +pprPackagesWith pprIPI dflags = + vcat (intersperse (text "---") (map pprIPI (listPackageConfigMap dflags))) + +-- | Show simplified package info. +-- +-- The idea is to only print package id, and any information that might +-- be different from the package databases (exposure, trust) +pprPackagesSimple :: DynFlags -> SDoc +pprPackagesSimple = pprPackagesWith pprIPI + where pprIPI ipi = let i = installedUnitIdFS (unitId ipi) + e = if exposed ipi then text "E" else text " " + t = if trusted ipi then text "T" else text " " + in e <> t <> text " " <> ftext i + +-- | Show the mapping of modules to where they come from. +pprModuleMap :: ModuleToPkgConfAll -> SDoc +pprModuleMap mod_map = + vcat (map pprLine (Map.toList mod_map)) + where + pprLine (m,e) = ppr m $$ nest 50 (vcat (map (pprEntry m) (Map.toList e))) + pprEntry :: Outputable a => ModuleName -> (Module, a) -> SDoc + pprEntry m (m',o) + | m == moduleName m' = ppr (moduleUnitId m') <+> parens (ppr o) + | otherwise = ppr m' <+> parens (ppr o) + +fsPackageName :: PackageConfig -> FastString +fsPackageName = mkFastString . packageNameString + +-- | Given a fully instantiated 'UnitId', improve it into a +-- 'InstalledUnitId' if we can find it in the package database. +improveUnitId :: PackageConfigMap -> UnitId -> UnitId +improveUnitId _ uid@(DefiniteUnitId _) = uid -- short circuit +improveUnitId pkg_map uid = + -- Do NOT lookup indefinite ones, they won't be useful! + case lookupPackage' False pkg_map uid of + Nothing -> uid + Just pkg -> + -- Do NOT improve if the indefinite unit id is not + -- part of the closure unique set. See + -- Note [UnitId to InstalledUnitId improvement] + if installedPackageConfigId pkg `elementOfUniqSet` preloadClosure pkg_map + then packageConfigId pkg + else uid + +-- | Retrieve the 'PackageConfigMap' from 'DynFlags'; used +-- in the @hs-boot@ loop-breaker. +getPackageConfigMap :: DynFlags -> PackageConfigMap +getPackageConfigMap = pkgIdMap . pkgState diff --git a/compiler/main/Packages.hs-boot b/compiler/main/Packages.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/main/Packages.hs-boot @@ -0,0 +1,11 @@ +module Packages where +import GhcPrelude +import {-# SOURCE #-} DynFlags(DynFlags) +import {-# SOURCE #-} Module(ComponentId, UnitId, InstalledUnitId) +data PackageState +data PackageConfigMap +emptyPackageState :: PackageState +componentIdString :: DynFlags -> ComponentId -> Maybe String +displayInstalledUnitId :: DynFlags -> InstalledUnitId -> Maybe String +improveUnitId :: PackageConfigMap -> UnitId -> UnitId +getPackageConfigMap :: DynFlags -> PackageConfigMap diff --git a/compiler/main/PipelineMonad.hs b/compiler/main/PipelineMonad.hs new file mode 100644 --- /dev/null +++ b/compiler/main/PipelineMonad.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE NamedFieldPuns #-} +-- | The CompPipeline monad and associated ops +-- +-- Defined in separate module so that it can safely be imported from Hooks +module PipelineMonad ( + CompPipeline(..), evalP + , PhasePlus(..) + , PipeEnv(..), PipeState(..), PipelineOutput(..) + , getPipeEnv, getPipeState, setDynFlags, setModLocation, setForeignOs + ) where + +import GhcPrelude + +import MonadUtils +import Outputable +import DynFlags +import DriverPhases +import HscTypes +import Module +import FileCleanup (TempFileLifetime) + +import Control.Monad + +newtype CompPipeline a = P { unP :: PipeEnv -> PipeState -> IO (PipeState, a) } + +evalP :: CompPipeline a -> PipeEnv -> PipeState -> IO a +evalP f env st = liftM snd $ unP f env st + +instance Functor CompPipeline where + fmap = liftM + +instance Applicative CompPipeline where + pure a = P $ \_env state -> return (state, a) + (<*>) = ap + +instance Monad CompPipeline where + P m >>= k = P $ \env state -> do (state',a) <- m env state + unP (k a) env state' + +instance MonadIO CompPipeline where + liftIO m = P $ \_env state -> do a <- m; return (state, a) + +data PhasePlus = RealPhase Phase + | HscOut HscSource ModuleName HscStatus + +instance Outputable PhasePlus where + ppr (RealPhase p) = ppr p + ppr (HscOut {}) = text "HscOut" + +-- ----------------------------------------------------------------------------- +-- The pipeline uses a monad to carry around various bits of information + +-- PipeEnv: invariant information passed down +data PipeEnv = PipeEnv { + stop_phase :: Phase, -- ^ Stop just before this phase + src_filename :: String, -- ^ basename of original input source + src_basename :: String, -- ^ basename of original input source + src_suffix :: String, -- ^ its extension + output_spec :: PipelineOutput -- ^ says where to put the pipeline output + } + +-- PipeState: information that might change during a pipeline run +data PipeState = PipeState { + hsc_env :: HscEnv, + -- ^ only the DynFlags change in the HscEnv. The DynFlags change + -- at various points, for example when we read the OPTIONS_GHC + -- pragmas in the Cpp phase. + maybe_loc :: Maybe ModLocation, + -- ^ the ModLocation. This is discovered during compilation, + -- in the Hsc phase where we read the module header. + foreign_os :: [FilePath] + -- ^ additional object files resulting from compiling foreign + -- code. They come from two sources: foreign stubs, and + -- add{C,Cxx,Objc,Objcxx}File from template haskell + } + +data PipelineOutput + = Temporary TempFileLifetime + -- ^ Output should be to a temporary file: we're going to + -- run more compilation steps on this output later. + | Persistent + -- ^ We want a persistent file, i.e. a file in the current directory + -- derived from the input filename, but with the appropriate extension. + -- eg. in "ghc -c Foo.hs" the output goes into ./Foo.o. + | SpecificFile + -- ^ The output must go into the specific outputFile in DynFlags. + -- We don't store the filename in the constructor as it changes + -- when doing -dynamic-too. + deriving Show + +getPipeEnv :: CompPipeline PipeEnv +getPipeEnv = P $ \env state -> return (state, env) + +getPipeState :: CompPipeline PipeState +getPipeState = P $ \_env state -> return (state, state) + +instance HasDynFlags CompPipeline where + getDynFlags = P $ \_env state -> return (state, hsc_dflags (hsc_env state)) + +setDynFlags :: DynFlags -> CompPipeline () +setDynFlags dflags = P $ \_env state -> + return (state{hsc_env= (hsc_env state){ hsc_dflags = dflags }}, ()) + +setModLocation :: ModLocation -> CompPipeline () +setModLocation loc = P $ \_env state -> + return (state{ maybe_loc = Just loc }, ()) + +setForeignOs :: [FilePath] -> CompPipeline () +setForeignOs os = P $ \_env state -> + return (state{ foreign_os = os }, ()) diff --git a/compiler/main/PlatformConstants.hs b/compiler/main/PlatformConstants.hs new file mode 100644 --- /dev/null +++ b/compiler/main/PlatformConstants.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE CPP #-} + +------------------------------------------------------------------------------- +-- +-- | Platform constants +-- +-- (c) The University of Glasgow 2013 +-- +------------------------------------------------------------------------------- + +module PlatformConstants (PlatformConstants(..)) where + +import GhcPrelude + +-- Produced by deriveConstants +#include "GHCConstantsHaskellType.hs" + diff --git a/compiler/main/Plugins.hs b/compiler/main/Plugins.hs new file mode 100644 --- /dev/null +++ b/compiler/main/Plugins.hs @@ -0,0 +1,241 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE CPP #-} +module Plugins ( + -- * Plugins + Plugin(..) + , defaultPlugin + , CommandLineOption + -- ** Recompilation checking + , purePlugin, impurePlugin, flagRecompile + , PluginRecompile(..) + + -- * Plugin types + -- ** Frontend plugins + , FrontendPlugin(..), defaultFrontendPlugin, FrontendPluginAction + -- ** Core plugins + -- | Core plugins allow plugins to register as a Core-to-Core pass. + , CorePlugin + -- ** Typechecker plugins + -- | Typechecker plugins allow plugins to provide evidence to the + -- typechecker. + , TcPlugin + -- ** Source plugins + -- | GHC offers a number of points where plugins can access and modify its + -- front-end (\"source\") representation. These include: + -- + -- - access to the parser result with 'parsedResultAction' + -- - access to the renamed AST with 'renamedResultAction' + -- - access to the typechecked AST with 'typeCheckResultAction' + -- - access to the Template Haskell splices with 'spliceRunAction' + -- - access to loaded interface files with 'interfaceLoadAction' + -- + , keepRenamedSource + + -- * Internal + , PluginWithArgs(..), plugins, pluginRecompile' + , LoadedPlugin(..), lpModuleName + , StaticPlugin(..) + , mapPlugins, withPlugins, withPlugins_ + ) where + +import GhcPrelude + +import {-# SOURCE #-} CoreMonad ( CoreToDo, CoreM ) +import qualified TcRnTypes +import TcRnTypes ( TcGblEnv, IfM, TcM, tcg_rn_decls, tcg_rn_exports ) +import HsSyn +import DynFlags +import HscTypes +import GhcMonad +import DriverPhases +import Module ( ModuleName, Module(moduleName)) +import Fingerprint +import Data.List +import Outputable (Outputable(..), text, (<+>)) + +--Qualified import so we can define a Semigroup instance +-- but it doesn't clash with Outputable.<> +import qualified Data.Semigroup + +import Control.Monad + +-- | Command line options gathered from the -PModule.Name:stuff syntax +-- are given to you as this type +type CommandLineOption = String + +-- | 'Plugin' is the compiler plugin data type. Try to avoid +-- constructing one of these directly, and just modify some fields of +-- 'defaultPlugin' instead: this is to try and preserve source-code +-- compatibility when we add fields to this. +-- +-- Nonetheless, this API is preliminary and highly likely to change in +-- the future. +data Plugin = Plugin { + installCoreToDos :: CorePlugin + -- ^ Modify the Core pipeline that will be used for compilation. + -- This is called as the Core pipeline is built for every module + -- being compiled, and plugins get the opportunity to modify the + -- pipeline in a nondeterministic order. + , tcPlugin :: TcPlugin + -- ^ An optional typechecker plugin, which may modify the + -- behaviour of the constraint solver. + , pluginRecompile :: [CommandLineOption] -> IO PluginRecompile + -- ^ Specify how the plugin should affect recompilation. + , parsedResultAction :: [CommandLineOption] -> ModSummary -> HsParsedModule + -> Hsc HsParsedModule + -- ^ Modify the module when it is parsed. This is called by + -- HscMain when the parsing is successful. + , renamedResultAction :: [CommandLineOption] -> TcGblEnv + -> HsGroup GhcRn -> TcM (TcGblEnv, HsGroup GhcRn) + -- ^ Modify each group after it is renamed. This is called after each + -- `HsGroup` has been renamed. + , typeCheckResultAction :: [CommandLineOption] -> ModSummary -> TcGblEnv + -> TcM TcGblEnv + -- ^ Modify the module when it is type checked. This is called at the + -- very end of typechecking. + , spliceRunAction :: [CommandLineOption] -> LHsExpr GhcTc + -> TcM (LHsExpr GhcTc) + -- ^ Modify the TH splice or quasiqoute before it is run. + , interfaceLoadAction :: forall lcl . [CommandLineOption] -> ModIface + -> IfM lcl ModIface + -- ^ Modify an interface that have been loaded. This is called by + -- LoadIface when an interface is successfully loaded. Not applied to + -- the loading of the plugin interface. Tools that rely on information from + -- modules other than the currently compiled one should implement this + -- function. + } + +-- Note [Source plugins] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The `Plugin` datatype have been extended by fields that allow access to the +-- different inner representations that are generated during the compilation +-- process. These fields are `parsedResultAction`, `renamedResultAction`, +-- `typeCheckResultAction`, `spliceRunAction` and `interfaceLoadAction`. +-- +-- The main purpose of these plugins is to help tool developers. They allow +-- development tools to extract the information about the source code of a big +-- Haskell project during the normal build procedure. In this case the plugin +-- acts as the tools access point to the compiler that can be controlled by +-- compiler flags. This is important because the manipulation of compiler flags +-- is supported by most build environment. +-- +-- For the full discussion, check the full proposal at: +-- https://gitlab.haskell.org/ghc/ghc/wikis/extended-plugins-proposal + +data PluginWithArgs = PluginWithArgs + { paPlugin :: Plugin + -- ^ the actual callable plugin + , paArguments :: [CommandLineOption] + -- ^ command line arguments for the plugin + } + +-- | A plugin with its arguments. The result of loading the plugin. +data LoadedPlugin = LoadedPlugin + { lpPlugin :: PluginWithArgs + -- ^ the actual plugin together with its commandline arguments + , lpModule :: ModIface + -- ^ the module containing the plugin + } + +-- | A static plugin with its arguments. For registering compiled-in plugins +-- through the GHC API. +data StaticPlugin = StaticPlugin + { spPlugin :: PluginWithArgs + -- ^ the actual plugin together with its commandline arguments + } + +lpModuleName :: LoadedPlugin -> ModuleName +lpModuleName = moduleName . mi_module . lpModule + +pluginRecompile' :: PluginWithArgs -> IO PluginRecompile +pluginRecompile' (PluginWithArgs plugin args) = pluginRecompile plugin args + +data PluginRecompile = ForceRecompile | NoForceRecompile | MaybeRecompile Fingerprint + +instance Outputable PluginRecompile where + ppr ForceRecompile = text "ForceRecompile" + ppr NoForceRecompile = text "NoForceRecompile" + ppr (MaybeRecompile fp) = text "MaybeRecompile" <+> ppr fp + +instance Semigroup PluginRecompile where + ForceRecompile <> _ = ForceRecompile + NoForceRecompile <> r = r + MaybeRecompile fp <> NoForceRecompile = MaybeRecompile fp + MaybeRecompile fp <> MaybeRecompile fp' = MaybeRecompile (fingerprintFingerprints [fp, fp']) + MaybeRecompile _fp <> ForceRecompile = ForceRecompile + +instance Monoid PluginRecompile where + mempty = NoForceRecompile + +type CorePlugin = [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] +type TcPlugin = [CommandLineOption] -> Maybe TcRnTypes.TcPlugin + +purePlugin, impurePlugin, flagRecompile :: [CommandLineOption] -> IO PluginRecompile +purePlugin _args = return NoForceRecompile + +impurePlugin _args = return ForceRecompile + +flagRecompile = + return . MaybeRecompile . fingerprintFingerprints . map fingerprintString . sort + +-- | Default plugin: does nothing at all, except for marking that safe +-- inference has failed unless @-fplugin-trustworthy@ is passed. For +-- compatibility reaso you should base all your plugin definitions on this +-- default value. +defaultPlugin :: Plugin +defaultPlugin = Plugin { + installCoreToDos = const return + , tcPlugin = const Nothing + , pluginRecompile = impurePlugin + , renamedResultAction = \_ env grp -> return (env, grp) + , parsedResultAction = \_ _ -> return + , typeCheckResultAction = \_ _ -> return + , spliceRunAction = \_ -> return + , interfaceLoadAction = \_ -> return + } + + +-- | A renamer plugin which mades the renamed source available in +-- a typechecker plugin. +keepRenamedSource :: [CommandLineOption] -> TcGblEnv + -> HsGroup GhcRn -> TcM (TcGblEnv, HsGroup GhcRn) +keepRenamedSource _ gbl_env group = + return (gbl_env { tcg_rn_decls = update (tcg_rn_decls gbl_env) + , tcg_rn_exports = update_exports (tcg_rn_exports gbl_env) }, group) + where + update_exports Nothing = Just [] + update_exports m = m + + update Nothing = Just emptyRnGroup + update m = m + + +type PluginOperation m a = Plugin -> [CommandLineOption] -> a -> m a +type ConstPluginOperation m a = Plugin -> [CommandLineOption] -> a -> m () + +plugins :: DynFlags -> [PluginWithArgs] +plugins df = + map lpPlugin (cachedPlugins df) ++ + map spPlugin (staticPlugins df) + +-- | Perform an operation by using all of the plugins in turn. +withPlugins :: Monad m => DynFlags -> PluginOperation m a -> a -> m a +withPlugins df transformation input = foldM go input (plugins df) + where + go arg (PluginWithArgs p opts) = transformation p opts arg + +mapPlugins :: DynFlags -> (Plugin -> [CommandLineOption] -> a) -> [a] +mapPlugins df f = map (\(PluginWithArgs p opts) -> f p opts) (plugins df) + +-- | Perform a constant operation by using all of the plugins in turn. +withPlugins_ :: Monad m => DynFlags -> ConstPluginOperation m a -> a -> m () +withPlugins_ df transformation input + = mapM_ (\(PluginWithArgs p opts) -> transformation p opts input) + (plugins df) + +type FrontendPluginAction = [String] -> [(String, Maybe Phase)] -> Ghc () +data FrontendPlugin = FrontendPlugin { + frontend :: FrontendPluginAction + } +defaultFrontendPlugin :: FrontendPlugin +defaultFrontendPlugin = FrontendPlugin { frontend = \_ _ -> return () } diff --git a/compiler/main/Plugins.hs-boot b/compiler/main/Plugins.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/main/Plugins.hs-boot @@ -0,0 +1,10 @@ +-- The plugins datatype is stored in DynFlags, so it needs to be +-- exposed without importing all of its implementation. +module Plugins where + +import GhcPrelude () + +data Plugin + +data LoadedPlugin +data StaticPlugin diff --git a/compiler/main/SysTools/BaseDir.hs b/compiler/main/SysTools/BaseDir.hs new file mode 100644 --- /dev/null +++ b/compiler/main/SysTools/BaseDir.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{- +----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow 2001-2017 +-- +-- Finding the compiler's base directory. +-- +----------------------------------------------------------------------------- +-} + +module SysTools.BaseDir + ( expandTopDir, expandToolDir + , findTopDir, findToolDir + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import Panic + +import System.Environment (lookupEnv) +import System.FilePath +import Data.List + +-- POSIX +#if defined(darwin_HOST_OS) || defined(linux_HOST_OS) || defined(freebsd_HOST_OS) +import System.Environment (getExecutablePath) +#endif + +-- Windows +#if defined(mingw32_HOST_OS) +import System.Environment (getExecutablePath) +import System.Directory (doesDirectoryExist) +#endif + +#if defined(mingw32_HOST_OS) +# if defined(i386_HOST_ARCH) +# define WINDOWS_CCONV stdcall +# elif defined(x86_64_HOST_ARCH) +# define WINDOWS_CCONV ccall +# else +# error Unknown mingw32 arch +# endif +#endif + +{- +Note [topdir: How GHC finds its files] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +GHC needs various support files (library packages, RTS etc), plus +various auxiliary programs (cp, gcc, etc). It starts by finding topdir, +the root of GHC's support files + +On Unix: + - ghc always has a shell wrapper that passes a -B option + +On Windows: + - ghc never has a shell wrapper. + - we can find the location of the ghc binary, which is + $topdir//.exe + where may be "ghc", "ghc-stage2", or similar + - we strip off the "/.exe" to leave $topdir. + +from topdir we can find package.conf, ghc-asm, etc. + + +Note [tooldir: How GHC finds mingw on Windows] + +GHC has some custom logic on Windows for finding the mingw +toolchain and perl. Depending on whether GHC is built +with the make build system or Hadrian, and on whether we're +running a bindist, we might find the mingw toolchain and perl +either under $topdir/../{mingw, perl}/ or +$topdir/../../{mingw, perl}/. + +-} + +-- | Expand occurrences of the @$topdir@ interpolation in a string. +expandTopDir :: FilePath -> String -> String +expandTopDir = expandPathVar "topdir" + +-- | Expand occurrences of the @$tooldir@ interpolation in a string +-- on Windows, leave the string untouched otherwise. +expandToolDir :: Maybe FilePath -> String -> String +#if defined(mingw32_HOST_OS) +expandToolDir (Just tool_dir) s = expandPathVar "tooldir" tool_dir s +expandToolDir Nothing _ = panic "Could not determine $tooldir" +#else +expandToolDir _ s = s +#endif + +-- | @expandPathVar var value str@ +-- +-- replaces occurences of variable @$var@ with @value@ in str. +expandPathVar :: String -> FilePath -> String -> String +expandPathVar var value str + | Just str' <- stripPrefix ('$':var) str + , null str' || isPathSeparator (head str') + = value ++ expandPathVar var value str' +expandPathVar var value (x:xs) = x : expandPathVar var value xs +expandPathVar _ _ [] = [] + +-- | Returns a Unix-format path pointing to TopDir. +findTopDir :: Maybe String -- Maybe TopDir path (without the '-B' prefix). + -> IO String -- TopDir (in Unix format '/' separated) +findTopDir (Just minusb) = return (normalise minusb) +findTopDir Nothing + = do -- The _GHC_TOP_DIR environment variable can be used to specify + -- the top dir when the -B argument is not specified. It is not + -- intended for use by users, it was added specifically for the + -- purpose of running GHC within GHCi. + maybe_env_top_dir <- lookupEnv "_GHC_TOP_DIR" + case maybe_env_top_dir of + Just env_top_dir -> return env_top_dir + Nothing -> do + -- Get directory of executable + maybe_exec_dir <- getBaseDir + case maybe_exec_dir of + -- "Just" on Windows, "Nothing" on unix + Nothing -> throwGhcExceptionIO $ + InstallationError "missing -B option" + Just dir -> return dir + +getBaseDir :: IO (Maybe String) + +#if defined(mingw32_HOST_OS) + +-- locate the "base dir" when given the path +-- to the real ghc executable (as opposed to symlink) +-- that is running this function. +rootDir :: FilePath -> FilePath +rootDir = takeDirectory . takeDirectory . normalise + +getBaseDir = Just . (\p -> p "lib") . rootDir <$> getExecutablePath +#elif defined(darwin_HOST_OS) || defined(linux_HOST_OS) || defined(freebsd_HOST_OS) +-- on unix, this is a bit more confusing. +-- The layout right now is something like +-- +-- /bin/ghc-X.Y.Z <- wrapper script (1) +-- /bin/ghc <- symlink to wrapper script (2) +-- /lib/ghc-X.Y.Z/bin/ghc <- ghc executable (3) +-- /lib/ghc-X.Y.Z <- $topdir (4) +-- +-- As such, we first need to find the absolute location to the +-- binary. +-- +-- getExecutablePath will return (3). One takeDirectory will +-- give use /lib/ghc-X.Y.Z/bin, and another will give us (4). +-- +-- This of course only works due to the current layout. If +-- the layout is changed, such that we have ghc-X.Y.Z/{bin,lib} +-- this would need to be changed accordingly. +-- +getBaseDir = Just . (\p -> p "lib") . takeDirectory . takeDirectory <$> getExecutablePath +#else +getBaseDir = return Nothing +#endif + +-- See Note [tooldir: How GHC finds mingw and perl on Windows] +-- Returns @Nothing@ when not on Windows. +-- When called on Windows, it either throws an error when the +-- tooldir can't be located, or returns @Just tooldirpath@. +findToolDir + :: FilePath -- ^ topdir + -> IO (Maybe FilePath) +#if defined(mingw32_HOST_OS) +findToolDir top_dir = go 0 (top_dir "..") + where maxDepth = 3 + go :: Int -> FilePath -> IO (Maybe FilePath) + go k path + | k == maxDepth = throwGhcExceptionIO $ + InstallationError "could not detect mingw toolchain" + | otherwise = do + oneLevel <- doesDirectoryExist (path "mingw") + if oneLevel + then return (Just path) + else go (k+1) (path "..") +#else +findToolDir _ = return Nothing +#endif diff --git a/compiler/main/SysTools/Terminal.hs b/compiler/main/SysTools/Terminal.hs new file mode 100644 --- /dev/null +++ b/compiler/main/SysTools/Terminal.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +module SysTools.Terminal (stderrSupportsAnsiColors) where + +import GhcPrelude + +#if defined MIN_VERSION_terminfo +import Control.Exception (catch) +import Data.Maybe (fromMaybe) +import System.Console.Terminfo (SetupTermError, Terminal, getCapability, + setupTermFromEnv, termColors) +import System.Posix (queryTerminal, stdError) +#elif defined mingw32_HOST_OS +import Control.Exception (catch, try) +import Data.Bits ((.|.), (.&.)) +import Data.List (isInfixOf, isPrefixOf, isSuffixOf) +import Foreign (FunPtr, Ptr, allocaBytes, castPtrToFunPtr, + peek, plusPtr, sizeOf, with) +import Foreign.C (CInt(..), CWchar, peekCWStringLen) +import qualified Graphics.Win32 as Win32 +import qualified System.Win32 as Win32 +#endif + +#if defined mingw32_HOST_OS && !defined WINAPI +# if defined i386_HOST_ARCH +# define WINAPI stdcall +# elif defined x86_64_HOST_ARCH +# define WINAPI ccall +# else +# error unknown architecture +# endif +#endif + +-- | Check if ANSI escape sequences can be used to control color in stderr. +stderrSupportsAnsiColors :: IO Bool +stderrSupportsAnsiColors = do +#if defined MIN_VERSION_terminfo + queryTerminal stdError `andM` do + (termSupportsColors <$> setupTermFromEnv) + `catch` \ (_ :: SetupTermError) -> + pure False + + where + + andM :: Monad m => m Bool -> m Bool -> m Bool + andM mx my = do + x <- mx + if x + then my + else pure x + + termSupportsColors :: Terminal -> Bool + termSupportsColors term = fromMaybe 0 (getCapability term termColors) > 0 + +#elif defined mingw32_HOST_OS + h <- Win32.getStdHandle Win32.sTD_ERROR_HANDLE + `catch` \ (_ :: IOError) -> + pure Win32.nullHANDLE + if h == Win32.nullHANDLE + then pure False + else do + eMode <- try (getConsoleMode h) + case eMode of + Left (_ :: IOError) -> queryCygwinTerminal h + Right mode + | modeHasVTP mode -> pure True + | otherwise -> enableVTP h mode + + where + + queryCygwinTerminal :: Win32.HANDLE -> IO Bool + queryCygwinTerminal h = do + fileType <- Win32.getFileType h + if fileType /= Win32.fILE_TYPE_PIPE + then pure False + else do + fn <- getFileNameByHandle h + pure (("\\cygwin-" `isPrefixOf` fn || "\\msys-" `isPrefixOf` fn) && + "-pty" `isInfixOf` fn && + "-master" `isSuffixOf` fn) + `catch` \ (_ :: IOError) -> + pure False + + enableVTP :: Win32.HANDLE -> Win32.DWORD -> IO Bool + enableVTP h mode = do + setConsoleMode h (modeAddVTP mode) + modeHasVTP <$> getConsoleMode h + `catch` \ (_ :: IOError) -> + pure False + + modeHasVTP :: Win32.DWORD -> Bool + modeHasVTP mode = mode .&. eNABLE_VIRTUAL_TERMINAL_PROCESSING /= 0 + + modeAddVTP :: Win32.DWORD -> Win32.DWORD + modeAddVTP mode = mode .|. eNABLE_VIRTUAL_TERMINAL_PROCESSING + +eNABLE_VIRTUAL_TERMINAL_PROCESSING :: Win32.DWORD +eNABLE_VIRTUAL_TERMINAL_PROCESSING = 0x0004 + +getConsoleMode :: Win32.HANDLE -> IO Win32.DWORD +getConsoleMode h = with 64 $ \ mode -> do + Win32.failIfFalse_ "GetConsoleMode" (c_GetConsoleMode h mode) + peek mode + +setConsoleMode :: Win32.HANDLE -> Win32.DWORD -> IO () +setConsoleMode h mode = do + Win32.failIfFalse_ "SetConsoleMode" (c_SetConsoleMode h mode) + +foreign import WINAPI unsafe "windows.h GetConsoleMode" c_GetConsoleMode + :: Win32.HANDLE -> Ptr Win32.DWORD -> IO Win32.BOOL + +foreign import WINAPI unsafe "windows.h SetConsoleMode" c_SetConsoleMode + :: Win32.HANDLE -> Win32.DWORD -> IO Win32.BOOL + +fileNameInfo :: CInt +fileNameInfo = 2 + +mAX_PATH :: Num a => a +mAX_PATH = 260 + +getFileNameByHandle :: Win32.HANDLE -> IO String +getFileNameByHandle h = do + let sizeOfDWORD = sizeOf (undefined :: Win32.DWORD) + let sizeOfWchar = sizeOf (undefined :: CWchar) + -- note: implicitly assuming that DWORD has stronger alignment than wchar_t + let bufSize = sizeOfDWORD + mAX_PATH * sizeOfWchar + allocaBytes bufSize $ \ buf -> do + getFileInformationByHandleEx h fileNameInfo buf (fromIntegral bufSize) + len :: Win32.DWORD <- peek buf + let len' = fromIntegral len `div` sizeOfWchar + peekCWStringLen (buf `plusPtr` sizeOfDWORD, min len' mAX_PATH) + +getFileInformationByHandleEx + :: Win32.HANDLE -> CInt -> Ptr a -> Win32.DWORD -> IO () +getFileInformationByHandleEx h cls buf bufSize = do + lib <- Win32.getModuleHandle (Just "kernel32.dll") + ptr <- Win32.getProcAddress lib "GetFileInformationByHandleEx" + let c_GetFileInformationByHandleEx = + mk_GetFileInformationByHandleEx (castPtrToFunPtr ptr) + Win32.failIfFalse_ "getFileInformationByHandleEx" + (c_GetFileInformationByHandleEx h cls buf bufSize) + +type F_GetFileInformationByHandleEx a = + Win32.HANDLE -> CInt -> Ptr a -> Win32.DWORD -> IO Win32.BOOL + +foreign import WINAPI "dynamic" + mk_GetFileInformationByHandleEx + :: FunPtr (F_GetFileInformationByHandleEx a) + -> F_GetFileInformationByHandleEx a + +#else + pure False +#endif diff --git a/compiler/nativeGen/NCG.h b/compiler/nativeGen/NCG.h new file mode 100644 --- /dev/null +++ b/compiler/nativeGen/NCG.h @@ -0,0 +1,11 @@ +/* ----------------------------------------------------------------------------- + + (c) The University of Glasgow, 1994-2004 + + Native-code generator header file - just useful macros for now. + + -------------------------------------------------------------------------- */ + +#pragma once + +#include "ghc_boot_platform.h" diff --git a/compiler/parser/ApiAnnotation.hs b/compiler/parser/ApiAnnotation.hs new file mode 100644 --- /dev/null +++ b/compiler/parser/ApiAnnotation.hs @@ -0,0 +1,364 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +module ApiAnnotation ( + getAnnotation, getAndRemoveAnnotation, + getAnnotationComments,getAndRemoveAnnotationComments, + ApiAnns, + ApiAnnKey, + AnnKeywordId(..), + AnnotationComment(..), + IsUnicodeSyntax(..), + unicodeAnn, + HasE(..), + LRdrName -- Exists for haddocks only + ) where + +import GhcPrelude + +import RdrName +import Outputable +import SrcLoc +import qualified Data.Map as Map +import Data.Data + + +{- +Note [Api annotations] +~~~~~~~~~~~~~~~~~~~~~~ +Given a parse tree of a Haskell module, how can we reconstruct +the original Haskell source code, retaining all whitespace and +source code comments? We need to track the locations of all +elements from the original source: this includes keywords such as +'let' / 'in' / 'do' etc as well as punctuation such as commas and +braces, and also comments. We collectively refer to this +metadata as the "API annotations". + +Rather than annotate the resulting parse tree with these locations +directly (this would be a major change to some fairly core data +structures in GHC), we instead capture locations for these elements in a +structure separate from the parse tree, and returned in the +pm_annotations field of the ParsedModule type. + +The full ApiAnns type is + +> type ApiAnns = ( Map.Map ApiAnnKey [SrcSpan] -- non-comments +> , Map.Map SrcSpan [Located AnnotationComment]) -- comments + +NON-COMMENT ELEMENTS + +Intuitively, every AST element directly contains a bag of keywords +(keywords can show up more than once in a node: a semicolon i.e. newline +can show up multiple times before the next AST element), each of which +needs to be associated with its location in the original source code. + +Consequently, the structure that records non-comment elements is logically +a two level map, from the SrcSpan of the AST element containing it, to +a map from keywords ('AnnKeyWord') to all locations of the keyword directly +in the AST element: + +> type ApiAnnKey = (SrcSpan,AnnKeywordId) +> +> Map.Map ApiAnnKey [SrcSpan] + +So + +> let x = 1 in 2 *x + +would result in the AST element + + L span (HsLet (binds for x = 1) (2 * x)) + +and the annotations + + (span,AnnLet) having the location of the 'let' keyword + (span,AnnEqual) having the location of the '=' sign + (span,AnnIn) having the location of the 'in' keyword + +For any given element in the AST, there is only a set number of +keywords that are applicable for it (e.g., you'll never see an +'import' keyword associated with a let-binding.) The set of allowed +keywords is documented in a comment associated with the constructor +of a given AST element, although the ground truth is in Parser +and RdrHsSyn (which actually add the annotations; see #13012). + +COMMENT ELEMENTS + +Every comment is associated with a *located* AnnotationComment. +We associate comments with the lowest (most specific) AST element +enclosing them: + +> Map.Map SrcSpan [Located AnnotationComment] + +PARSER STATE + +There are three fields in PState (the parser state) which play a role +with annotations. + +> annotations :: [(ApiAnnKey,[SrcSpan])], +> comment_q :: [Located AnnotationComment], +> annotations_comments :: [(SrcSpan,[Located AnnotationComment])] + +The 'annotations' and 'annotations_comments' fields are simple: they simply +accumulate annotations that will end up in 'ApiAnns' at the end +(after they are passed to Map.fromList). + +The 'comment_q' field captures comments as they are seen in the token stream, +so that when they are ready to be allocated via the parser they are +available (at the time we lex a comment, we don't know what the enclosing +AST node of it is, so we can't associate it with a SrcSpan in +annotations_comments). + +PARSER EMISSION OF ANNOTATIONS + +The parser interacts with the lexer using the function + +> addAnnotation :: SrcSpan -> AnnKeywordId -> SrcSpan -> P () + +which takes the AST element SrcSpan, the annotation keyword and the +target SrcSpan. + +This adds the annotation to the `annotations` field of `PState` and +transfers any comments in `comment_q` WHICH ARE ENCLOSED by +the SrcSpan of this element to the `annotations_comments` +field. (Comments which are outside of this annotation are deferred +until later. 'allocateComments' in 'Lexer' is responsible for +making sure we only attach comments that actually fit in the 'SrcSpan'.) + +The wiki page describing this feature is +https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations + +-} +-- --------------------------------------------------------------------- + +-- If you update this, update the Note [Api annotations] above +type ApiAnns = ( Map.Map ApiAnnKey [SrcSpan] + , Map.Map SrcSpan [Located AnnotationComment]) + +-- If you update this, update the Note [Api annotations] above +type ApiAnnKey = (SrcSpan,AnnKeywordId) + + +-- | Retrieve a list of annotation 'SrcSpan's based on the 'SrcSpan' +-- of the annotated AST element, and the known type of the annotation. +getAnnotation :: ApiAnns -> SrcSpan -> AnnKeywordId -> [SrcSpan] +getAnnotation (anns,_) span ann + = case Map.lookup (span,ann) anns of + Nothing -> [] + Just ss -> ss + +-- | Retrieve a list of annotation 'SrcSpan's based on the 'SrcSpan' +-- of the annotated AST element, and the known type of the annotation. +-- The list is removed from the annotations. +getAndRemoveAnnotation :: ApiAnns -> SrcSpan -> AnnKeywordId + -> ([SrcSpan],ApiAnns) +getAndRemoveAnnotation (anns,cs) span ann + = case Map.lookup (span,ann) anns of + Nothing -> ([],(anns,cs)) + Just ss -> (ss,(Map.delete (span,ann) anns,cs)) + +-- |Retrieve the comments allocated to the current 'SrcSpan' +-- +-- Note: A given 'SrcSpan' may appear in multiple AST elements, +-- beware of duplicates +getAnnotationComments :: ApiAnns -> SrcSpan -> [Located AnnotationComment] +getAnnotationComments (_,anns) span = + case Map.lookup span anns of + Just cs -> cs + Nothing -> [] + +-- |Retrieve the comments allocated to the current 'SrcSpan', and +-- remove them from the annotations +getAndRemoveAnnotationComments :: ApiAnns -> SrcSpan + -> ([Located AnnotationComment],ApiAnns) +getAndRemoveAnnotationComments (anns,canns) span = + case Map.lookup span canns of + Just cs -> (cs,(anns,Map.delete span canns)) + Nothing -> ([],(anns,canns)) + +-- -------------------------------------------------------------------- + +-- | API Annotations exist so that tools can perform source to source +-- conversions of Haskell code. They are used to keep track of the +-- various syntactic keywords that are not captured in the existing +-- AST. +-- +-- The annotations, together with original source comments are made +-- available in the @'pm_annotations'@ field of @'GHC.ParsedModule'@. +-- Comments are only retained if @'Opt_KeepRawTokenStream'@ is set in +-- @'DynFlags.DynFlags'@ before parsing. +-- +-- The wiki page describing this feature is +-- https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations +-- +-- Note: in general the names of these are taken from the +-- corresponding token, unless otherwise noted +-- See note [Api annotations] above for details of the usage +data AnnKeywordId + = AnnAnyclass + | AnnAs + | AnnAt + | AnnBang -- ^ '!' + | AnnBackquote -- ^ '`' + | AnnBy + | AnnCase -- ^ case or lambda case + | AnnClass + | AnnClose -- ^ '\#)' or '\#-}' etc + | AnnCloseB -- ^ '|)' + | AnnCloseBU -- ^ '|)', unicode variant + | AnnCloseC -- ^ '}' + | AnnCloseQ -- ^ '|]' + | AnnCloseQU -- ^ '|]', unicode variant + | AnnCloseP -- ^ ')' + | AnnCloseS -- ^ ']' + | AnnColon + | AnnComma -- ^ as a list separator + | AnnCommaTuple -- ^ in a RdrName for a tuple + | AnnDarrow -- ^ '=>' + | AnnDarrowU -- ^ '=>', unicode variant + | AnnData + | AnnDcolon -- ^ '::' + | AnnDcolonU -- ^ '::', unicode variant + | AnnDefault + | AnnDeriving + | AnnDo + | AnnDot -- ^ '.' + | AnnDotdot -- ^ '..' + | AnnElse + | AnnEqual + | AnnExport + | AnnFamily + | AnnForall + | AnnForallU -- ^ Unicode variant + | AnnForeign + | AnnFunId -- ^ for function name in matches where there are + -- multiple equations for the function. + | AnnGroup + | AnnHeader -- ^ for CType + | AnnHiding + | AnnIf + | AnnImport + | AnnIn + | AnnInfix -- ^ 'infix' or 'infixl' or 'infixr' + | AnnInstance + | AnnLam + | AnnLarrow -- ^ '<-' + | AnnLarrowU -- ^ '<-', unicode variant + | AnnLet + | AnnMdo + | AnnMinus -- ^ '-' + | AnnModule + | AnnNewtype + | AnnName -- ^ where a name loses its location in the AST, this carries it + | AnnOf + | AnnOpen -- ^ '(\#' or '{-\# LANGUAGE' etc + | AnnOpenB -- ^ '(|' + | AnnOpenBU -- ^ '(|', unicode variant + | AnnOpenC -- ^ '{' + | AnnOpenE -- ^ '[e|' or '[e||' + | AnnOpenEQ -- ^ '[|' + | AnnOpenEQU -- ^ '[|', unicode variant + | AnnOpenP -- ^ '(' + | AnnOpenPE -- ^ '$(' + | AnnOpenPTE -- ^ '$$(' + | AnnOpenS -- ^ '[' + | AnnPackageName + | AnnPattern + | AnnProc + | AnnQualified + | AnnRarrow -- ^ '->' + | AnnRarrowU -- ^ '->', unicode variant + | AnnRec + | AnnRole + | AnnSafe + | AnnSemi -- ^ ';' + | AnnSimpleQuote -- ^ ''' + | AnnSignature + | AnnStatic -- ^ 'static' + | AnnStock + | AnnThen + | AnnThIdSplice -- ^ '$' + | AnnThIdTySplice -- ^ '$$' + | AnnThTyQuote -- ^ double ''' + | AnnTilde -- ^ '~' + | AnnType + | AnnUnit -- ^ '()' for types + | AnnUsing + | AnnVal -- ^ e.g. INTEGER + | AnnValStr -- ^ String value, will need quotes when output + | AnnVbar -- ^ '|' + | AnnVia -- ^ 'via' + | AnnWhere + | Annlarrowtail -- ^ '-<' + | AnnlarrowtailU -- ^ '-<', unicode variant + | Annrarrowtail -- ^ '->' + | AnnrarrowtailU -- ^ '->', unicode variant + | AnnLarrowtail -- ^ '-<<' + | AnnLarrowtailU -- ^ '-<<', unicode variant + | AnnRarrowtail -- ^ '>>-' + | AnnRarrowtailU -- ^ '>>-', unicode variant + | AnnEofPos + deriving (Eq, Ord, Data, Show) + +instance Outputable AnnKeywordId where + ppr x = text (show x) + +-- --------------------------------------------------------------------- + +data AnnotationComment = + -- Documentation annotations + AnnDocCommentNext String -- ^ something beginning '-- |' + | AnnDocCommentPrev String -- ^ something beginning '-- ^' + | AnnDocCommentNamed String -- ^ something beginning '-- $' + | AnnDocSection Int String -- ^ a section heading + | AnnDocOptions String -- ^ doc options (prune, ignore-exports, etc) + | AnnLineComment String -- ^ comment starting by "--" + | AnnBlockComment String -- ^ comment in {- -} + deriving (Eq, Ord, Data, Show) +-- Note: these are based on the Token versions, but the Token type is +-- defined in Lexer.x and bringing it in here would create a loop + +instance Outputable AnnotationComment where + ppr x = text (show x) + +-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', +-- 'ApiAnnotation.AnnClose','ApiAnnotation.AnnComma', +-- 'ApiAnnotation.AnnRarrow' +-- 'ApiAnnotation.AnnTilde' +-- - May have 'ApiAnnotation.AnnComma' when in a list +type LRdrName = Located RdrName + + +-- | Certain tokens can have alternate representations when unicode syntax is +-- enabled. This flag is attached to those tokens in the lexer so that the +-- original source representation can be reproduced in the corresponding +-- 'ApiAnnotation' +data IsUnicodeSyntax = UnicodeSyntax | NormalSyntax + deriving (Eq, Ord, Data, Show) + +-- | Convert a normal annotation into its unicode equivalent one +unicodeAnn :: AnnKeywordId -> AnnKeywordId +unicodeAnn AnnForall = AnnForallU +unicodeAnn AnnDcolon = AnnDcolonU +unicodeAnn AnnLarrow = AnnLarrowU +unicodeAnn AnnRarrow = AnnRarrowU +unicodeAnn AnnDarrow = AnnDarrowU +unicodeAnn Annlarrowtail = AnnlarrowtailU +unicodeAnn Annrarrowtail = AnnrarrowtailU +unicodeAnn AnnLarrowtail = AnnLarrowtailU +unicodeAnn AnnRarrowtail = AnnRarrowtailU +unicodeAnn AnnOpenB = AnnOpenBU +unicodeAnn AnnCloseB = AnnCloseBU +unicodeAnn AnnOpenEQ = AnnOpenEQU +unicodeAnn AnnCloseQ = AnnCloseQU +unicodeAnn ann = ann + + +-- | Some template haskell tokens have two variants, one with an `e` the other +-- not: +-- +-- > [| or [e| +-- > [|| or [e|| +-- +-- This type indicates whether the 'e' is present or not. +data HasE = HasE | NoE + deriving (Eq, Ord, Data, Show) diff --git a/compiler/parser/Ctype.hs b/compiler/parser/Ctype.hs new file mode 100644 --- /dev/null +++ b/compiler/parser/Ctype.hs @@ -0,0 +1,215 @@ +-- Character classification +{-# LANGUAGE CPP #-} +module Ctype + ( is_ident -- Char# -> Bool + , is_symbol -- Char# -> Bool + , is_any -- Char# -> Bool + , is_space -- Char# -> Bool + , is_lower -- Char# -> Bool + , is_upper -- Char# -> Bool + , is_digit -- Char# -> Bool + , is_alphanum -- Char# -> Bool + + , is_decdigit, is_hexdigit, is_octdigit, is_bindigit + , hexDigit, octDecDigit + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import Data.Bits ( Bits((.&.),(.|.)) ) +import Data.Char ( ord, chr ) +import Data.Word +import Panic + +-- Bit masks + +cIdent, cSymbol, cAny, cSpace, cLower, cUpper, cDigit :: Word8 +cIdent = 1 +cSymbol = 2 +cAny = 4 +cSpace = 8 +cLower = 16 +cUpper = 32 +cDigit = 64 + +-- | The predicates below look costly, but aren't, GHC+GCC do a great job +-- at the big case below. + +{-# INLINABLE is_ctype #-} +is_ctype :: Word8 -> Char -> Bool +is_ctype mask c = (charType c .&. mask) /= 0 + +is_ident, is_symbol, is_any, is_space, is_lower, is_upper, is_digit, + is_alphanum :: Char -> Bool +is_ident = is_ctype cIdent +is_symbol = is_ctype cSymbol +is_any = is_ctype cAny +is_space = is_ctype cSpace +is_lower = is_ctype cLower +is_upper = is_ctype cUpper +is_digit = is_ctype cDigit +is_alphanum = is_ctype (cLower+cUpper+cDigit) + +-- Utils + +hexDigit :: Char -> Int +hexDigit c | is_decdigit c = ord c - ord '0' + | otherwise = ord (to_lower c) - ord 'a' + 10 + +octDecDigit :: Char -> Int +octDecDigit c = ord c - ord '0' + +is_decdigit :: Char -> Bool +is_decdigit c + = c >= '0' && c <= '9' + +is_hexdigit :: Char -> Bool +is_hexdigit c + = is_decdigit c + || (c >= 'a' && c <= 'f') + || (c >= 'A' && c <= 'F') + +is_octdigit :: Char -> Bool +is_octdigit c = c >= '0' && c <= '7' + +is_bindigit :: Char -> Bool +is_bindigit c = c == '0' || c == '1' + +to_lower :: Char -> Char +to_lower c + | c >= 'A' && c <= 'Z' = chr (ord c - (ord 'A' - ord 'a')) + | otherwise = c + +charType :: Char -> Word8 +charType c = case c of + '\0' -> 0 -- \000 + '\1' -> 0 -- \001 + '\2' -> 0 -- \002 + '\3' -> 0 -- \003 + '\4' -> 0 -- \004 + '\5' -> 0 -- \005 + '\6' -> 0 -- \006 + '\7' -> 0 -- \007 + '\8' -> 0 -- \010 + '\9' -> cSpace -- \t (not allowed in strings, so !cAny) + '\10' -> cSpace -- \n (ditto) + '\11' -> cSpace -- \v (ditto) + '\12' -> cSpace -- \f (ditto) + '\13' -> cSpace -- ^M (ditto) + '\14' -> 0 -- \016 + '\15' -> 0 -- \017 + '\16' -> 0 -- \020 + '\17' -> 0 -- \021 + '\18' -> 0 -- \022 + '\19' -> 0 -- \023 + '\20' -> 0 -- \024 + '\21' -> 0 -- \025 + '\22' -> 0 -- \026 + '\23' -> 0 -- \027 + '\24' -> 0 -- \030 + '\25' -> 0 -- \031 + '\26' -> 0 -- \032 + '\27' -> 0 -- \033 + '\28' -> 0 -- \034 + '\29' -> 0 -- \035 + '\30' -> 0 -- \036 + '\31' -> 0 -- \037 + '\32' -> cAny .|. cSpace -- + '\33' -> cAny .|. cSymbol -- ! + '\34' -> cAny -- " + '\35' -> cAny .|. cSymbol -- # + '\36' -> cAny .|. cSymbol -- $ + '\37' -> cAny .|. cSymbol -- % + '\38' -> cAny .|. cSymbol -- & + '\39' -> cAny .|. cIdent -- ' + '\40' -> cAny -- ( + '\41' -> cAny -- ) + '\42' -> cAny .|. cSymbol -- * + '\43' -> cAny .|. cSymbol -- + + '\44' -> cAny -- , + '\45' -> cAny .|. cSymbol -- - + '\46' -> cAny .|. cSymbol -- . + '\47' -> cAny .|. cSymbol -- / + '\48' -> cAny .|. cIdent .|. cDigit -- 0 + '\49' -> cAny .|. cIdent .|. cDigit -- 1 + '\50' -> cAny .|. cIdent .|. cDigit -- 2 + '\51' -> cAny .|. cIdent .|. cDigit -- 3 + '\52' -> cAny .|. cIdent .|. cDigit -- 4 + '\53' -> cAny .|. cIdent .|. cDigit -- 5 + '\54' -> cAny .|. cIdent .|. cDigit -- 6 + '\55' -> cAny .|. cIdent .|. cDigit -- 7 + '\56' -> cAny .|. cIdent .|. cDigit -- 8 + '\57' -> cAny .|. cIdent .|. cDigit -- 9 + '\58' -> cAny .|. cSymbol -- : + '\59' -> cAny -- ; + '\60' -> cAny .|. cSymbol -- < + '\61' -> cAny .|. cSymbol -- = + '\62' -> cAny .|. cSymbol -- > + '\63' -> cAny .|. cSymbol -- ? + '\64' -> cAny .|. cSymbol -- @ + '\65' -> cAny .|. cIdent .|. cUpper -- A + '\66' -> cAny .|. cIdent .|. cUpper -- B + '\67' -> cAny .|. cIdent .|. cUpper -- C + '\68' -> cAny .|. cIdent .|. cUpper -- D + '\69' -> cAny .|. cIdent .|. cUpper -- E + '\70' -> cAny .|. cIdent .|. cUpper -- F + '\71' -> cAny .|. cIdent .|. cUpper -- G + '\72' -> cAny .|. cIdent .|. cUpper -- H + '\73' -> cAny .|. cIdent .|. cUpper -- I + '\74' -> cAny .|. cIdent .|. cUpper -- J + '\75' -> cAny .|. cIdent .|. cUpper -- K + '\76' -> cAny .|. cIdent .|. cUpper -- L + '\77' -> cAny .|. cIdent .|. cUpper -- M + '\78' -> cAny .|. cIdent .|. cUpper -- N + '\79' -> cAny .|. cIdent .|. cUpper -- O + '\80' -> cAny .|. cIdent .|. cUpper -- P + '\81' -> cAny .|. cIdent .|. cUpper -- Q + '\82' -> cAny .|. cIdent .|. cUpper -- R + '\83' -> cAny .|. cIdent .|. cUpper -- S + '\84' -> cAny .|. cIdent .|. cUpper -- T + '\85' -> cAny .|. cIdent .|. cUpper -- U + '\86' -> cAny .|. cIdent .|. cUpper -- V + '\87' -> cAny .|. cIdent .|. cUpper -- W + '\88' -> cAny .|. cIdent .|. cUpper -- X + '\89' -> cAny .|. cIdent .|. cUpper -- Y + '\90' -> cAny .|. cIdent .|. cUpper -- Z + '\91' -> cAny -- [ + '\92' -> cAny .|. cSymbol -- backslash + '\93' -> cAny -- ] + '\94' -> cAny .|. cSymbol -- ^ + '\95' -> cAny .|. cIdent .|. cLower -- _ + '\96' -> cAny -- ` + '\97' -> cAny .|. cIdent .|. cLower -- a + '\98' -> cAny .|. cIdent .|. cLower -- b + '\99' -> cAny .|. cIdent .|. cLower -- c + '\100' -> cAny .|. cIdent .|. cLower -- d + '\101' -> cAny .|. cIdent .|. cLower -- e + '\102' -> cAny .|. cIdent .|. cLower -- f + '\103' -> cAny .|. cIdent .|. cLower -- g + '\104' -> cAny .|. cIdent .|. cLower -- h + '\105' -> cAny .|. cIdent .|. cLower -- i + '\106' -> cAny .|. cIdent .|. cLower -- j + '\107' -> cAny .|. cIdent .|. cLower -- k + '\108' -> cAny .|. cIdent .|. cLower -- l + '\109' -> cAny .|. cIdent .|. cLower -- m + '\110' -> cAny .|. cIdent .|. cLower -- n + '\111' -> cAny .|. cIdent .|. cLower -- o + '\112' -> cAny .|. cIdent .|. cLower -- p + '\113' -> cAny .|. cIdent .|. cLower -- q + '\114' -> cAny .|. cIdent .|. cLower -- r + '\115' -> cAny .|. cIdent .|. cLower -- s + '\116' -> cAny .|. cIdent .|. cLower -- t + '\117' -> cAny .|. cIdent .|. cLower -- u + '\118' -> cAny .|. cIdent .|. cLower -- v + '\119' -> cAny .|. cIdent .|. cLower -- w + '\120' -> cAny .|. cIdent .|. cLower -- x + '\121' -> cAny .|. cIdent .|. cLower -- y + '\122' -> cAny .|. cIdent .|. cLower -- z + '\123' -> cAny -- { + '\124' -> cAny .|. cSymbol -- | + '\125' -> cAny -- } + '\126' -> cAny .|. cSymbol -- ~ + '\127' -> 0 -- \177 + _ -> panic ("charType: " ++ show c) diff --git a/compiler/parser/HaddockUtils.hs b/compiler/parser/HaddockUtils.hs new file mode 100644 --- /dev/null +++ b/compiler/parser/HaddockUtils.hs @@ -0,0 +1,34 @@ + +module HaddockUtils where + +import GhcPrelude + +import HsSyn +import SrcLoc + +import Control.Monad + +-- ----------------------------------------------------------------------------- +-- Adding documentation to record fields (used in parsing). + +addFieldDoc :: LConDeclField a -> Maybe LHsDocString -> LConDeclField a +addFieldDoc (L l fld) doc + = L l (fld { cd_fld_doc = cd_fld_doc fld `mplus` doc }) + +addFieldDocs :: [LConDeclField a] -> Maybe LHsDocString -> [LConDeclField a] +addFieldDocs [] _ = [] +addFieldDocs (x:xs) doc = addFieldDoc x doc : xs + + +addConDoc :: LConDecl a -> Maybe LHsDocString -> LConDecl a +addConDoc decl Nothing = decl +addConDoc (L p c) doc = L p ( c { con_doc = con_doc c `mplus` doc } ) + +addConDocs :: [LConDecl a] -> Maybe LHsDocString -> [LConDecl a] +addConDocs [] _ = [] +addConDocs [x] doc = [addConDoc x doc] +addConDocs (x:xs) doc = x : addConDocs xs doc + +addConDocFirst :: [LConDecl a] -> Maybe LHsDocString -> [LConDecl a] +addConDocFirst [] _ = [] +addConDocFirst (x:xs) doc = addConDoc x doc : xs diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs new file mode 100644 --- /dev/null +++ b/compiler/parser/RdrHsSyn.hs @@ -0,0 +1,2764 @@ +-- +-- (c) The University of Glasgow 2002-2006 +-- + +-- Functions over HsSyn specialised to RdrName. + +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} + +module RdrHsSyn ( + mkHsOpApp, + mkHsIntegral, mkHsFractional, mkHsIsString, + mkHsDo, mkSpliceDecl, + mkRoleAnnotDecl, + mkClassDecl, + mkTyData, mkDataFamInst, + mkTySynonym, mkTyFamInstEqn, + mkTyFamInst, + mkFamDecl, mkLHsSigType, + mkInlinePragma, + mkPatSynMatchGroup, + mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp + mkTyClD, mkInstD, + mkRdrRecordCon, mkRdrRecordUpd, + setRdrNameSpace, + filterCTuple, + + cvBindGroup, + cvBindsAndSigs, + cvTopDecls, + placeHolderPunRhs, + + -- Stuff to do with Foreign declarations + mkImport, + parseCImport, + mkExport, + mkExtName, -- RdrName -> CLabelString + mkGadtDecl, -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName + mkConDeclH98, + mkATDefault, + + -- Bunch of functions in the parser monad for + -- checking and constructing values + checkBlockArguments, + checkPrecP, -- Int -> P Int + checkContext, -- HsType -> P HsContext + checkPattern, -- HsExp -> P HsPat + bang_RDR, + isBangRdr, + isTildeRdr, + checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat] + checkMonadComp, -- P (HsStmtContext RdrName) + checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl + checkValSigLhs, + checkDoAndIfThenElse, + LRuleTyTmVar, RuleTyTmVar(..), + mkRuleBndrs, mkRuleTyVarBndrs, + checkRuleTyVarBndrNames, + checkRecordSyntax, + checkEmptyGADTs, + addFatalError, hintBangPat, + TyEl(..), mergeOps, mergeDataCon, + + -- Help with processing exports + ImpExpSubSpec(..), + ImpExpQcSpec(..), + mkModuleImpExp, + mkTypeImpExp, + mkImpExpSubSpec, + checkImportSpec, + + -- Token symbols + forallSym, + starSym, + + -- Warnings and errors + warnStarIsType, + failOpFewArgs, + + SumOrTuple (..), mkSumOrTuple, + + -- Expression/command ambiguity resolution + PV, + ExpCmdP(ExpCmdP, runExpCmdP), + ExpCmdI(..), + ecFromExp, + ecFromCmd, + ecHsLam, + ecHsLet, + ecOpApp, + ecHsCase, + ecHsApp, + ecHsIf, + ecHsDo, + ecHsPar, + + ) where + +import GhcPrelude +import HsSyn -- Lots of it +import TyCon ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe ) +import DataCon ( DataCon, dataConTyCon ) +import ConLike ( ConLike(..) ) +import CoAxiom ( Role, fsFromRole ) +import RdrName +import Name +import BasicTypes +import TcEvidence ( idHsWrapper ) +import Lexer +import Lexeme ( isLexCon ) +import Type ( TyThing(..), funTyCon ) +import TysWiredIn ( cTupleTyConName, tupleTyCon, tupleDataCon, + nilDataConName, nilDataConKey, + listTyConName, listTyConKey, eqTyCon_RDR, + tupleTyConName, cTupleTyConNameArity_maybe ) +import ForeignCall +import PrelNames ( allNameStrings ) +import SrcLoc +import Unique ( hasKey ) +import OrdList ( OrdList, fromOL ) +import Bag ( emptyBag, consBag ) +import Outputable +import FastString +import Maybes +import Util +import ApiAnnotation +import Data.List +import DynFlags ( WarningFlag(..) ) + +import Control.Monad +import Text.ParserCombinators.ReadP as ReadP +import Data.Char +import qualified Data.Monoid as Monoid +import Data.Data ( dataTypeOf, fromConstr, dataTypeConstrs ) + +#include "HsVersions.h" + + +{- ********************************************************************** + + Construction functions for Rdr stuff + + ********************************************************************* -} + +-- | mkClassDecl builds a RdrClassDecl, filling in the names for tycon and +-- datacon by deriving them from the name of the class. We fill in the names +-- for the tycon and datacon corresponding to the class, by deriving them +-- from the name of the class itself. This saves recording the names in the +-- interface file (which would be equally good). + +-- Similarly for mkConDecl, mkClassOpSig and default-method names. + +-- *** See Note [The Naming story] in HsDecls **** + +mkTyClD :: LTyClDecl (GhcPass p) -> LHsDecl (GhcPass p) +mkTyClD (dL->L loc d) = cL loc (TyClD noExt d) + +mkInstD :: LInstDecl (GhcPass p) -> LHsDecl (GhcPass p) +mkInstD (dL->L loc d) = cL loc (InstD noExt d) + +mkClassDecl :: SrcSpan + -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) + -> Located (a,[LHsFunDep GhcPs]) + -> OrdList (LHsDecl GhcPs) + -> P (LTyClDecl GhcPs) + +mkClassDecl loc (dL->L _ (mcxt, tycl_hdr)) fds where_cls + = do { (binds, sigs, ats, at_insts, _, docs) <- cvBindsAndSigs where_cls + ; let cxt = fromMaybe (noLoc []) mcxt + ; (cls, tparams, fixity, ann) <- checkTyClHdr True tycl_hdr + ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan + ; (tyvars,annst) <- checkTyVarsP (text "class") whereDots cls tparams + ; addAnnsAt loc annst -- Add any API Annotations to the top SrcSpan + ; (at_defs, annsi) <- mapAndUnzipM (eitherToP . mkATDefault) at_insts + ; sequence_ annsi + ; return (cL loc (ClassDecl { tcdCExt = noExt, tcdCtxt = cxt + , tcdLName = cls, tcdTyVars = tyvars + , tcdFixity = fixity + , tcdFDs = snd (unLoc fds) + , tcdSigs = mkClassOpSigs sigs + , tcdMeths = binds + , tcdATs = ats, tcdATDefs = at_defs + , tcdDocs = docs })) } + +mkATDefault :: LTyFamInstDecl GhcPs + -> Either (SrcSpan, SDoc) (LTyFamDefltEqn GhcPs, P ()) +-- ^ Take a type-family instance declaration and turn it into +-- a type-family default equation for a class declaration. +-- We parse things as the former and use this function to convert to the latter +-- +-- We use the Either monad because this also called from "Convert". +-- +-- The @P ()@ we return corresponds represents an action which will add +-- some necessary paren annotations to the parsing context. Naturally, this +-- is not something that the "Convert" use cares about. +mkATDefault (dL->L loc (TyFamInstDecl { tfid_eqn = HsIB { hsib_body = e }})) + | FamEqn { feqn_tycon = tc, feqn_bndrs = bndrs, feqn_pats = pats + , feqn_fixity = fixity, feqn_rhs = rhs } <- e + = do { (tvs, anns) <- checkTyVars (text "default") equalsDots tc pats + ; let f = cL loc (FamEqn { feqn_ext = noExt + , feqn_tycon = tc + , feqn_bndrs = ASSERT( isNothing bndrs ) + Nothing + , feqn_pats = tvs + , feqn_fixity = fixity + , feqn_rhs = rhs }) + ; pure (f, addAnnsAt loc anns) } +mkATDefault (dL->L _ (TyFamInstDecl (HsIB _ (XFamEqn _)))) = panic "mkATDefault" +mkATDefault (dL->L _ (TyFamInstDecl (XHsImplicitBndrs _))) = panic "mkATDefault" +mkATDefault _ = panic "mkATDefault: Impossible Match" + -- due to #15884 + +mkTyData :: SrcSpan + -> NewOrData + -> Maybe (Located CType) + -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) + -> Maybe (LHsKind GhcPs) + -> [LConDecl GhcPs] + -> HsDeriving GhcPs + -> P (LTyClDecl GhcPs) +mkTyData loc new_or_data cType (dL->L _ (mcxt, tycl_hdr)) + ksig data_cons maybe_deriv + = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr + ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan + ; (tyvars, anns) <- checkTyVarsP (ppr new_or_data) equalsDots tc tparams + ; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan + ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv + ; return (cL loc (DataDecl { tcdDExt = noExt, + tcdLName = tc, tcdTyVars = tyvars, + tcdFixity = fixity, + tcdDataDefn = defn })) } + +mkDataDefn :: NewOrData + -> Maybe (Located CType) + -> Maybe (LHsContext GhcPs) + -> Maybe (LHsKind GhcPs) + -> [LConDecl GhcPs] + -> HsDeriving GhcPs + -> P (HsDataDefn GhcPs) +mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv + = do { checkDatatypeContext mcxt + ; let cxt = fromMaybe (noLoc []) mcxt + ; return (HsDataDefn { dd_ext = noExt + , dd_ND = new_or_data, dd_cType = cType + , dd_ctxt = cxt + , dd_cons = data_cons + , dd_kindSig = ksig + , dd_derivs = maybe_deriv }) } + + +mkTySynonym :: SrcSpan + -> LHsType GhcPs -- LHS + -> LHsType GhcPs -- RHS + -> P (LTyClDecl GhcPs) +mkTySynonym loc lhs rhs + = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs + ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan + ; (tyvars, anns) <- checkTyVarsP (text "type") equalsDots tc tparams + ; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan + ; return (cL loc (SynDecl { tcdSExt = noExt + , tcdLName = tc, tcdTyVars = tyvars + , tcdFixity = fixity + , tcdRhs = rhs })) } + +mkTyFamInstEqn :: Maybe [LHsTyVarBndr GhcPs] + -> LHsType GhcPs + -> LHsType GhcPs + -> P (TyFamInstEqn GhcPs,[AddAnn]) +mkTyFamInstEqn bndrs lhs rhs + = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs + ; return (mkHsImplicitBndrs + (FamEqn { feqn_ext = noExt + , feqn_tycon = tc + , feqn_bndrs = bndrs + , feqn_pats = tparams + , feqn_fixity = fixity + , feqn_rhs = rhs }), + ann) } + +mkDataFamInst :: SrcSpan + -> NewOrData + -> Maybe (Located CType) + -> (Maybe ( LHsContext GhcPs), Maybe [LHsTyVarBndr GhcPs] + , LHsType GhcPs) + -> Maybe (LHsKind GhcPs) + -> [LConDecl GhcPs] + -> HsDeriving GhcPs + -> P (LInstDecl GhcPs) +mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr) + ksig data_cons maybe_deriv + = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr + ; mapM_ (\a -> a loc) ann -- Add any API Annotations to the top SrcSpan + ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv + ; return (cL loc (DataFamInstD noExt (DataFamInstDecl (mkHsImplicitBndrs + (FamEqn { feqn_ext = noExt + , feqn_tycon = tc + , feqn_bndrs = bndrs + , feqn_pats = tparams + , feqn_fixity = fixity + , feqn_rhs = defn }))))) } + +mkTyFamInst :: SrcSpan + -> TyFamInstEqn GhcPs + -> P (LInstDecl GhcPs) +mkTyFamInst loc eqn + = return (cL loc (TyFamInstD noExt (TyFamInstDecl eqn))) + +mkFamDecl :: SrcSpan + -> FamilyInfo GhcPs + -> LHsType GhcPs -- LHS + -> Located (FamilyResultSig GhcPs) -- Optional result signature + -> Maybe (LInjectivityAnn GhcPs) -- Injectivity annotation + -> P (LTyClDecl GhcPs) +mkFamDecl loc info lhs ksig injAnn + = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs + ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan + ; (tyvars, anns) <- checkTyVarsP (ppr info) equals_or_where tc tparams + ; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan + ; return (cL loc (FamDecl noExt (FamilyDecl + { fdExt = noExt + , fdInfo = info, fdLName = tc + , fdTyVars = tyvars + , fdFixity = fixity + , fdResultSig = ksig + , fdInjectivityAnn = injAnn }))) } + where + equals_or_where = case info of + DataFamily -> empty + OpenTypeFamily -> empty + ClosedTypeFamily {} -> whereDots + +mkSpliceDecl :: LHsExpr GhcPs -> HsDecl GhcPs +-- If the user wrote +-- [pads| ... ] then return a QuasiQuoteD +-- $(e) then return a SpliceD +-- but if she wrote, say, +-- f x then behave as if she'd written $(f x) +-- ie a SpliceD +-- +-- Typed splices are not allowed at the top level, thus we do not represent them +-- as spliced declaration. See #10945 +mkSpliceDecl lexpr@(dL->L loc expr) + | HsSpliceE _ splice@(HsUntypedSplice {}) <- expr + = SpliceD noExt (SpliceDecl noExt (cL loc splice) ExplicitSplice) + + | HsSpliceE _ splice@(HsQuasiQuote {}) <- expr + = SpliceD noExt (SpliceDecl noExt (cL loc splice) ExplicitSplice) + + | otherwise + = SpliceD noExt (SpliceDecl noExt (cL loc (mkUntypedSplice NoParens lexpr)) + ImplicitSplice) + +mkRoleAnnotDecl :: SrcSpan + -> Located RdrName -- type being annotated + -> [Located (Maybe FastString)] -- roles + -> P (LRoleAnnotDecl GhcPs) +mkRoleAnnotDecl loc tycon roles + = do { roles' <- mapM parse_role roles + ; return $ cL loc $ RoleAnnotDecl noExt tycon roles' } + where + role_data_type = dataTypeOf (undefined :: Role) + all_roles = map fromConstr $ dataTypeConstrs role_data_type + possible_roles = [(fsFromRole role, role) | role <- all_roles] + + parse_role (dL->L loc_role Nothing) = return $ cL loc_role Nothing + parse_role (dL->L loc_role (Just role)) + = case lookup role possible_roles of + Just found_role -> return $ cL loc_role $ Just found_role + Nothing -> + let nearby = fuzzyLookup (unpackFS role) + (mapFst unpackFS possible_roles) + in + addFatalError loc_role + (text "Illegal role name" <+> quotes (ppr role) $$ + suggestions nearby) + parse_role _ = panic "parse_role: Impossible Match" + -- due to #15884 + + suggestions [] = empty + suggestions [r] = text "Perhaps you meant" <+> quotes (ppr r) + -- will this last case ever happen?? + suggestions list = hang (text "Perhaps you meant one of these:") + 2 (pprWithCommas (quotes . ppr) list) + +{- ********************************************************************** + + #cvBinds-etc# Converting to @HsBinds@, etc. + + ********************************************************************* -} + +-- | Function definitions are restructured here. Each is assumed to be recursive +-- initially, and non recursive definitions are discovered by the dependency +-- analyser. + + +-- | Groups together bindings for a single function +cvTopDecls :: OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs] +cvTopDecls decls = go (fromOL decls) + where + go :: [LHsDecl GhcPs] -> [LHsDecl GhcPs] + go [] = [] + go ((dL->L l (ValD x b)) : ds) + = cL l' (ValD x b') : go ds' + where (dL->L l' b', ds') = getMonoBind (cL l b) ds + go (d : ds) = d : go ds + +-- Declaration list may only contain value bindings and signatures. +cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs) +cvBindGroup binding + = do { (mbs, sigs, fam_ds, tfam_insts + , dfam_insts, _) <- cvBindsAndSigs binding + ; ASSERT( null fam_ds && null tfam_insts && null dfam_insts) + return $ ValBinds noExt mbs sigs } + +cvBindsAndSigs :: OrdList (LHsDecl GhcPs) + -> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs] + , [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl]) +-- Input decls contain just value bindings and signatures +-- and in case of class or instance declarations also +-- associated type declarations. They might also contain Haddock comments. +cvBindsAndSigs fb = go (fromOL fb) + where + go [] = return (emptyBag, [], [], [], [], []) + go ((dL->L l (ValD _ b)) : ds) + = do { (bs, ss, ts, tfis, dfis, docs) <- go ds' + ; return (b' `consBag` bs, ss, ts, tfis, dfis, docs) } + where + (b', ds') = getMonoBind (cL l b) ds + go ((dL->L l decl) : ds) + = do { (bs, ss, ts, tfis, dfis, docs) <- go ds + ; case decl of + SigD _ s + -> return (bs, cL l s : ss, ts, tfis, dfis, docs) + TyClD _ (FamDecl _ t) + -> return (bs, ss, cL l t : ts, tfis, dfis, docs) + InstD _ (TyFamInstD { tfid_inst = tfi }) + -> return (bs, ss, ts, cL l tfi : tfis, dfis, docs) + InstD _ (DataFamInstD { dfid_inst = dfi }) + -> return (bs, ss, ts, tfis, cL l dfi : dfis, docs) + DocD _ d + -> return (bs, ss, ts, tfis, dfis, cL l d : docs) + SpliceD _ d + -> addFatalError l $ + hang (text "Declaration splices are allowed only" <+> + text "at the top level:") + 2 (ppr d) + _ -> pprPanic "cvBindsAndSigs" (ppr decl) } + +----------------------------------------------------------------------------- +-- Group function bindings into equation groups + +getMonoBind :: LHsBind GhcPs -> [LHsDecl GhcPs] + -> (LHsBind GhcPs, [LHsDecl GhcPs]) +-- Suppose (b',ds') = getMonoBind b ds +-- ds is a list of parsed bindings +-- b is a MonoBinds that has just been read off the front + +-- Then b' is the result of grouping more equations from ds that +-- belong with b into a single MonoBinds, and ds' is the depleted +-- list of parsed bindings. +-- +-- All Haddock comments between equations inside the group are +-- discarded. +-- +-- No AndMonoBinds or EmptyMonoBinds here; just single equations + +getMonoBind (dL->L loc1 (FunBind { fun_id = fun_id1@(dL->L _ f1) + , fun_matches = + MG { mg_alts = (dL->L _ mtchs1) } })) + binds + | has_args mtchs1 + = go mtchs1 loc1 binds [] + where + go mtchs loc + ((dL->L loc2 (ValD _ (FunBind { fun_id = (dL->L _ f2) + , fun_matches = + MG { mg_alts = (dL->L _ mtchs2) } }))) + : binds) _ + | f1 == f2 = go (mtchs2 ++ mtchs) + (combineSrcSpans loc loc2) binds [] + go mtchs loc (doc_decl@(dL->L loc2 (DocD {})) : binds) doc_decls + = let doc_decls' = doc_decl : doc_decls + in go mtchs (combineSrcSpans loc loc2) binds doc_decls' + go mtchs loc binds doc_decls + = ( cL loc (makeFunBind fun_id1 (reverse mtchs)) + , (reverse doc_decls) ++ binds) + -- Reverse the final matches, to get it back in the right order + -- Do the same thing with the trailing doc comments + +getMonoBind bind binds = (bind, binds) + +has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool +has_args [] = panic "RdrHsSyn:has_args" +has_args ((dL->L _ (Match { m_pats = args })) : _) = not (null args) + -- Don't group together FunBinds if they have + -- no arguments. This is necessary now that variable bindings + -- with no arguments are now treated as FunBinds rather + -- than pattern bindings (tests/rename/should_fail/rnfail002). +has_args ((dL->L _ (XMatch _)) : _) = panic "has_args" +has_args (_ : _) = panic "has_args:Impossible Match" -- due to #15884 + +{- ********************************************************************** + + #PrefixToHS-utils# Utilities for conversion + + ********************************************************************* -} + +{- Note [Parsing data constructors is hard] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The problem with parsing data constructors is that they look a lot like types. +Compare: + + (s1) data T = C t1 t2 + (s2) type T = C t1 t2 + +Syntactically, there's little difference between these declarations, except in +(s1) 'C' is a data constructor, but in (s2) 'C' is a type constructor. + +This similarity would pose no problem if we knew ahead of time if we are +parsing a type or a constructor declaration. Looking at (s1) and (s2), a simple +(but wrong!) rule comes to mind: in 'data' declarations assume we are parsing +data constructors, and in other contexts (e.g. 'type' declarations) assume we +are parsing type constructors. + +This simple rule does not work because of two problematic cases: + + (p1) data T = C t1 t2 :+ t3 + (p2) data T = C t1 t2 => t3 + +In (p1) we encounter (:+) and it turns out we are parsing an infix data +declaration, so (C t1 t2) is a type and 'C' is a type constructor. +In (p2) we encounter (=>) and it turns out we are parsing an existential +context, so (C t1 t2) is a constraint and 'C' is a type constructor. + +As the result, in order to determine whether (C t1 t2) declares a data +constructor, a type, or a context, we would need unlimited lookahead which +'happy' is not so happy with. + +To further complicate matters, the interpretation of (!) and (~) is different +in constructors and types: + + (b1) type T = C ! D + (b2) data T = C ! D + (b3) data T = C ! D => E + +In (b1) and (b3), (!) is a type operator with two arguments: 'C' and 'D'. At +the same time, in (b2) it is a strictness annotation: 'C' is a data constructor +with a single strict argument 'D'. For the programmer, these cases are usually +easy to tell apart due to whitespace conventions: + + (b2) data T = C !D -- no space after the bang hints that + -- it is a strictness annotation + +For the parser, on the other hand, this whitespace does not matter. We cannot +tell apart (b2) from (b3) until we encounter (=>), so it requires unlimited +lookahead. + +The solution that accounts for all of these issues is to initially parse data +declarations and types as a reversed list of TyEl: + + data TyEl = TyElOpr RdrName + | TyElOpd (HsType GhcPs) + | TyElBang | TyElTilde + | ... + +For example, both occurences of (C ! D) in the following example are parsed +into equal lists of TyEl: + + data T = C ! D => C ! D results in [ TyElOpd (HsTyVar "D") + , TyElBang + , TyElOpd (HsTyVar "C") ] + +Note that elements are in reverse order. Also, 'C' is parsed as a type +constructor (HsTyVar) even when it is a data constructor. We fix this in +`tyConToDataCon`. + +By the time the list of TyEl is assembled, we have looked ahead enough to +decide whether to reduce using `mergeOps` (for types) or `mergeDataCon` (for +data constructors). These functions are where the actual job of parsing is +done. + +-} + +-- | Reinterpret a type constructor, including type operators, as a data +-- constructor. +-- See Note [Parsing data constructors is hard] +tyConToDataCon :: SrcSpan -> RdrName -> Either (SrcSpan, SDoc) (Located RdrName) +tyConToDataCon loc tc + | isTcOcc occ || isDataOcc occ + , isLexCon (occNameFS occ) + = return (cL loc (setRdrNameSpace tc srcDataName)) + + | otherwise + = Left (loc, msg) + where + occ = rdrNameOcc tc + msg = text "Not a data constructor:" <+> quotes (ppr tc) + +mkPatSynMatchGroup :: Located RdrName + -> Located (OrdList (LHsDecl GhcPs)) + -> P (MatchGroup GhcPs (LHsExpr GhcPs)) +mkPatSynMatchGroup (dL->L loc patsyn_name) (dL->L _ decls) = + do { matches <- mapM fromDecl (fromOL decls) + ; when (null matches) (wrongNumberErr loc) + ; return $ mkMatchGroup FromSource matches } + where + fromDecl (dL->L loc decl@(ValD _ (PatBind _ + pat@(dL->L _ (ConPatIn ln@(dL->L _ name) details)) + rhs _))) = + do { unless (name == patsyn_name) $ + wrongNameBindingErr loc decl + ; match <- case details of + PrefixCon pats -> return $ Match { m_ext = noExt + , m_ctxt = ctxt, m_pats = pats + , m_grhss = rhs } + where + ctxt = FunRhs { mc_fun = ln + , mc_fixity = Prefix + , mc_strictness = NoSrcStrict } + + InfixCon p1 p2 -> return $ Match { m_ext = noExt + , m_ctxt = ctxt + , m_pats = [p1, p2] + , m_grhss = rhs } + where + ctxt = FunRhs { mc_fun = ln + , mc_fixity = Infix + , mc_strictness = NoSrcStrict } + + RecCon{} -> recordPatSynErr loc pat + ; return $ cL loc match } + fromDecl (dL->L loc decl) = extraDeclErr loc decl + + extraDeclErr loc decl = + addFatalError loc $ + text "pattern synonym 'where' clause must contain a single binding:" $$ + ppr decl + + wrongNameBindingErr loc decl = + addFatalError loc $ + text "pattern synonym 'where' clause must bind the pattern synonym's name" + <+> quotes (ppr patsyn_name) $$ ppr decl + + wrongNumberErr loc = + addFatalError loc $ + text "pattern synonym 'where' clause cannot be empty" $$ + text "In the pattern synonym declaration for: " <+> ppr (patsyn_name) + +recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a +recordPatSynErr loc pat = + addFatalError loc $ + text "record syntax not supported for pattern synonym declarations:" $$ + ppr pat + +mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr GhcPs] + -> Maybe (LHsContext GhcPs) -> HsConDeclDetails GhcPs + -> ConDecl GhcPs + +mkConDeclH98 name mb_forall mb_cxt args + = ConDeclH98 { con_ext = noExt + , con_name = name + , con_forall = noLoc $ isJust mb_forall + , con_ex_tvs = mb_forall `orElse` [] + , con_mb_cxt = mb_cxt + , con_args = args' + , con_doc = Nothing } + where + args' = nudgeHsSrcBangs args + +mkGadtDecl :: [Located RdrName] + -> LHsType GhcPs -- Always a HsForAllTy + -> (ConDecl GhcPs, [AddAnn]) +mkGadtDecl names ty + = (ConDeclGADT { con_g_ext = noExt + , con_names = names + , con_forall = cL l $ isLHsForAllTy ty' + , con_qvars = mkHsQTvs tvs + , con_mb_cxt = mcxt + , con_args = args' + , con_res_ty = res_ty + , con_doc = Nothing } + , anns1 ++ anns2) + where + (ty'@(dL->L l _),anns1) = peel_parens ty [] + (tvs, rho) = splitLHsForAllTyInvis ty' + (mcxt, tau, anns2) = split_rho rho [] + + split_rho (dL->L _ (HsQualTy { hst_ctxt = cxt, hst_body = tau })) ann + = (Just cxt, tau, ann) + split_rho (dL->L l (HsParTy _ ty)) ann + = split_rho ty (ann++mkParensApiAnn l) + split_rho tau ann + = (Nothing, tau, ann) + + (args, res_ty) = split_tau tau + args' = nudgeHsSrcBangs args + + -- See Note [GADT abstract syntax] in HsDecls + split_tau (dL->L _ (HsFunTy _ (dL->L loc (HsRecTy _ rf)) res_ty)) + = (RecCon (cL loc rf), res_ty) + split_tau tau + = (PrefixCon [], tau) + + peel_parens (dL->L l (HsParTy _ ty)) ann = peel_parens ty + (ann++mkParensApiAnn l) + peel_parens ty ann = (ty, ann) + +nudgeHsSrcBangs :: HsConDeclDetails GhcPs -> HsConDeclDetails GhcPs +-- ^ This function ensures that fields with strictness or packedness +-- annotations put these annotations on an outer 'HsBangTy'. +-- +-- The problem is that in the parser, strictness and packedness annotations +-- bind more tightly that docstrings. However, the expectation downstream of +-- the parser (by functions such as 'getBangType' and 'getBangStrictness') +-- is that docstrings bind more tightly so that 'HsBangTy' may end up as the +-- top-level type. +-- +-- See #15206 +nudgeHsSrcBangs details + = case details of + PrefixCon as -> PrefixCon (map go as) + RecCon r -> RecCon r + InfixCon a1 a2 -> InfixCon (go a1) (go a2) + where + go (dL->L l (HsDocTy _ (dL->L _ (HsBangTy _ s lty)) lds)) = + cL l (HsBangTy noExt s (addCLoc lty lds (HsDocTy noExt lty lds))) + go lty = lty + + +setRdrNameSpace :: RdrName -> NameSpace -> RdrName +-- ^ This rather gruesome function is used mainly by the parser. +-- When parsing: +-- +-- > data T a = T | T1 Int +-- +-- we parse the data constructors as /types/ because of parser ambiguities, +-- so then we need to change the /type constr/ to a /data constr/ +-- +-- The exact-name case /can/ occur when parsing: +-- +-- > data [] a = [] | a : [a] +-- +-- For the exact-name case we return an original name. +setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace ns occ) +setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace ns occ) +setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ) +setRdrNameSpace (Exact n) ns + | Just thing <- wiredInNameTyThing_maybe n + = setWiredInNameSpace thing ns + -- Preserve Exact Names for wired-in things, + -- notably tuples and lists + + | isExternalName n + = Orig (nameModule n) occ + + | otherwise -- This can happen when quoting and then + -- splicing a fixity declaration for a type + = Exact (mkSystemNameAt (nameUnique n) occ (nameSrcSpan n)) + where + occ = setOccNameSpace ns (nameOccName n) + +setWiredInNameSpace :: TyThing -> NameSpace -> RdrName +setWiredInNameSpace (ATyCon tc) ns + | isDataConNameSpace ns + = ty_con_data_con tc + | isTcClsNameSpace ns + = Exact (getName tc) -- No-op + +setWiredInNameSpace (AConLike (RealDataCon dc)) ns + | isTcClsNameSpace ns + = data_con_ty_con dc + | isDataConNameSpace ns + = Exact (getName dc) -- No-op + +setWiredInNameSpace thing ns + = pprPanic "setWiredinNameSpace" (pprNameSpace ns <+> ppr thing) + +ty_con_data_con :: TyCon -> RdrName +ty_con_data_con tc + | isTupleTyCon tc + , Just dc <- tyConSingleDataCon_maybe tc + = Exact (getName dc) + + | tc `hasKey` listTyConKey + = Exact nilDataConName + + | otherwise -- See Note [setRdrNameSpace for wired-in names] + = Unqual (setOccNameSpace srcDataName (getOccName tc)) + +data_con_ty_con :: DataCon -> RdrName +data_con_ty_con dc + | let tc = dataConTyCon dc + , isTupleTyCon tc + = Exact (getName tc) + + | dc `hasKey` nilDataConKey + = Exact listTyConName + + | otherwise -- See Note [setRdrNameSpace for wired-in names] + = Unqual (setOccNameSpace tcClsName (getOccName dc)) + +-- | Replaces constraint tuple names with corresponding boxed ones. +filterCTuple :: RdrName -> RdrName +filterCTuple (Exact n) + | Just arity <- cTupleTyConNameArity_maybe n + = Exact $ tupleTyConName BoxedTuple arity +filterCTuple rdr = rdr + + +{- Note [setRdrNameSpace for wired-in names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In GHC.Types, which declares (:), we have + infixr 5 : +The ambiguity about which ":" is meant is resolved by parsing it as a +data constructor, but then using dataTcOccs to try the type constructor too; +and that in turn calls setRdrNameSpace to change the name-space of ":" to +tcClsName. There isn't a corresponding ":" type constructor, but it's painful +to make setRdrNameSpace partial, so we just make an Unqual name instead. It +really doesn't matter! +-} + +checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsTypeArg GhcPs] + -> P (LHsQTyVars GhcPs, [AddAnn]) +-- Same as checkTyVars, but in the P monad +checkTyVarsP pp_what equals_or_where tc tparms + = do { let checkedTvs = checkTyVars pp_what equals_or_where tc tparms + ; eitherToP checkedTvs } + +eitherToP :: Either (SrcSpan, SDoc) a -> P a +-- Adapts the Either monad to the P monad +eitherToP (Left (loc, doc)) = addFatalError loc doc +eitherToP (Right thing) = return thing + +checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsTypeArg GhcPs] + -> Either (SrcSpan, SDoc) + ( LHsQTyVars GhcPs -- the synthesized type variables + , [AddAnn] ) -- action which adds annotations +-- ^ Check whether the given list of type parameters are all type variables +-- (possibly with a kind signature). +-- We use the Either monad because it's also called (via 'mkATDefault') from +-- "Convert". +checkTyVars pp_what equals_or_where tc tparms + = do { (tvs, anns) <- fmap unzip $ mapM check tparms + ; return (mkHsQTvs tvs, concat anns) } + where + check (HsTypeArg _ ki@(L loc _)) + = Left (loc, + vcat [ text "Unexpected type application" <+> + text "@" <> ppr ki + , text "In the" <+> pp_what <+> + ptext (sLit "declaration for") <+> quotes (ppr tc)]) + check (HsValArg ty) = chkParens [] ty + check (HsArgPar sp) = Left (sp, vcat [text "Malformed" <+> pp_what + <+> text "declaration for" <+> quotes (ppr tc)]) + -- Keep around an action for adjusting the annotations of extra parens + chkParens :: [AddAnn] -> LHsType GhcPs + -> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs, [AddAnn]) + chkParens acc (dL->L l (HsParTy _ ty)) = chkParens (mkParensApiAnn l + ++ acc) ty + chkParens acc ty = case chk ty of + Left err -> Left err + Right tv -> Right (tv, reverse acc) + + -- Check that the name space is correct! + chk :: LHsType GhcPs -> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs) + chk (dL->L l (HsKindSig _ (dL->L lv (HsTyVar _ _ (dL->L _ tv))) k)) + | isRdrTyVar tv = return (cL l (KindedTyVar noExt (cL lv tv) k)) + chk (dL->L l (HsTyVar _ _ (dL->L ltv tv))) + | isRdrTyVar tv = return (cL l (UserTyVar noExt (cL ltv tv))) + chk t@(dL->L loc _) + = Left (loc, + vcat [ text "Unexpected type" <+> quotes (ppr t) + , text "In the" <+> pp_what + <+> ptext (sLit "declaration for") <+> quotes tc' + , vcat[ (text "A" <+> pp_what + <+> ptext (sLit "declaration should have form")) + , nest 2 + (pp_what + <+> tc' + <+> hsep (map text (takeList tparms allNameStrings)) + <+> equals_or_where) ] ]) + + -- Avoid printing a constraint tuple in the error message. Print + -- a plain old tuple instead (since that's what the user probably + -- wrote). See #14907 + tc' = ppr $ fmap filterCTuple tc + + + +whereDots, equalsDots :: SDoc +-- Second argument to checkTyVars +whereDots = text "where ..." +equalsDots = text "= ..." + +checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P () +checkDatatypeContext Nothing = return () +checkDatatypeContext (Just c) + = do allowed <- getBit DatatypeContextsBit + unless allowed $ + addError (getLoc c) + (text "Illegal datatype context (use DatatypeContexts):" + <+> pprLHsContext c) + +type LRuleTyTmVar = Located RuleTyTmVar +data RuleTyTmVar = RuleTyTmVar (Located RdrName) (Maybe (LHsType GhcPs)) +-- ^ Essentially a wrapper for a @RuleBndr GhcPs@ + +-- turns RuleTyTmVars into RuleBnrs - this is straightforward +mkRuleBndrs :: [LRuleTyTmVar] -> [LRuleBndr GhcPs] +mkRuleBndrs = fmap (fmap cvt_one) + where cvt_one (RuleTyTmVar v Nothing) = RuleBndr noExt v + cvt_one (RuleTyTmVar v (Just sig)) = + RuleBndrSig noExt v (mkLHsSigWcType sig) + +-- turns RuleTyTmVars into HsTyVarBndrs - this is more interesting +mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr GhcPs] +mkRuleTyVarBndrs = fmap (fmap cvt_one) + where cvt_one (RuleTyTmVar v Nothing) = UserTyVar noExt (fmap tm_to_ty v) + cvt_one (RuleTyTmVar v (Just sig)) + = KindedTyVar noExt (fmap tm_to_ty v) sig + -- takes something in namespace 'varName' to something in namespace 'tvName' + tm_to_ty (Unqual occ) = Unqual (setOccNameSpace tvName occ) + tm_to_ty _ = panic "mkRuleTyVarBndrs" + +-- See note [Parsing explicit foralls in Rules] in Parser.y +checkRuleTyVarBndrNames :: [LHsTyVarBndr GhcPs] -> P () +checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName) + where check (dL->L loc (Unqual occ)) = do + when ((occNameString occ ==) `any` ["forall","family","role"]) + (addFatalError loc (text $ "parse error on input " + ++ occNameString occ)) + check _ = panic "checkRuleTyVarBndrNames" + +checkRecordSyntax :: Outputable a => Located a -> P (Located a) +checkRecordSyntax lr@(dL->L loc r) + = do allowed <- getBit TraditionalRecordSyntaxBit + unless allowed $ addError loc $ + text "Illegal record syntax (use TraditionalRecordSyntax):" <+> ppr r + return lr + +-- | Check if the gadt_constrlist is empty. Only raise parse error for +-- `data T where` to avoid affecting existing error message, see #8258. +checkEmptyGADTs :: Located ([AddAnn], [LConDecl GhcPs]) + -> P (Located ([AddAnn], [LConDecl GhcPs])) +checkEmptyGADTs gadts@(dL->L span (_, [])) -- Empty GADT declaration. + = do gadtSyntax <- getBit GadtSyntaxBit -- GADTs implies GADTSyntax + unless gadtSyntax $ addError span $ vcat + [ text "Illegal keyword 'where' in data declaration" + , text "Perhaps you intended to use GADTs or a similar language" + , text "extension to enable syntax: data T where" + ] + return gadts +checkEmptyGADTs gadts = return gadts -- Ordinary GADT declaration. + +checkTyClHdr :: Bool -- True <=> class header + -- False <=> type header + -> LHsType GhcPs + -> P (Located RdrName, -- the head symbol (type or class name) + [LHsTypeArg GhcPs], -- parameters of head symbol + LexicalFixity, -- the declaration is in infix format + [AddAnn]) -- API Annotation for HsParTy when stripping parens +-- Well-formedness check and decomposition of type and class heads. +-- Decomposes T ty1 .. tyn into (T, [ty1, ..., tyn]) +-- Int :*: Bool into (:*:, [Int, Bool]) +-- returning the pieces +checkTyClHdr is_cls ty + = goL ty [] [] Prefix + where + goL (dL->L l ty) acc ann fix = go l ty acc ann fix + + -- workaround to define '*' despite StarIsType + go lp (HsParTy _ (dL->L l (HsStarTy _ isUni))) acc ann fix + = do { warnStarBndr l + ; let name = mkOccName tcClsName (starSym isUni) + ; return (cL l (Unqual name), acc, fix, (ann ++ mkParensApiAnn lp)) } + + go l (HsTyVar _ _ (dL->L _ tc)) acc ann fix + | isRdrTc tc = return (cL l tc, acc, fix, ann) + go _ (HsOpTy _ t1 ltc@(dL->L _ tc) t2) acc ann _fix + | isRdrTc tc = return (ltc, HsValArg t1:HsValArg t2:acc, Infix, ann) + go l (HsParTy _ ty) acc ann fix = goL ty acc (ann ++mkParensApiAnn l) fix + go _ (HsAppTy _ t1 t2) acc ann fix = goL t1 (HsValArg t2:acc) ann fix + go _ (HsAppKindTy l ty ki) acc ann fix = goL ty (HsTypeArg l ki:acc) ann fix + go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ann fix + = return (cL l (nameRdrName tup_name), map HsValArg ts, fix, ann) + where + arity = length ts + tup_name | is_cls = cTupleTyConName arity + | otherwise = getName (tupleTyCon Boxed arity) + -- See Note [Unit tuples] in HsTypes (TODO: is this still relevant?) + go l _ _ _ _ + = addFatalError l (text "Malformed head of type or class declaration:" + <+> ppr ty) + +-- | Yield a parse error if we have a function applied directly to a do block +-- etc. and BlockArguments is not enabled. +checkBlockArguments :: forall b. ExpCmdI b => Located (b GhcPs) -> PV () +checkBlockArguments = case expCmdG @b of { ExpG -> checkExpr; CmdG -> checkCmd } + where + checkExpr :: LHsExpr GhcPs -> P () + checkExpr expr = case unLoc expr of + HsDo _ DoExpr _ -> check "do block" expr + HsDo _ MDoExpr _ -> check "mdo block" expr + HsLam {} -> check "lambda expression" expr + HsCase {} -> check "case expression" expr + HsLamCase {} -> check "lambda-case expression" expr + HsLet {} -> check "let expression" expr + HsIf {} -> check "if expression" expr + HsProc {} -> check "proc expression" expr + _ -> return () + + checkCmd :: LHsCmd GhcPs -> P () + checkCmd cmd = case unLoc cmd of + HsCmdLam {} -> check "lambda command" cmd + HsCmdCase {} -> check "case command" cmd + HsCmdIf {} -> check "if command" cmd + HsCmdLet {} -> check "let command" cmd + HsCmdDo {} -> check "do command" cmd + _ -> return () + + check :: (HasSrcSpan a, Outputable a) => String -> a -> P () + check element a = do + blockArguments <- getBit BlockArgumentsBit + unless blockArguments $ + addError (getLoc a) $ + text "Unexpected " <> text element <> text " in function application:" + $$ nest 4 (ppr a) + $$ text "You could write it with parentheses" + $$ text "Or perhaps you meant to enable BlockArguments?" + +-- | Validate the context constraints and break up a context into a list +-- of predicates. +-- +-- @ +-- (Eq a, Ord b) --> [Eq a, Ord b] +-- Eq a --> [Eq a] +-- (Eq a) --> [Eq a] +-- (((Eq a))) --> [Eq a] +-- @ +checkContext :: LHsType GhcPs -> P ([AddAnn],LHsContext GhcPs) +checkContext (dL->L l orig_t) + = check [] (cL l orig_t) + where + check anns (dL->L lp (HsTupleTy _ HsBoxedOrConstraintTuple ts)) + -- (Eq a, Ord b) shows up as a tuple type. Only boxed tuples can + -- be used as context constraints. + = return (anns ++ mkParensApiAnn lp,cL l ts) -- Ditto () + + check anns (dL->L lp1 (HsParTy _ ty)) + -- to be sure HsParTy doesn't get into the way + = check anns' ty + where anns' = if l == lp1 then anns + else (anns ++ mkParensApiAnn lp1) + + -- no need for anns, returning original + check _anns t = checkNoDocs msg t *> return ([],cL l [cL l orig_t]) + + msg = text "data constructor context" + +-- | Check recursively if there are any 'HsDocTy's in the given type. +-- This only works on a subset of types produced by 'btype_no_ops' +checkNoDocs :: SDoc -> LHsType GhcPs -> P () +checkNoDocs msg ty = go ty + where + go (dL->L _ (HsAppKindTy _ ty ki)) = go ty *> go ki + go (dL->L _ (HsAppTy _ t1 t2)) = go t1 *> go t2 + go (dL->L l (HsDocTy _ t ds)) = addError l $ hsep + [ text "Unexpected haddock", quotes (ppr ds) + , text "on", msg, quotes (ppr t) ] + go _ = pure () + +-- ------------------------------------------------------------------------- +-- Checking Patterns. + +-- We parse patterns as expressions and check for valid patterns below, +-- converting the expression into a pattern at the same time. + +checkPattern :: SDoc -> LHsExpr GhcPs -> P (LPat GhcPs) +checkPattern msg e = checkLPat msg e + +checkPatterns :: SDoc -> [LHsExpr GhcPs] -> P [LPat GhcPs] +checkPatterns msg es = mapM (checkPattern msg) es + +checkLPat :: SDoc -> LHsExpr GhcPs -> P (LPat GhcPs) +checkLPat msg e@(dL->L l _) = checkPat msg l e [] + +checkPat :: SDoc -> SrcSpan -> LHsExpr GhcPs -> [LPat GhcPs] + -> P (LPat GhcPs) +checkPat _ loc (dL->L l e@(HsVar _ (dL->L _ c))) args + | isRdrDataCon c = return (cL loc (ConPatIn (cL l c) (PrefixCon args))) + | not (null args) && patIsRec c = + patFail (text "Perhaps you intended to use RecursiveDo") l e +checkPat msg loc e args -- OK to let this happen even if bang-patterns + -- are not enabled, because there is no valid + -- non-bang-pattern parse of (C ! e) + | Just (e', args') <- splitBang e + = do { args'' <- checkPatterns msg args' + ; checkPat msg loc e' (args'' ++ args) } +checkPat msg loc (dL->L _ (HsApp _ f e)) args + = do p <- checkLPat msg e + checkPat msg loc f (p : args) +checkPat msg loc (dL->L _ e) [] + = do p <- checkAPat msg loc e + return (cL loc p) +checkPat msg loc e _ + = patFail msg loc (unLoc e) + +checkAPat :: SDoc -> SrcSpan -> HsExpr GhcPs -> P (Pat GhcPs) +checkAPat msg loc e0 = do + nPlusKPatterns <- getBit NPlusKPatternsBit + case e0 of + EWildPat _ -> return (WildPat noExt) + HsVar _ x -> return (VarPat noExt x) + HsLit _ (HsStringPrim _ _) -- (#13260) + -> addFatalError loc (text "Illegal unboxed string literal in pattern:" + $$ ppr e0) + + HsLit _ l -> return (LitPat noExt l) + + -- Overloaded numeric patterns (e.g. f 0 x = x) + -- Negation is recorded separately, so that the literal is zero or +ve + -- NB. Negative *primitive* literals are already handled by the lexer + HsOverLit _ pos_lit -> return (mkNPat (cL loc pos_lit) Nothing) + NegApp _ (dL->L l (HsOverLit _ pos_lit)) _ + -> return (mkNPat (cL l pos_lit) (Just noSyntaxExpr)) + + SectionR _ (dL->L lb (HsVar _ (dL->L _ bang))) e -- (! x) + | bang == bang_RDR + -> do { hintBangPat loc e0 + ; e' <- checkLPat msg e + ; addAnnotation loc AnnBang lb + ; return (BangPat noExt e') } + + ELazyPat _ e -> checkLPat msg e >>= (return . (LazyPat noExt)) + EAsPat _ n e -> checkLPat msg e >>= (return . (AsPat noExt) n) + -- view pattern is well-formed if the pattern is + EViewPat _ expr patE -> checkLPat msg patE >>= + (return . (\p -> ViewPat noExt expr p)) + ExprWithTySig _ e t -> do e <- checkLPat msg e + return (SigPat noExt e t) + + -- n+k patterns + OpApp _ (dL->L nloc (HsVar _ (dL->L _ n))) + (dL->L _ (HsVar _ (dL->L _ plus))) + (dL->L lloc (HsOverLit _ lit@(OverLit {ol_val = HsIntegral {}}))) + | nPlusKPatterns && (plus == plus_RDR) + -> return (mkNPlusKPat (cL nloc n) (cL lloc lit)) + OpApp _ l (dL->L cl (HsVar _ (dL->L _ c))) r + | isDataOcc (rdrNameOcc c) -> do + l <- checkLPat msg l + r <- checkLPat msg r + return (ConPatIn (cL cl c) (InfixCon l r)) + + OpApp {} -> patFail msg loc e0 + + ExplicitList _ _ es -> do ps <- mapM (checkLPat msg) es + return (ListPat noExt ps) + + HsPar _ e -> checkLPat msg e >>= (return . (ParPat noExt)) + + ExplicitTuple _ es b + | all tupArgPresent es -> do ps <- mapM (checkLPat msg) + [e | (dL->L _ (Present _ e)) <- es] + return (TuplePat noExt ps b) + | otherwise -> addFatalError loc (text "Illegal tuple section in pattern:" + $$ ppr e0) + + ExplicitSum _ alt arity expr -> do + p <- checkLPat msg expr + return (SumPat noExt p alt arity) + + RecordCon { rcon_con_name = c, rcon_flds = HsRecFields fs dd } + -> do fs <- mapM (checkPatField msg) fs + return (ConPatIn c (RecCon (HsRecFields fs dd))) + HsSpliceE _ s | not (isTypedSplice s) + -> return (SplicePat noExt s) + _ -> patFail msg loc e0 + +placeHolderPunRhs :: LHsExpr GhcPs +-- The RHS of a punned record field will be filled in by the renamer +-- It's better not to make it an error, in case we want to print it when +-- debugging +placeHolderPunRhs = noLoc (HsVar noExt (noLoc pun_RDR)) + +plus_RDR, bang_RDR, pun_RDR :: RdrName +plus_RDR = mkUnqual varName (fsLit "+") -- Hack +bang_RDR = mkUnqual varName (fsLit "!") -- Hack +pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side") + +isBangRdr, isTildeRdr :: RdrName -> Bool +isBangRdr (Unqual occ) = occNameFS occ == fsLit "!" +isBangRdr _ = False +isTildeRdr = (==eqTyCon_RDR) + +checkPatField :: SDoc -> LHsRecField GhcPs (LHsExpr GhcPs) + -> P (LHsRecField GhcPs (LPat GhcPs)) +checkPatField msg (dL->L l fld) = do p <- checkLPat msg (hsRecFieldArg fld) + return (cL l (fld { hsRecFieldArg = p })) + +patFail :: SDoc -> SrcSpan -> HsExpr GhcPs -> P a +patFail msg loc e = addFatalError loc err + where err = text "Parse error in pattern:" <+> ppr e + $$ msg + +patIsRec :: RdrName -> Bool +patIsRec e = e == mkUnqual varName (fsLit "rec") + + +--------------------------------------------------------------------------- +-- Check Equation Syntax + +checkValDef :: SDoc + -> SrcStrictness + -> LHsExpr GhcPs + -> Maybe (LHsType GhcPs) + -> Located (a,GRHSs GhcPs (LHsExpr GhcPs)) + -> P ([AddAnn],HsBind GhcPs) + +checkValDef msg _strictness lhs (Just sig) grhss + -- x :: ty = rhs parses as a *pattern* binding + = checkPatBind msg (cL (combineLocs lhs sig) + (ExprWithTySig noExt lhs (mkLHsSigWcType sig))) grhss + +checkValDef msg strictness lhs Nothing g@(dL->L l (_,grhss)) + = do { mb_fun <- isFunLhs lhs + ; case mb_fun of + Just (fun, is_infix, pats, ann) -> + checkFunBind msg strictness ann (getLoc lhs) + fun is_infix pats (cL l grhss) + Nothing -> checkPatBind msg lhs g } + +checkFunBind :: SDoc + -> SrcStrictness + -> [AddAnn] + -> SrcSpan + -> Located RdrName + -> LexicalFixity + -> [LHsExpr GhcPs] + -> Located (GRHSs GhcPs (LHsExpr GhcPs)) + -> P ([AddAnn],HsBind GhcPs) +checkFunBind msg strictness ann lhs_loc fun is_infix pats (dL->L rhs_span grhss) + = do ps <- checkPatterns msg pats + let match_span = combineSrcSpans lhs_loc rhs_span + -- Add back the annotations stripped from any HsPar values in the lhs + -- mapM_ (\a -> a match_span) ann + return (ann, makeFunBind fun + [cL match_span (Match { m_ext = noExt + , m_ctxt = FunRhs + { mc_fun = fun + , mc_fixity = is_infix + , mc_strictness = strictness } + , m_pats = ps + , m_grhss = grhss })]) + -- The span of the match covers the entire equation. + -- That isn't quite right, but it'll do for now. + +makeFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] + -> HsBind GhcPs +-- Like HsUtils.mkFunBind, but we need to be able to set the fixity too +makeFunBind fn ms + = FunBind { fun_ext = noExt, + fun_id = fn, + fun_matches = mkMatchGroup FromSource ms, + fun_co_fn = idHsWrapper, + fun_tick = [] } + +checkPatBind :: SDoc + -> LHsExpr GhcPs + -> Located (a,GRHSs GhcPs (LHsExpr GhcPs)) + -> P ([AddAnn],HsBind GhcPs) +checkPatBind msg lhs (dL->L _ (_,grhss)) + = do { lhs <- checkPattern msg lhs + ; return ([],PatBind noExt lhs grhss + ([],[])) } + +checkValSigLhs :: LHsExpr GhcPs -> P (Located RdrName) +checkValSigLhs (dL->L _ (HsVar _ lrdr@(dL->L _ v))) + | isUnqual v + , not (isDataOcc (rdrNameOcc v)) + = return lrdr + +checkValSigLhs lhs@(dL->L l _) + = addFatalError l ((text "Invalid type signature:" <+> + ppr lhs <+> text ":: ...") + $$ text hint) + where + hint | foreign_RDR `looks_like` lhs + = "Perhaps you meant to use ForeignFunctionInterface?" + | default_RDR `looks_like` lhs + = "Perhaps you meant to use DefaultSignatures?" + | pattern_RDR `looks_like` lhs + = "Perhaps you meant to use PatternSynonyms?" + | otherwise + = "Should be of form :: " + + -- A common error is to forget the ForeignFunctionInterface flag + -- so check for that, and suggest. cf #3805 + -- Sadly 'foreign import' still barfs 'parse error' because + -- 'import' is a keyword + looks_like s (dL->L _ (HsVar _ (dL->L _ v))) = v == s + looks_like s (dL->L _ (HsApp _ lhs _)) = looks_like s lhs + looks_like _ _ = False + + foreign_RDR = mkUnqual varName (fsLit "foreign") + default_RDR = mkUnqual varName (fsLit "default") + pattern_RDR = mkUnqual varName (fsLit "pattern") + +checkDoAndIfThenElse + :: forall b. ExpCmdI b => + LHsExpr GhcPs + -> Bool + -> Located (b GhcPs) + -> Bool + -> Located (b GhcPs) + -> P () +checkDoAndIfThenElse = + case expCmdG @b of + ExpG -> checkDoAndIfThenElse' + CmdG -> checkDoAndIfThenElse' + +checkDoAndIfThenElse' + :: (HasSrcSpan a, Outputable a, Outputable b, HasSrcSpan c, Outputable c) + => a -> Bool -> b -> Bool -> c -> P () +checkDoAndIfThenElse' guardExpr semiThen thenExpr semiElse elseExpr + | semiThen || semiElse + = do doAndIfThenElse <- getBit DoAndIfThenElseBit + unless doAndIfThenElse $ do + addError (combineLocs guardExpr elseExpr) + (text "Unexpected semi-colons in conditional:" + $$ nest 4 expr + $$ text "Perhaps you meant to use DoAndIfThenElse?") + | otherwise = return () + where pprOptSemi True = semi + pprOptSemi False = empty + expr = text "if" <+> ppr guardExpr <> pprOptSemi semiThen <+> + text "then" <+> ppr thenExpr <> pprOptSemi semiElse <+> + text "else" <+> ppr elseExpr + + + -- The parser left-associates, so there should + -- not be any OpApps inside the e's +splitBang :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [LHsExpr GhcPs]) +-- Splits (f ! g a b) into (f, [(! g), a, b]) +splitBang (dL->L _ (OpApp _ l_arg bang@(dL->L _ (HsVar _ (dL->L _ op))) r_arg)) + | op == bang_RDR = Just (l_arg, cL l' (SectionR noExt bang arg1) : argns) + where + l' = combineLocs bang arg1 + (arg1,argns) = split_bang r_arg [] + split_bang (dL->L _ (HsApp _ f e)) es = split_bang f (e:es) + split_bang e es = (e,es) +splitBang _ = Nothing + +-- See Note [isFunLhs vs mergeDataCon] +isFunLhs :: LHsExpr GhcPs + -> P (Maybe (Located RdrName, LexicalFixity, [LHsExpr GhcPs],[AddAnn])) +-- A variable binding is parsed as a FunBind. +-- Just (fun, is_infix, arg_pats) if e is a function LHS +-- +-- The whole LHS is parsed as a single expression. +-- Any infix operators on the LHS will parse left-associatively +-- E.g. f !x y !z +-- will parse (rather strangely) as +-- (f ! x y) ! z +-- It's up to isFunLhs to sort out the mess +-- +-- a .!. !b + +isFunLhs e = go e [] [] + where + go (dL->L loc (HsVar _ (dL->L _ f))) es ann + | not (isRdrDataCon f) = return (Just (cL loc f, Prefix, es, ann)) + go (dL->L _ (HsApp _ f e)) es ann = go f (e:es) ann + go (dL->L l (HsPar _ e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l) + + -- Things of the form `!x` are also FunBinds + -- See Note [FunBind vs PatBind] + go (dL->L _ (SectionR _ (dL->L _ (HsVar _ (dL->L _ bang))) + (dL->L l (HsVar _ (L _ var))))) [] ann + | bang == bang_RDR + , not (isRdrDataCon var) = return (Just (cL l var, Prefix, [], ann)) + + -- For infix function defns, there should be only one infix *function* + -- (though there may be infix *datacons* involved too). So we don't + -- need fixity info to figure out which function is being defined. + -- a `K1` b `op` c `K2` d + -- must parse as + -- (a `K1` b) `op` (c `K2` d) + -- The renamer checks later that the precedences would yield such a parse. + -- + -- There is a complication to deal with bang patterns. + -- + -- ToDo: what about this? + -- x + 1 `op` y = ... + + go e@(L loc (OpApp _ l (dL->L loc' (HsVar _ (dL->L _ op))) r)) es ann + | Just (e',es') <- splitBang e + = do { bang_on <- getBit BangPatBit + ; if bang_on then go e' (es' ++ es) ann + else return (Just (cL loc' op, Infix, (l:r:es), ann)) } + -- No bangs; behave just like the next case + | not (isRdrDataCon op) -- We have found the function! + = return (Just (cL loc' op, Infix, (l:r:es), ann)) + | otherwise -- Infix data con; keep going + = do { mb_l <- go l es ann + ; case mb_l of + Just (op', Infix, j : k : es', ann') + -> return (Just (op', Infix, j : op_app : es', ann')) + where + op_app = cL loc (OpApp noExt k + (cL loc' (HsVar noExt (cL loc' op))) r) + _ -> return Nothing } + go _ _ _ = return Nothing + +-- | Either an operator or an operand. +data TyEl = TyElOpr RdrName | TyElOpd (HsType GhcPs) + | TyElKindApp SrcSpan (LHsType GhcPs) + -- See Note [TyElKindApp SrcSpan interpretation] + | TyElTilde | TyElBang + | TyElUnpackedness ([AddAnn], SourceText, SrcUnpackedness) + | TyElDocPrev HsDocString + + +{- Note [TyElKindApp SrcSpan interpretation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +A TyElKindApp captures type application written in haskell as + + @ Foo + +where Foo is some type. + +The SrcSpan reflects both elements, and there are AnnAt and AnnVal API +Annotations attached to this SrcSpan for the specific locations of +each within it. +-} + +instance Outputable TyEl where + ppr (TyElOpr name) = ppr name + ppr (TyElOpd ty) = ppr ty + ppr (TyElKindApp _ ki) = text "@" <> ppr ki + ppr TyElTilde = text "~" + ppr TyElBang = text "!" + ppr (TyElUnpackedness (_, _, unpk)) = ppr unpk + ppr (TyElDocPrev doc) = ppr doc + +tyElStrictness :: TyEl -> Maybe (AnnKeywordId, SrcStrictness) +tyElStrictness TyElTilde = Just (AnnTilde, SrcLazy) +tyElStrictness TyElBang = Just (AnnBang, SrcStrict) +tyElStrictness _ = Nothing + +-- | Extract a strictness/unpackedness annotation from the front of a reversed +-- 'TyEl' list. +pStrictMark + :: [Located TyEl] -- reversed TyEl + -> Maybe ( Located HsSrcBang {- a strictness/upnackedness marker -} + , [AddAnn] + , [Located TyEl] {- remaining TyEl -}) +pStrictMark ((dL->L l1 x1) : (dL->L l2 x2) : xs) + | Just (strAnnId, str) <- tyElStrictness x1 + , TyElUnpackedness (unpkAnns, prag, unpk) <- x2 + = Just ( cL (combineSrcSpans l1 l2) (HsSrcBang prag unpk str) + , unpkAnns ++ [\s -> addAnnotation s strAnnId l1] + , xs ) +pStrictMark ((dL->L l x1) : xs) + | Just (strAnnId, str) <- tyElStrictness x1 + = Just ( cL l (HsSrcBang NoSourceText NoSrcUnpack str) + , [\s -> addAnnotation s strAnnId l] + , xs ) +pStrictMark ((dL->L l x1) : xs) + | TyElUnpackedness (anns, prag, unpk) <- x1 + = Just ( cL l (HsSrcBang prag unpk NoSrcStrict) + , anns + , xs ) +pStrictMark _ = Nothing + +pBangTy + :: LHsType GhcPs -- a type to be wrapped inside HsBangTy + -> [Located TyEl] -- reversed TyEl + -> ( Bool {- has a strict mark been consumed? -} + , LHsType GhcPs {- the resulting BangTy -} + , P () {- add annotations -} + , [Located TyEl] {- remaining TyEl -}) +pBangTy lt@(dL->L l1 _) xs = + case pStrictMark xs of + Nothing -> (False, lt, pure (), xs) + Just (dL->L l2 strictMark, anns, xs') -> + let bl = combineSrcSpans l1 l2 + bt = HsBangTy noExt strictMark lt + in (True, cL bl bt, addAnnsAt bl anns, xs') + +-- | Merge a /reversed/ and /non-empty/ soup of operators and operands +-- into a type. +-- +-- User input: @F x y + G a b * X@ +-- Input to 'mergeOps': [X, *, b, a, G, +, y, x, F] +-- Output corresponds to what the user wrote assuming all operators are of the +-- same fixity and right-associative. +-- +-- It's a bit silly that we're doing it at all, as the renamer will have to +-- rearrange this, and it'd be easier to keep things separate. +-- +-- See Note [Parsing data constructors is hard] +mergeOps :: [Located TyEl] -> P (LHsType GhcPs) +mergeOps ((dL->L l1 (TyElOpd t)) : xs) + | (_, t', addAnns, xs') <- pBangTy (cL l1 t) xs + , null xs' -- We accept a BangTy only when there are no preceding TyEl. + = addAnns >> return t' +mergeOps all_xs = go (0 :: Int) [] id all_xs + where + -- NB. When modifying clauses in 'go', make sure that the reasoning in + -- Note [Non-empty 'acc' in mergeOps clause [end]] is still correct. + + -- clause [unpk]: + -- handle (NO)UNPACK pragmas + go k acc ops_acc ((dL->L l (TyElUnpackedness (anns, unpkSrc, unpk))):xs) = + if not (null acc) && null xs + then do { acc' <- eitherToP $ mergeOpsAcc acc + ; let a = ops_acc acc' + strictMark = HsSrcBang unpkSrc unpk NoSrcStrict + bl = combineSrcSpans l (getLoc a) + bt = HsBangTy noExt strictMark a + ; addAnnsAt bl anns + ; return (cL bl bt) } + else addFatalError l unpkError + where + unpkSDoc = case unpkSrc of + NoSourceText -> ppr unpk + SourceText str -> text str <> text " #-}" + unpkError + | not (null xs) = unpkSDoc <+> text "cannot appear inside a type." + | null acc && k == 0 = unpkSDoc <+> text "must be applied to a type." + | otherwise = + -- See Note [Impossible case in mergeOps clause [unpk]] + panic "mergeOps.UNPACK: impossible position" + + -- clause [doc]: + -- we do not expect to encounter any docs + go _ _ _ ((dL->L l (TyElDocPrev _)):_) = + failOpDocPrev l + + -- to improve error messages, we do a bit of guesswork to determine if the + -- user intended a '!' or a '~' as a strictness annotation + go k acc ops_acc ((dL->L l x) : xs) + | Just (_, str) <- tyElStrictness x + , let guess [] = True + guess ((dL->L _ (TyElOpd _)):_) = False + guess ((dL->L _ (TyElOpr _)):_) = True + guess ((dL->L _ (TyElKindApp _ _)):_) = False + guess ((dL->L _ (TyElTilde)):_) = True + guess ((dL->L _ (TyElBang)):_) = True + guess ((dL->L _ (TyElUnpackedness _)):_) = True + guess ((dL->L _ (TyElDocPrev _)):xs') = guess xs' + guess _ = panic "mergeOps.go.guess: Impossible Match" + -- due to #15884 + in guess xs + = if not (null acc) && (k > 1 || length acc > 1) + then do { a <- eitherToP (mergeOpsAcc acc) + ; failOpStrictnessCompound (cL l str) (ops_acc a) } + else failOpStrictnessPosition (cL l str) + + -- clause [opr]: + -- when we encounter an operator, we must have accumulated + -- something for its rhs, and there must be something left + -- to build its lhs. + go k acc ops_acc ((dL->L l (TyElOpr op)):xs) = + if null acc || null (filter isTyElOpd xs) + then failOpFewArgs (cL l op) + else do { acc' <- eitherToP (mergeOpsAcc acc) + ; go (k + 1) [] (\c -> mkLHsOpTy c (cL l op) (ops_acc acc')) xs } + where + isTyElOpd (dL->L _ (TyElOpd _)) = True + isTyElOpd _ = False + + -- clause [opr.1]: interpret 'TyElTilde' as an operator + go k acc ops_acc ((dL->L l TyElTilde):xs) = + let op = eqTyCon_RDR + in go k acc ops_acc (cL l (TyElOpr op):xs) + + -- clause [opr.2]: interpret 'TyElBang' as an operator + go k acc ops_acc ((dL->L l TyElBang):xs) = + let op = mkUnqual tcClsName (fsLit "!") + in go k acc ops_acc (cL l (TyElOpr op):xs) + + -- clause [opd]: + -- whenever an operand is encountered, it is added to the accumulator + go k acc ops_acc ((dL->L l (TyElOpd a)):xs) = go k (HsValArg (cL l a):acc) ops_acc xs + + -- clause [tyapp]: + -- whenever a type application is encountered, it is added to the accumulator + go k acc ops_acc ((dL->L _ (TyElKindApp l a)):xs) = go k (HsTypeArg l a:acc) ops_acc xs + + -- clause [end] + -- See Note [Non-empty 'acc' in mergeOps clause [end]] + go _ acc ops_acc [] = do { acc' <- eitherToP (mergeOpsAcc acc) + ; return (ops_acc acc') } + + go _ _ _ _ = panic "mergeOps.go: Impossible Match" + -- due to #15884 + +mergeOpsAcc :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)] + -> Either (SrcSpan, SDoc) (LHsType GhcPs) +mergeOpsAcc [] = panic "mergeOpsAcc: empty input" +mergeOpsAcc (HsTypeArg _ (L loc ki):_) + = Left (loc, text "Unexpected type application:" <+> ppr ki) +mergeOpsAcc (HsValArg ty : xs) = go1 ty xs + where + go1 :: LHsType GhcPs + -> [HsArg (LHsType GhcPs) (LHsKind GhcPs)] + -> Either (SrcSpan, SDoc) (LHsType GhcPs) + go1 lhs [] = Right lhs + go1 lhs (x:xs) = case x of + HsValArg ty -> go1 (mkHsAppTy lhs ty) xs + HsTypeArg loc ki -> let ty = mkHsAppKindTy loc lhs ki + in go1 ty xs + HsArgPar _ -> go1 lhs xs +mergeOpsAcc (HsArgPar _: xs) = mergeOpsAcc xs + +{- Note [Impossible case in mergeOps clause [unpk]] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This case should never occur. Let us consider all possible +variations of 'acc', 'xs', and 'k': + + acc xs k +============================== + null | null 0 -- "must be applied to a type" + null | not null 0 -- "must be applied to a type" +not null | null 0 -- successful parse +not null | not null 0 -- "cannot appear inside a type" + null | null >0 -- handled in clause [opr] + null | not null >0 -- "cannot appear inside a type" +not null | null >0 -- successful parse +not null | not null >0 -- "cannot appear inside a type" + +The (null acc && null xs && k>0) case is handled in clause [opr] +by the following check: + + if ... || null (filter isTyElOpd xs) + then failOpFewArgs (L l op) + +We know that this check has been performed because k>0, and by +the time we reach the end of the list (null xs), the only way +for (null acc) to hold is that there was not a single TyElOpd +between the operator and the end of the list. But this case is +caught by the check and reported as 'failOpFewArgs'. +-} + +{- Note [Non-empty 'acc' in mergeOps clause [end]] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In clause [end] we need to know that 'acc' is non-empty to call 'mergeAcc' +without a check. + +Running 'mergeOps' with an empty input list is forbidden, so we do not consider +this possibility. This means we'll hit at least one other clause before we +reach clause [end]. + +* Clauses [unpk] and [doc] do not call 'go' recursively, so we cannot hit + clause [end] from there. +* Clause [opd] makes 'acc' non-empty, so if we hit clause [end] after it, 'acc' + will be non-empty. +* Clause [opr] checks that (filter isTyElOpd xs) is not null - so we are going + to hit clause [opd] at least once before we reach clause [end], making 'acc' + non-empty. +* There are no other clauses. + +Therefore, it is safe to omit a check for non-emptiness of 'acc' in clause +[end]. + +-} + +pInfixSide :: [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl]) +pInfixSide ((dL->L l (TyElOpd t)):xs) + | (True, t', addAnns, xs') <- pBangTy (cL l t) xs + = Just (t', addAnns, xs') +pInfixSide (el:xs1) + | Just t1 <- pLHsTypeArg el + = go [t1] xs1 + where + go :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)] + -> [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl]) + go acc (el:xs) + | Just t <- pLHsTypeArg el + = go (t:acc) xs + go acc xs = case mergeOpsAcc acc of + Left _ -> Nothing + Right acc' -> Just (acc', pure (), xs) +pInfixSide _ = Nothing + +pLHsTypeArg :: Located TyEl -> Maybe (HsArg (LHsType GhcPs) (LHsKind GhcPs)) +pLHsTypeArg (dL->L l (TyElOpd a)) = Just (HsValArg (L l a)) +pLHsTypeArg (dL->L _ (TyElKindApp l a)) = Just (HsTypeArg l a) +pLHsTypeArg _ = Nothing + +pDocPrev :: [Located TyEl] -> (Maybe LHsDocString, [Located TyEl]) +pDocPrev = go Nothing + where + go mTrailingDoc ((dL->L l (TyElDocPrev doc)):xs) = + go (mTrailingDoc `mplus` Just (cL l doc)) xs + go mTrailingDoc xs = (mTrailingDoc, xs) + +orErr :: Maybe a -> b -> Either b a +orErr (Just a) _ = Right a +orErr Nothing b = Left b + +{- Note [isFunLhs vs mergeDataCon] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When parsing a function LHS, we do not know whether to treat (!) as +a strictness annotation or an infix operator: + + f ! a = ... + +Without -XBangPatterns, this parses as (!) f a = ... + with -XBangPatterns, this parses as f (!a) = ... + +So in function declarations we opted to always parse as if -XBangPatterns +were off, and then rejig in 'isFunLhs'. + +There are two downsides to this approach: + +1. It is not particularly elegant, as there's a point in our pipeline where + the representation is awfully incorrect. For instance, + f !a b !c = ... + will be first parsed as + (f ! a b) ! c = ... + +2. There are cases that it fails to cover, for instance infix declarations: + !a + !b = ... + will trigger an error. + +Unfortunately, we cannot define different productions in the 'happy' grammar +depending on whether -XBangPatterns are enabled. + +When parsing data constructors, we face a similar issue: + (a) data T1 = C ! D + (b) data T2 = C ! D => ... + +In (a) the first bang is a strictness annotation, but in (b) it is a type +operator. A 'happy'-based parser does not have unlimited lookahead to check for +=>, so we must first parse (C ! D) into a common representation. + +If we tried to mirror the approach used in functions, we would parse both sides +of => as types, and then rejig. However, we take a different route and use an +intermediate data structure, a reversed list of 'TyEl'. +See Note [Parsing data constructors is hard] for details. + +This approach does not suffer from the issues of 'isFunLhs': + +1. A sequence of 'TyEl' is a dedicated intermediate representation, not an + incorrectly parsed type. Therefore, we do not have confusing states in our + pipeline. (Except for representing data constructors as type variables). + +2. We can handle infix data constructors with strictness annotations: + data T a b = !a :+ !b + +-} + + +-- | Merge a /reversed/ and /non-empty/ soup of operators and operands +-- into a data constructor. +-- +-- User input: @C !A B -- ^ doc@ +-- Input to 'mergeDataCon': ["doc", B, !, A, C] +-- Output: (C, PrefixCon [!A, B], "doc") +-- +-- See Note [Parsing data constructors is hard] +-- See Note [isFunLhs vs mergeDataCon] +mergeDataCon + :: [Located TyEl] + -> P ( Located RdrName -- constructor name + , HsConDeclDetails GhcPs -- constructor field information + , Maybe LHsDocString -- docstring to go on the constructor + ) +mergeDataCon all_xs = + do { (addAnns, a) <- eitherToP res + ; addAnns + ; return a } + where + -- We start by splitting off the trailing documentation comment, + -- if any exists. + (mTrailingDoc, all_xs') = pDocPrev all_xs + + -- Determine whether the trailing documentation comment exists and is the + -- only docstring in this constructor declaration. + -- + -- When true, it means that it applies to the constructor itself: + -- data T = C + -- A + -- B -- ^ Comment on C (singleDoc == True) + -- + -- When false, it means that it applies to the last field: + -- data T = C -- ^ Comment on C + -- A -- ^ Comment on A + -- B -- ^ Comment on B (singleDoc == False) + singleDoc = isJust mTrailingDoc && + null [ () | (dL->L _ (TyElDocPrev _)) <- all_xs' ] + + -- The result of merging the list of reversed TyEl into a + -- data constructor, along with [AddAnn]. + res = goFirst all_xs' + + -- Take the trailing docstring into account when interpreting + -- the docstring near the constructor. + -- + -- data T = C -- ^ docstring right after C + -- A + -- B -- ^ trailing docstring + -- + -- 'mkConDoc' must be applied to the docstring right after C, so that it + -- falls back to the trailing docstring when appropriate (see singleDoc). + mkConDoc mDoc | singleDoc = mDoc `mplus` mTrailingDoc + | otherwise = mDoc + + -- The docstring for the last field of a data constructor. + trailingFieldDoc | singleDoc = Nothing + | otherwise = mTrailingDoc + + goFirst [ dL->L l (TyElOpd (HsTyVar _ _ (dL->L _ tc))) ] + = do { data_con <- tyConToDataCon l tc + ; return (pure (), (data_con, PrefixCon [], mTrailingDoc)) } + goFirst ((dL->L l (TyElOpd (HsRecTy _ fields))):xs) + | (mConDoc, xs') <- pDocPrev xs + , [ dL->L l' (TyElOpd (HsTyVar _ _ (dL->L _ tc))) ] <- xs' + = do { data_con <- tyConToDataCon l' tc + ; let mDoc = mTrailingDoc `mplus` mConDoc + ; return (pure (), (data_con, RecCon (cL l fields), mDoc)) } + goFirst [dL->L l (TyElOpd (HsTupleTy _ HsBoxedOrConstraintTuple ts))] + = return ( pure () + , ( cL l (getRdrName (tupleDataCon Boxed (length ts))) + , PrefixCon ts + , mTrailingDoc ) ) + goFirst ((dL->L l (TyElOpd t)):xs) + | (_, t', addAnns, xs') <- pBangTy (cL l t) xs + = go addAnns Nothing [mkLHsDocTyMaybe t' trailingFieldDoc] xs' + goFirst (L l (TyElKindApp _ _):_) + = goInfix Monoid.<> Left (l, kindAppErr) + goFirst xs + = go (pure ()) mTrailingDoc [] xs + + go addAnns mLastDoc ts [ dL->L l (TyElOpd (HsTyVar _ _ (dL->L _ tc))) ] + = do { data_con <- tyConToDataCon l tc + ; return (addAnns, (data_con, PrefixCon ts, mkConDoc mLastDoc)) } + go addAnns mLastDoc ts ((dL->L l (TyElDocPrev doc)):xs) = + go addAnns (mLastDoc `mplus` Just (cL l doc)) ts xs + go addAnns mLastDoc ts ((dL->L l (TyElOpd t)):xs) + | (_, t', addAnns', xs') <- pBangTy (cL l t) xs + , t'' <- mkLHsDocTyMaybe t' mLastDoc + = go (addAnns >> addAnns') Nothing (t'':ts) xs' + go _ _ _ ((dL->L _ (TyElOpr _)):_) = + -- Encountered an operator: backtrack to the beginning and attempt + -- to parse as an infix definition. + goInfix + go _ _ _ (L l (TyElKindApp _ _):_) = goInfix Monoid.<> Left (l, kindAppErr) + go _ _ _ _ = Left malformedErr + where + malformedErr = + ( foldr combineSrcSpans noSrcSpan (map getLoc all_xs') + , text "Cannot parse data constructor" <+> + text "in a data/newtype declaration:" $$ + nest 2 (hsep . reverse $ map ppr all_xs')) + + goInfix = + do { let xs0 = all_xs' + ; (rhs_t, rhs_addAnns, xs1) <- pInfixSide xs0 `orErr` malformedErr + ; let (mOpDoc, xs2) = pDocPrev xs1 + ; (op, xs3) <- case xs2 of + (dL->L l (TyElOpr op)) : xs3 -> + do { data_con <- tyConToDataCon l op + ; return (data_con, xs3) } + _ -> Left malformedErr + ; let (mLhsDoc, xs4) = pDocPrev xs3 + ; (lhs_t, lhs_addAnns, xs5) <- pInfixSide xs4 `orErr` malformedErr + ; unless (null xs5) (Left malformedErr) + ; let rhs = mkLHsDocTyMaybe rhs_t trailingFieldDoc + lhs = mkLHsDocTyMaybe lhs_t mLhsDoc + addAnns = lhs_addAnns >> rhs_addAnns + ; return (addAnns, (op, InfixCon lhs rhs, mkConDoc mOpDoc)) } + where + malformedErr = + ( foldr combineSrcSpans noSrcSpan (map getLoc all_xs') + , text "Cannot parse an infix data constructor" <+> + text "in a data/newtype declaration:" $$ + nest 2 (hsep . reverse $ map ppr all_xs')) + + kindAppErr = + text "Unexpected kind application" <+> + text "in a data/newtype declaration:" $$ + nest 2 (hsep . reverse $ map ppr all_xs') + +--------------------------------------------------------------------------- +-- | Check for monad comprehensions +-- +-- If the flag MonadComprehensions is set, return a 'MonadComp' context, +-- otherwise use the usual 'ListComp' context + +checkMonadComp :: P (HsStmtContext Name) +checkMonadComp = do + monadComprehensions <- getBit MonadComprehensionsBit + return $ if monadComprehensions + then MonadComp + else ListComp + +-- ------------------------------------------------------------------------- +-- Expression/command ambiguity (arrow syntax). +-- See Note [Ambiguous syntactic categories] +-- + +-- ExpCmdP as defined is isomorphic to a pair of parsers: +-- +-- data ExpCmdP = ExpCmdP { expP :: PV (LHsExpr GhcPs) +-- , cmdP :: PV (LHsCmd GhcPs) } +-- +-- See Note [Parser-Validator] +-- See Note [Ambiguous syntactic categories] +newtype ExpCmdP = + ExpCmdP { runExpCmdP :: forall b. ExpCmdI b => PV (Located (b GhcPs)) } + +-- See Note [Ambiguous syntactic categories] +data ExpCmdG b where + ExpG :: ExpCmdG HsExpr + CmdG :: ExpCmdG HsCmd + +-- See Note [Ambiguous syntactic categories] +class ExpCmdI b where expCmdG :: ExpCmdG b +instance ExpCmdI HsExpr where expCmdG = ExpG +instance ExpCmdI HsCmd where expCmdG = CmdG + +ecFromCmd :: LHsCmd GhcPs -> ExpCmdP +ecFromCmd c@(getLoc -> l) = ExpCmdP onB + where + onB :: forall b. ExpCmdI b => PV (Located (b GhcPs)) + onB = case expCmdG @b of { ExpG -> onExp; CmdG -> return c } + onExp :: P (LHsExpr GhcPs) + onExp = do + addError l $ vcat + [ text "Arrow command found where an expression was expected:", + nest 2 (ppr c) ] + return (cL l hsHoleExpr) + +ecFromExp :: LHsExpr GhcPs -> ExpCmdP +ecFromExp e@(getLoc -> l) = ExpCmdP onB + where + onB :: forall b. ExpCmdI b => PV (Located (b GhcPs)) + onB = case expCmdG @b of { ExpG -> return e; CmdG -> onCmd } + onCmd :: P (LHsCmd GhcPs) + onCmd = + addFatalError l $ + text "Parse error in command:" <+> ppr e + +hsHoleExpr :: HsExpr (GhcPass id) +hsHoleExpr = HsUnboundVar noExt (TrueExprHole (mkVarOcc "_")) + +ecHsLam :: forall b. ExpCmdI b => MatchGroup GhcPs (Located (b GhcPs)) -> b GhcPs +ecHsLam = case expCmdG @b of { ExpG -> HsLam noExt; CmdG -> HsCmdLam noExt } + +ecHsLet :: forall b. ExpCmdI b => LHsLocalBinds GhcPs -> Located (b GhcPs) -> b GhcPs +ecHsLet = case expCmdG @b of { ExpG -> HsLet noExt; CmdG -> HsCmdLet noExt } + +ecOpApp :: forall b. ExpCmdI b => Located (b GhcPs) -> LHsExpr GhcPs + -> Located (b GhcPs) -> b GhcPs +ecOpApp = case expCmdG @b of { ExpG -> OpApp noExt; CmdG -> cmdOpApp } + where + cmdOpApp c1 op c2 = + let cmdArg c = cL (getLoc c) $ HsCmdTop noExt c in + HsCmdArrForm noExt op Infix Nothing [cmdArg c1, cmdArg c2] + +ecHsCase :: forall b. ExpCmdI b => + LHsExpr GhcPs -> MatchGroup GhcPs (Located (b GhcPs)) -> b GhcPs +ecHsCase = case expCmdG @b of { ExpG -> HsCase noExt; CmdG -> HsCmdCase noExt } + +ecHsApp :: forall b. ExpCmdI b => + Located (b GhcPs) -> LHsExpr GhcPs -> b GhcPs +ecHsApp = case expCmdG @b of { ExpG -> HsApp noExt; CmdG -> HsCmdApp noExt } + +ecHsIf :: forall b. ExpCmdI b => + LHsExpr GhcPs -> Located (b GhcPs) -> Located (b GhcPs) -> b GhcPs +ecHsIf = case expCmdG @b of { ExpG -> mkHsIf; CmdG -> mkHsCmdIf } + +ecHsDo :: forall b. ExpCmdI b => + Located [LStmt GhcPs (Located (b GhcPs))] -> b GhcPs +ecHsDo = case expCmdG @b of { ExpG -> HsDo noExt DoExpr; CmdG -> HsCmdDo noExt } + +ecHsPar :: forall b. ExpCmdI b => Located (b GhcPs) -> b GhcPs +ecHsPar = case expCmdG @b of { ExpG -> HsPar noExt; CmdG -> HsCmdPar noExt } + +{- Note [Ambiguous syntactic categories] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +There are places in the grammar where we do not know whether we are parsing an +expression or a pattern without unlimited lookahead (which we do not have in +'happy'): + +View patterns: + + f (Con a b ) = ... -- 'Con a b' is a pattern + f (Con a b -> x) = ... -- 'Con a b' is an expression + +do-notation: + + do { Con a b <- x } -- 'Con a b' is a pattern + do { Con a b } -- 'Con a b' is an expression + +Guards: + + x | True <- p && q = ... -- 'True' is a pattern + x | True = ... -- 'True' is an expression + +Top-level value/function declarations (FunBind/PatBind): + + f !a -- TH splice + f !a = ... -- function declaration + + Until we encounter the = sign, we don't know if it's a top-level + TemplateHaskell splice where ! is an infix operator, or if it's a function + declaration where ! is a strictness annotation. + +There are also places in the grammar where we do not know whether we are +parsing an expression or a command: + + proc x -> do { (stuff) -< x } -- 'stuff' is an expression + proc x -> do { (stuff) } -- 'stuff' is a command + + Until we encounter arrow syntax (-<) we don't know whether to parse 'stuff' + as an expression or a command. + +In fact, do-notation is subject to both ambiguities: + + proc x -> do { (stuff) -< x } -- 'stuff' is an expression + proc x -> do { (stuff) <- f -< x } -- 'stuff' is a pattern + proc x -> do { (stuff) } -- 'stuff' is a command + +There are many possible solutions to this problem. For an overview of the ones +we decided against, see Note [Resolving parsing ambiguities: non-taken alternatives] + +The solution that keeps basic definitions (such as HsExpr) clean, keeps the +concerns local to the parser, and does not require duplication of hsSyn types, +or an extra pass over the entire AST, is to parse into a function from a GADT +to a parser-validator: + + data ExpCmdG b where + ExpG :: ExpCmdG HsExpr + CmdG :: ExpCmdG HsCmd + + type ExpCmd = forall b. ExpCmdG b -> PV (Located (b GhcPs)) + + checkExp :: ExpCmd -> PV (LHsExpr GhcPs) + checkCmd :: ExpCmd -> PV (LHsCmd GhcPs) + checkExp f = f ExpG -- interpret as an expression + checkCmd f = f CmdG -- interpret as a command + +Consider the 'alts' production used to parse case-of alternatives: + + alts :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) } + : alts1 { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } + | ';' alts { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } + +We abstract over LHsExpr, and it becomes: + + alts :: { forall b. ExpCmdG b -> PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) } + : alts1 + { \tag -> $1 tag >>= \ $1 -> + return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } + | ';' alts + { \tag -> $2 tag >>= \ $2 -> + return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } + +Note that 'ExpCmdG' is a singleton type, the value is completely +determined by the type: + + when (b~HsExpr), tag = ExpG + when (b~HsCmd), tag = CmdG + +This is a clear indication that we can use a class to pass this value behind +the scenes: + + class ExpCmdI b where expCmdG :: ExpCmdG b + instance ExpCmdI HsExpr where expCmdG = ExpG + instance ExpCmdI HsCmd where expCmdG = CmdG + +And now the 'alts' production is simplified, as we no longer need to +thread 'tag' explicitly: + + alts :: { forall b. ExpCmdI b => PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) } + : alts1 { $1 >>= \ $1 -> + return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } + | ';' alts { $2 >>= \ $2 -> + return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } + +Compared to the initial definition, the added bits are: + + forall b. ExpCmdI b => PV ( ... ) -- in the type signature + $1 >>= \ $1 -> return $ -- in one reduction rule + $2 >>= \ $2 -> return $ -- in another reduction rule + +The overhead is constant relative to the size of the rest of the reduction +rule, so this approach scales well to large parser productions. + +-} + + +{- Note [Resolving parsing ambiguities: non-taken alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Alternative I, extra constructors in HsExpr +------------------------------------------- +We could add extra constructors to HsExpr to represent command-specific and +pattern-specific syntactic constructs. Under this scheme, we parse patterns +and commands as expressions and rejig later. This is what GHC used to do, and +it polluted 'HsExpr' with irrelevant constructors: + + * for commands: 'HsArrForm', 'HsArrApp' + * for patterns: 'EWildPat', 'EAsPat', 'EViewPat', 'ELazyPat' + +(As of now, we still do that for patterns, but we plan to fix it). + +There are several issues with this: + + * The implementation details of parsing are leaking into hsSyn definitions. + + * Code that uses HsExpr has to panic on these impossible-after-parsing cases. + + * HsExpr is arbitrarily selected as the extension basis. Why not extend + HsCmd or HsPat with extra constructors instead? + + * We cannot handle corner cases. For instance, the following function + declaration LHS is not a valid expression (see #1087): + + !a + !b = ... + + * There are points in the pipeline where the representation was awfully + incorrect. For instance, + + f !a b !c = ... + + is first parsed as + + (f ! a b) ! c = ... + + +Alternative II, extra constructors in HsExpr for GhcPs +------------------------------------------------------ +We could address some of the problems with Alternative I by using Trees That +Grow and extending HsExpr only in the GhcPs pass. However, GhcPs corresponds to +the output of parsing, not to its intermediate results, so we wouldn't want +them there either. + +Alternative III, extra constructors in HsExpr for GhcPrePs +---------------------------------------------------------- +We could introduce a new pass, GhcPrePs, to keep GhcPs pristine. +Unfortunately, creating a new pass would significantly bloat conversion code +and slow down the compiler by adding another linear-time pass over the entire +AST. For example, in order to build HsExpr GhcPrePs, we would need to build +HsLocalBinds GhcPrePs (as part of HsLet), and we never want HsLocalBinds +GhcPrePs. + + +Alternative IV, sum type and bottom-up data flow +------------------------------------------------ +Expressions and commands are disjoint. There are no user inputs that could be +interpreted as either an expression or a command depending on outer context: + + 5 -- definitely an expression + x -< y -- definitely a command + +Even though we have both 'HsLam' and 'HsCmdLam', we can look at +the body to disambiguate: + + \p -> 5 -- definitely an expression + \p -> x -< y -- definitely a command + +This means we could use a bottom-up flow of information to determine +whether we are parsing an expression or a command, using a sum type +for intermediate results: + + Either (LHsExpr GhcPs) (LHsCmd GhcPs) + +There are two problems with this: + + * We cannot handle the ambiguity between expressions and + patterns, which are not disjoint. + + * Bottom-up flow of information leads to poor error messages. Consider + + if ... then 5 else (x -< y) + + Do we report that '5' is not a valid command or that (x -< y) is not a + valid expression? It depends on whether we want the entire node to be + 'HsIf' or 'HsCmdIf', and this information flows top-down, from the + surrounding parsing context (are we in 'proc'?) + +Alternative V, backtracking with parser combinators +--------------------------------------------------- +One might think we could sidestep the issue entirely by using a backtracking +parser and doing something along the lines of (try pExpr <|> pPat). + +Turns out, this wouldn't work very well, as there can be patterns inside +expressions (e.g. via 'case', 'let', 'do') and expressions inside patterns +(e.g. view patterns). To handle this, we would need to backtrack while +backtracking, and unbound levels of backtracking lead to very fragile +performance. + +Alternative VI, an intermediate data type +----------------------------------------- +There are common syntactic elements of expressions, commands, and patterns +(e.g. all of them must have balanced parentheses), and we can capture this +common structure in an intermediate data type, Frame: + +data Frame + = FrameVar RdrName + -- ^ Identifier: Just, map, BS.length + | FrameTuple [LTupArgFrame] Boxity + -- ^ Tuple (section): (a,b) (a,b,c) (a,,) (,a,) + | FrameTySig LFrame (LHsSigWcType GhcPs) + -- ^ Type signature: x :: ty + | FramePar (SrcSpan, SrcSpan) LFrame + -- ^ Parentheses + | FrameIf LFrame LFrame LFrame + -- ^ If-expression: if p then x else y + | FrameCase LFrame [LFrameMatch] + -- ^ Case-expression: case x of { p1 -> e1; p2 -> e2 } + | FrameDo (HsStmtContext Name) [LFrameStmt] + -- ^ Do-expression: do { s1; a <- s2; s3 } + ... + | FrameExpr (HsExpr GhcPs) -- unambiguously an expression + | FramePat (HsPat GhcPs) -- unambiguously a pattern + | FrameCommand (HsCmd GhcPs) -- unambiguously a command + +To determine which constructors 'Frame' needs to have, we take the union of +intersections between HsExpr, HsCmd, and HsPat. + +The intersection between HsPat and HsExpr: + + HsPat = VarPat | TuplePat | SigPat | ParPat | ... + HsExpr = HsVar | ExplicitTuple | ExprWithTySig | HsPar | ... + ------------------------------------------------------------------- + Frame = FrameVar | FrameTuple | FrameTySig | FramePar | ... + +The intersection between HsCmd and HsExpr: + + HsCmd = HsCmdIf | HsCmdCase | HsCmdDo | HsCmdPar + HsExpr = HsIf | HsCase | HsDo | HsPar + ------------------------------------------------ + Frame = FrameIf | FrameCase | FrameDo | FramePar + +The intersection between HsCmd and HsPat: + + HsPat = ParPat | ... + HsCmd = HsCmdPar | ... + ----------------------- + Frame = FramePar | ... + +Take the union of each intersection and this yields the final 'Frame' data +type. The problem with this approach is that we end up duplicating a good +portion of hsSyn: + + Frame for HsExpr, HsPat, HsCmd + TupArgFrame for HsTupArg + FrameMatch for Match + FrameStmt for StmtLR + FrameGRHS for GRHS + FrameGRHSs for GRHSs + ... + +Alternative VII, a product type +------------------------------- +We could avoid the intermediate representation of Alternative VI by parsing +into a product of interpretations directly: + + -- See Note [Parser-Validator] + type ExpCmdPat = ( PV (LHsExpr GhcPs) + , PV (LHsCmd GhcPs) + , PV (LHsPat GhcPs) ) + +This means that in positions where we do not know whether to produce +expression, a pattern, or a command, we instead produce a parser-validator for +each possible option. + +Then, as soon as we have parsed far enough to resolve the ambiguity, we pick +the appropriate component of the product, discarding the rest: + + checkExpOf3 (e, _, _) = e -- interpret as an expression + checkCmdOf3 (_, c, _) = c -- interpret as a command + checkPatOf3 (_, _, p) = p -- interpret as a pattern + +We can easily define ambiguities between arbitrary subsets of interpretations. +For example, when we know ahead of type that only an expression or a command is +possible, but not a pattern, we can use a smaller type: + + -- See Note [Parser-Validator] + type ExpCmd = (PV (LHsExpr GhcPs), PV (LHsCmd GhcPs)) + + checkExpOf2 (e, _) = e -- interpret as an expression + checkCmdOf2 (_, c) = c -- interpret as a command + +However, there is a slight problem with this approach, namely code duplication +in parser productions. Consider the 'alts' production used to parse case-of +alternatives: + + alts :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) } + : alts1 { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) } + | ';' alts { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) } + +Under the new scheme, we have to completely duplicate its type signature and +each reduction rule: + + alts :: { ( PV (Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)])) -- as an expression + , PV (Located ([AddAnn],[LMatch GhcPs (LHsCmd GhcPs)])) -- as a command + ) } + : alts1 + { ( checkExpOf2 $1 >>= \ $1 -> + return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) + , checkCmdOf2 $1 >>= \ $1 -> + return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) + ) } + | ';' alts + { ( checkExpOf2 $2 >>= \ $2 -> + return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) + , checkCmdOf2 $2 >>= \ $2 -> + return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) + ) } + +And the same goes for other productions: 'altslist', 'alts1', 'alt', 'alt_rhs', +'ralt', 'gdpats', 'gdpat', 'exp', ... and so on. That is a lot of code! + +-} + +--------------------------------------------------------------------------- +-- Miscellaneous utilities + +-- | Check if a fixity is valid. We support bypassing the usual bound checks +-- for some special operators. +checkPrecP + :: Located (SourceText,Int) -- ^ precedence + -> Located (OrdList (Located RdrName)) -- ^ operators + -> P () +checkPrecP (dL->L l (_,i)) (dL->L _ ol) + | 0 <= i, i <= maxPrecedence = pure () + | all specialOp ol = pure () + | otherwise = addFatalError l (text ("Precedence out of range: " ++ show i)) + where + specialOp op = unLoc op `elem` [ eqTyCon_RDR + , getRdrName funTyCon ] + +mkRecConstrOrUpdate + :: LHsExpr GhcPs + -> SrcSpan + -> ([LHsRecField GhcPs (LHsExpr GhcPs)], Maybe SrcSpan) + -> P (HsExpr GhcPs) + +mkRecConstrOrUpdate (dL->L l (HsVar _ (dL->L _ c))) _ (fs,dd) + | isRdrDataCon c + = return (mkRdrRecordCon (cL l c) (mk_rec_fields fs dd)) +mkRecConstrOrUpdate exp _ (fs,dd) + | Just dd_loc <- dd = addFatalError dd_loc (text "You cannot use `..' in a record update") + | otherwise = return (mkRdrRecordUpd exp (map (fmap mk_rec_upd_field) fs)) + +mkRdrRecordUpd :: LHsExpr GhcPs -> [LHsRecUpdField GhcPs] -> HsExpr GhcPs +mkRdrRecordUpd exp flds + = RecordUpd { rupd_ext = noExt + , rupd_expr = exp + , rupd_flds = flds } + +mkRdrRecordCon :: Located RdrName -> HsRecordBinds GhcPs -> HsExpr GhcPs +mkRdrRecordCon con flds + = RecordCon { rcon_ext = noExt, rcon_con_name = con, rcon_flds = flds } + +mk_rec_fields :: [LHsRecField id arg] -> Maybe SrcSpan -> HsRecFields id arg +mk_rec_fields fs Nothing = HsRecFields { rec_flds = fs, rec_dotdot = Nothing } +mk_rec_fields fs (Just s) = HsRecFields { rec_flds = fs + , rec_dotdot = Just (cL s (length fs)) } + +mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs +mk_rec_upd_field (HsRecField (dL->L loc (FieldOcc _ rdr)) arg pun) + = HsRecField (L loc (Unambiguous noExt rdr)) arg pun +mk_rec_upd_field (HsRecField (dL->L _ (XFieldOcc _)) _ _) + = panic "mk_rec_upd_field" +mk_rec_upd_field (HsRecField _ _ _) + = panic "mk_rec_upd_field: Impossible Match" -- due to #15884 + +mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation + -> InlinePragma +-- The (Maybe Activation) is because the user can omit +-- the activation spec (and usually does) +mkInlinePragma src (inl, match_info) mb_act + = InlinePragma { inl_src = src -- Note [Pragma source text] in BasicTypes + , inl_inline = inl + , inl_sat = Nothing + , inl_act = act + , inl_rule = match_info } + where + act = case mb_act of + Just act -> act + Nothing -> -- No phase specified + case inl of + NoInline -> NeverActive + _other -> AlwaysActive + +----------------------------------------------------------------------------- +-- utilities for foreign declarations + +-- construct a foreign import declaration +-- +mkImport :: Located CCallConv + -> Located Safety + -> (Located StringLiteral, Located RdrName, LHsSigType GhcPs) + -> P (HsDecl GhcPs) +mkImport cconv safety (L loc (StringLiteral esrc entity), v, ty) = + case unLoc cconv of + CCallConv -> mkCImport + CApiConv -> mkCImport + StdCallConv -> mkCImport + PrimCallConv -> mkOtherImport + JavaScriptCallConv -> mkOtherImport + where + -- Parse a C-like entity string of the following form: + -- "[static] [chname] [&] [cid]" | "dynamic" | "wrapper" + -- If 'cid' is missing, the function name 'v' is used instead as symbol + -- name (cf section 8.5.1 in Haskell 2010 report). + mkCImport = do + let e = unpackFS entity + case parseCImport cconv safety (mkExtName (unLoc v)) e (cL loc esrc) of + Nothing -> addFatalError loc (text "Malformed entity string") + Just importSpec -> returnSpec importSpec + + -- currently, all the other import conventions only support a symbol name in + -- the entity string. If it is missing, we use the function name instead. + mkOtherImport = returnSpec importSpec + where + entity' = if nullFS entity + then mkExtName (unLoc v) + else entity + funcTarget = CFunction (StaticTarget esrc entity' Nothing True) + importSpec = CImport cconv safety Nothing funcTarget (cL loc esrc) + + returnSpec spec = return $ ForD noExt $ ForeignImport + { fd_i_ext = noExt + , fd_name = v + , fd_sig_ty = ty + , fd_fi = spec + } + + + +-- the string "foo" is ambiguous: either a header or a C identifier. The +-- C identifier case comes first in the alternatives below, so we pick +-- that one. +parseCImport :: Located CCallConv -> Located Safety -> FastString -> String + -> Located SourceText + -> Maybe ForeignImport +parseCImport cconv safety nm str sourceText = + listToMaybe $ map fst $ filter (null.snd) $ + readP_to_S parse str + where + parse = do + skipSpaces + r <- choice [ + string "dynamic" >> return (mk Nothing (CFunction DynamicTarget)), + string "wrapper" >> return (mk Nothing CWrapper), + do optional (token "static" >> skipSpaces) + ((mk Nothing <$> cimp nm) +++ + (do h <- munch1 hdr_char + skipSpaces + mk (Just (Header (SourceText h) (mkFastString h))) + <$> cimp nm)) + ] + skipSpaces + return r + + token str = do _ <- string str + toks <- look + case toks of + c : _ + | id_char c -> pfail + _ -> return () + + mk h n = CImport cconv safety h n sourceText + + hdr_char c = not (isSpace c) + -- header files are filenames, which can contain + -- pretty much any char (depending on the platform), + -- so just accept any non-space character + id_first_char c = isAlpha c || c == '_' + id_char c = isAlphaNum c || c == '_' + + cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid) + +++ (do isFun <- case unLoc cconv of + CApiConv -> + option True + (do token "value" + skipSpaces + return False) + _ -> return True + cid' <- cid + return (CFunction (StaticTarget NoSourceText cid' + Nothing isFun))) + where + cid = return nm +++ + (do c <- satisfy id_first_char + cs <- many (satisfy id_char) + return (mkFastString (c:cs))) + + +-- construct a foreign export declaration +-- +mkExport :: Located CCallConv + -> (Located StringLiteral, Located RdrName, LHsSigType GhcPs) + -> P (HsDecl GhcPs) +mkExport (dL->L lc cconv) (dL->L le (StringLiteral esrc entity), v, ty) + = return $ ForD noExt $ + ForeignExport { fd_e_ext = noExt, fd_name = v, fd_sig_ty = ty + , fd_fe = CExport (cL lc (CExportStatic esrc entity' cconv)) + (cL le esrc) } + where + entity' | nullFS entity = mkExtName (unLoc v) + | otherwise = entity + +-- Supplying the ext_name in a foreign decl is optional; if it +-- isn't there, the Haskell name is assumed. Note that no transformation +-- of the Haskell name is then performed, so if you foreign export (++), +-- it's external name will be "++". Too bad; it's important because we don't +-- want z-encoding (e.g. names with z's in them shouldn't be doubled) +-- +mkExtName :: RdrName -> CLabelString +mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm)) + +-------------------------------------------------------------------------------- +-- Help with module system imports/exports + +data ImpExpSubSpec = ImpExpAbs + | ImpExpAll + | ImpExpList [Located ImpExpQcSpec] + | ImpExpAllWith [Located ImpExpQcSpec] + +data ImpExpQcSpec = ImpExpQcName (Located RdrName) + | ImpExpQcType (Located RdrName) + | ImpExpQcWildcard + +mkModuleImpExp :: Located ImpExpQcSpec -> ImpExpSubSpec -> P (IE GhcPs) +mkModuleImpExp (dL->L l specname) subs = + case subs of + ImpExpAbs + | isVarNameSpace (rdrNameSpace name) + -> return $ IEVar noExt (cL l (ieNameFromSpec specname)) + | otherwise -> IEThingAbs noExt . cL l <$> nameT + ImpExpAll -> IEThingAll noExt . cL l <$> nameT + ImpExpList xs -> + (\newName -> IEThingWith noExt (cL l newName) + NoIEWildcard (wrapped xs) []) <$> nameT + ImpExpAllWith xs -> + do allowed <- getBit PatternSynonymsBit + if allowed + then + let withs = map unLoc xs + pos = maybe NoIEWildcard IEWildcard + (findIndex isImpExpQcWildcard withs) + ies = wrapped $ filter (not . isImpExpQcWildcard . unLoc) xs + in (\newName + -> IEThingWith noExt (cL l newName) pos ies []) + <$> nameT + else addFatalError l + (text "Illegal export form (use PatternSynonyms to enable)") + where + name = ieNameVal specname + nameT = + if isVarNameSpace (rdrNameSpace name) + then addFatalError l + (text "Expecting a type constructor but found a variable," + <+> quotes (ppr name) <> text "." + $$ if isSymOcc $ rdrNameOcc name + then text "If" <+> quotes (ppr name) + <+> text "is a type constructor" + <+> text "then enable ExplicitNamespaces and use the 'type' keyword." + else empty) + else return $ ieNameFromSpec specname + + ieNameVal (ImpExpQcName ln) = unLoc ln + ieNameVal (ImpExpQcType ln) = unLoc ln + ieNameVal (ImpExpQcWildcard) = panic "ieNameVal got wildcard" + + ieNameFromSpec (ImpExpQcName ln) = IEName ln + ieNameFromSpec (ImpExpQcType ln) = IEType ln + ieNameFromSpec (ImpExpQcWildcard) = panic "ieName got wildcard" + + wrapped = map (onHasSrcSpan ieNameFromSpec) + +mkTypeImpExp :: Located RdrName -- TcCls or Var name space + -> P (Located RdrName) +mkTypeImpExp name = + do allowed <- getBit ExplicitNamespacesBit + unless allowed $ addError (getLoc name) $ + text "Illegal keyword 'type' (use ExplicitNamespaces to enable)" + return (fmap (`setRdrNameSpace` tcClsName) name) + +checkImportSpec :: Located [LIE GhcPs] -> P (Located [LIE GhcPs]) +checkImportSpec ie@(dL->L _ specs) = + case [l | (dL->L l (IEThingWith _ _ (IEWildcard _) _ _)) <- specs] of + [] -> return ie + (l:_) -> importSpecError l + where + importSpecError l = + addFatalError l + (text "Illegal import form, this syntax can only be used to bundle" + $+$ text "pattern synonyms with types in module exports.") + +-- In the correct order +mkImpExpSubSpec :: [Located ImpExpQcSpec] -> P ([AddAnn], ImpExpSubSpec) +mkImpExpSubSpec [] = return ([], ImpExpList []) +mkImpExpSubSpec [dL->L _ ImpExpQcWildcard] = + return ([], ImpExpAll) +mkImpExpSubSpec xs = + if (any (isImpExpQcWildcard . unLoc) xs) + then return $ ([], ImpExpAllWith xs) + else return $ ([], ImpExpList xs) + +isImpExpQcWildcard :: ImpExpQcSpec -> Bool +isImpExpQcWildcard ImpExpQcWildcard = True +isImpExpQcWildcard _ = False + +----------------------------------------------------------------------------- +-- Warnings and failures + +warnStarIsType :: SrcSpan -> P () +warnStarIsType span = addWarning Opt_WarnStarIsType span msg + where + msg = text "Using" <+> quotes (text "*") + <+> text "(or its Unicode variant) to mean" + <+> quotes (text "Data.Kind.Type") + $$ text "relies on the StarIsType extension, which will become" + $$ text "deprecated in the future." + $$ text "Suggested fix: use" <+> quotes (text "Type") + <+> text "from" <+> quotes (text "Data.Kind") <+> text "instead." + +warnStarBndr :: SrcSpan -> P () +warnStarBndr span = addWarning Opt_WarnStarBinder span msg + where + msg = text "Found binding occurrence of" <+> quotes (text "*") + <+> text "yet StarIsType is enabled." + $$ text "NB. To use (or export) this operator in" + <+> text "modules with StarIsType," + $$ text " including the definition module, you must qualify it." + +failOpFewArgs :: Located RdrName -> P a +failOpFewArgs (dL->L loc op) = + do { star_is_type <- getBit StarIsTypeBit + ; let msg = too_few $$ starInfo star_is_type op + ; addFatalError loc msg } + where + too_few = text "Operator applied to too few arguments:" <+> ppr op + +failOpDocPrev :: SrcSpan -> P a +failOpDocPrev loc = addFatalError loc msg + where + msg = text "Unexpected documentation comment." + +failOpStrictnessCompound :: Located SrcStrictness -> LHsType GhcPs -> P a +failOpStrictnessCompound (dL->L _ str) (dL->L loc ty) = addFatalError loc msg + where + msg = text "Strictness annotation applied to a compound type." $$ + text "Did you mean to add parentheses?" $$ + nest 2 (ppr str <> parens (ppr ty)) + +failOpStrictnessPosition :: Located SrcStrictness -> P a +failOpStrictnessPosition (dL->L loc _) = addFatalError loc msg + where + msg = text "Strictness annotation cannot appear in this position." + +----------------------------------------------------------------------------- +-- Misc utils + +type PV = P -- See Note [Parser-Validator] + +{- Note [Parser-Validator] +~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When resolving ambiguities, we need to postpone failure to make a choice later. +For example, if we have ambiguity between some A and B, our parser could be + + abParser :: P (Maybe A, Maybe B) + +This way we can represent four possible outcomes of parsing: + + (Just a, Nothing) -- definitely A + (Nothing, Just b) -- definitely B + (Just a, Just b) -- either A or B + (Nothing, Nothing) -- neither A nor B + +However, if we want to report informative parse errors, accumulate warnings, +and add API annotations, we are better off using 'P' instead of 'Maybe': + + abParser :: P (P A, P B) + +So we have an outer layer of P that consumes the input and builds the inner +layer, which validates the input. + +For clarity, we introduce the notion of a parser-validator: a parser that does +not consume any input, but may fail or use other effects. Thus we have: + + abParser :: P (PV A, PV B) + +-} + +-- | Hint about bang patterns, assuming @BangPatterns@ is off. +hintBangPat :: SrcSpan -> HsExpr GhcPs -> P () +hintBangPat span e = do + bang_on <- getBit BangPatBit + unless bang_on $ + addFatalError span + (text "Illegal bang-pattern (use BangPatterns):" $$ ppr e) + +data SumOrTuple + = Sum ConTag Arity (LHsExpr GhcPs) + | Tuple [LHsTupArg GhcPs] + +mkSumOrTuple :: Boxity -> SrcSpan -> SumOrTuple -> P (HsExpr GhcPs) + +-- Tuple +mkSumOrTuple boxity _ (Tuple es) = return (ExplicitTuple noExt es boxity) + +-- Sum +mkSumOrTuple Unboxed _ (Sum alt arity e) = + return (ExplicitSum noExt alt arity e) +mkSumOrTuple Boxed l (Sum alt arity (dL->L _ e)) = + addFatalError l (hang (text "Boxed sums not supported:") 2 + (ppr_boxed_sum alt arity e)) + where + ppr_boxed_sum :: ConTag -> Arity -> HsExpr GhcPs -> SDoc + ppr_boxed_sum alt arity e = + text "(" <+> ppr_bars (alt - 1) <+> ppr e <+> ppr_bars (arity - alt) + <+> text ")" + + ppr_bars n = hsep (replicate n (Outputable.char '|')) + +mkLHsOpTy :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> LHsType GhcPs +mkLHsOpTy x op y = + let loc = getLoc x `combineSrcSpans` getLoc op `combineSrcSpans` getLoc y + in cL loc (mkHsOpTy x op y) + +mkLHsDocTy :: LHsType GhcPs -> LHsDocString -> LHsType GhcPs +mkLHsDocTy t doc = + let loc = getLoc t `combineSrcSpans` getLoc doc + in cL loc (HsDocTy noExt t doc) + +mkLHsDocTyMaybe :: LHsType GhcPs -> Maybe LHsDocString -> LHsType GhcPs +mkLHsDocTyMaybe t = maybe t (mkLHsDocTy t) + +----------------------------------------------------------------------------- +-- Token symbols + +starSym :: Bool -> String +starSym True = "★" +starSym False = "*" + +forallSym :: Bool -> String +forallSym True = "∀" +forallSym False = "forall" diff --git a/compiler/parser/cutils.c b/compiler/parser/cutils.c new file mode 100644 --- /dev/null +++ b/compiler/parser/cutils.c @@ -0,0 +1,30 @@ +/* +These utility routines are used various +places in the GHC library. +*/ + +#include "Rts.h" + +#include "HsFFI.h" + +#include + +#if defined(HAVE_UNISTD_H) +#include +#endif + +void +enableTimingStats( void ) /* called from the driver */ +{ + RtsFlags.GcFlags.giveStats = ONELINE_GC_STATS; +} + +void +setHeapSize( HsInt size ) +{ + RtsFlags.GcFlags.heapSizeSuggestion = size / BLOCK_SIZE; + if (RtsFlags.GcFlags.maxHeapSize != 0 && + RtsFlags.GcFlags.heapSizeSuggestion > RtsFlags.GcFlags.maxHeapSize) { + RtsFlags.GcFlags.maxHeapSize = RtsFlags.GcFlags.heapSizeSuggestion; + } +} diff --git a/compiler/prelude/ForeignCall.hs b/compiler/prelude/ForeignCall.hs new file mode 100644 --- /dev/null +++ b/compiler/prelude/ForeignCall.hs @@ -0,0 +1,348 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[Foreign]{Foreign calls} +-} + +{-# LANGUAGE DeriveDataTypeable #-} + +module ForeignCall ( + ForeignCall(..), isSafeForeignCall, + Safety(..), playSafe, playInterruptible, + + CExportSpec(..), CLabelString, isCLabelString, pprCLabelString, + CCallSpec(..), + CCallTarget(..), isDynamicTarget, + CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute, + + Header(..), CType(..), + ) where + +import GhcPrelude + +import FastString +import Binary +import Outputable +import Module +import BasicTypes ( SourceText, pprWithSourceText ) + +import Data.Char +import Data.Data + +{- +************************************************************************ +* * +\subsubsection{Data types} +* * +************************************************************************ +-} + +newtype ForeignCall = CCall CCallSpec + deriving Eq + +isSafeForeignCall :: ForeignCall -> Bool +isSafeForeignCall (CCall (CCallSpec _ _ safe)) = playSafe safe + +-- We may need more clues to distinguish foreign calls +-- but this simple printer will do for now +instance Outputable ForeignCall where + ppr (CCall cc) = ppr cc + +data Safety + = PlaySafe -- Might invoke Haskell GC, or do a call back, or + -- switch threads, etc. So make sure things are + -- tidy before the call. Additionally, in the threaded + -- RTS we arrange for the external call to be executed + -- by a separate OS thread, i.e., _concurrently_ to the + -- execution of other Haskell threads. + + | PlayInterruptible -- Like PlaySafe, but additionally + -- the worker thread running this foreign call may + -- be unceremoniously killed, so it must be scheduled + -- on an unbound thread. + + | PlayRisky -- None of the above can happen; the call will return + -- without interacting with the runtime system at all + deriving ( Eq, Show, Data ) + -- Show used just for Show Lex.Token, I think + +instance Outputable Safety where + ppr PlaySafe = text "safe" + ppr PlayInterruptible = text "interruptible" + ppr PlayRisky = text "unsafe" + +playSafe :: Safety -> Bool +playSafe PlaySafe = True +playSafe PlayInterruptible = True +playSafe PlayRisky = False + +playInterruptible :: Safety -> Bool +playInterruptible PlayInterruptible = True +playInterruptible _ = False + +{- +************************************************************************ +* * +\subsubsection{Calling C} +* * +************************************************************************ +-} + +data CExportSpec + = CExportStatic -- foreign export ccall foo :: ty + SourceText -- of the CLabelString. + -- See note [Pragma source text] in BasicTypes + CLabelString -- C Name of exported function + CCallConv + deriving Data + +data CCallSpec + = CCallSpec CCallTarget -- What to call + CCallConv -- Calling convention to use. + Safety + deriving( Eq ) + +-- The call target: + +-- | How to call a particular function in C-land. +data CCallTarget + -- An "unboxed" ccall# to named function in a particular package. + = StaticTarget + SourceText -- of the CLabelString. + -- See note [Pragma source text] in BasicTypes + CLabelString -- C-land name of label. + + (Maybe UnitId) -- What package the function is in. + -- If Nothing, then it's taken to be in the current package. + -- Note: This information is only used for PrimCalls on Windows. + -- See CLabel.labelDynamic and CoreToStg.coreToStgApp + -- for the difference in representation between PrimCalls + -- and ForeignCalls. If the CCallTarget is representing + -- a regular ForeignCall then it's safe to set this to Nothing. + + -- The first argument of the import is the name of a function pointer (an Addr#). + -- Used when importing a label as "foreign import ccall "dynamic" ..." + Bool -- True => really a function + -- False => a value; only + -- allowed in CAPI imports + | DynamicTarget + + deriving( Eq, Data ) + +isDynamicTarget :: CCallTarget -> Bool +isDynamicTarget DynamicTarget = True +isDynamicTarget _ = False + +{- +Stuff to do with calling convention: + +ccall: Caller allocates parameters, *and* deallocates them. + +stdcall: Caller allocates parameters, callee deallocates. + Function name has @N after it, where N is number of arg bytes + e.g. _Foo@8. This convention is x86 (win32) specific. + +See: http://www.programmersheaven.com/2/Calling-conventions +-} + +-- any changes here should be replicated in the CallConv type in template haskell +data CCallConv = CCallConv | CApiConv | StdCallConv | PrimCallConv | JavaScriptCallConv + deriving (Eq, Data) + +instance Outputable CCallConv where + ppr StdCallConv = text "stdcall" + ppr CCallConv = text "ccall" + ppr CApiConv = text "capi" + ppr PrimCallConv = text "prim" + ppr JavaScriptCallConv = text "javascript" + +defaultCCallConv :: CCallConv +defaultCCallConv = CCallConv + +ccallConvToInt :: CCallConv -> Int +ccallConvToInt StdCallConv = 0 +ccallConvToInt CCallConv = 1 +ccallConvToInt CApiConv = panic "ccallConvToInt CApiConv" +ccallConvToInt (PrimCallConv {}) = panic "ccallConvToInt PrimCallConv" +ccallConvToInt JavaScriptCallConv = panic "ccallConvToInt JavaScriptCallConv" + +{- +Generate the gcc attribute corresponding to the given +calling convention (used by PprAbsC): +-} + +ccallConvAttribute :: CCallConv -> SDoc +ccallConvAttribute StdCallConv = text "__attribute__((__stdcall__))" +ccallConvAttribute CCallConv = empty +ccallConvAttribute CApiConv = empty +ccallConvAttribute (PrimCallConv {}) = panic "ccallConvAttribute PrimCallConv" +ccallConvAttribute JavaScriptCallConv = panic "ccallConvAttribute JavaScriptCallConv" + +type CLabelString = FastString -- A C label, completely unencoded + +pprCLabelString :: CLabelString -> SDoc +pprCLabelString lbl = ftext lbl + +isCLabelString :: CLabelString -> Bool -- Checks to see if this is a valid C label +isCLabelString lbl + = all ok (unpackFS lbl) + where + ok c = isAlphaNum c || c == '_' || c == '.' + -- The '.' appears in e.g. "foo.so" in the + -- module part of a ExtName. Maybe it should be separate + +-- Printing into C files: + +instance Outputable CExportSpec where + ppr (CExportStatic _ str _) = pprCLabelString str + +instance Outputable CCallSpec where + ppr (CCallSpec fun cconv safety) + = hcat [ whenPprDebug callconv, ppr_fun fun ] + where + callconv = text "{-" <> ppr cconv <> text "-}" + + gc_suf | playSafe safety = text "_GC" + | otherwise = empty + + ppr_fun (StaticTarget st _fn mPkgId isFun) + = text (if isFun then "__pkg_ccall" + else "__pkg_ccall_value") + <> gc_suf + <+> (case mPkgId of + Nothing -> empty + Just pkgId -> ppr pkgId) + <+> (pprWithSourceText st empty) + + ppr_fun DynamicTarget + = text "__dyn_ccall" <> gc_suf <+> text "\"\"" + +-- The filename for a C header file +-- Note [Pragma source text] in BasicTypes +data Header = Header SourceText FastString + deriving (Eq, Data) + +instance Outputable Header where + ppr (Header st h) = pprWithSourceText st (doubleQuotes $ ppr h) + +-- | A C type, used in CAPI FFI calls +-- +-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen' @'{-\# CTYPE'@, +-- 'ApiAnnotation.AnnHeader','ApiAnnotation.AnnVal', +-- 'ApiAnnotation.AnnClose' @'\#-}'@, + +-- For details on above see note [Api annotations] in ApiAnnotation +data CType = CType SourceText -- Note [Pragma source text] in BasicTypes + (Maybe Header) -- header to include for this type + (SourceText,FastString) -- the type itself + deriving (Eq, Data) + +instance Outputable CType where + ppr (CType stp mh (stct,ct)) + = pprWithSourceText stp (text "{-# CTYPE") <+> hDoc + <+> pprWithSourceText stct (doubleQuotes (ftext ct)) <+> text "#-}" + where hDoc = case mh of + Nothing -> empty + Just h -> ppr h + +{- +************************************************************************ +* * +\subsubsection{Misc} +* * +************************************************************************ +-} + +instance Binary ForeignCall where + put_ bh (CCall aa) = put_ bh aa + get bh = do aa <- get bh; return (CCall aa) + +instance Binary Safety where + put_ bh PlaySafe = do + putByte bh 0 + put_ bh PlayInterruptible = do + putByte bh 1 + put_ bh PlayRisky = do + putByte bh 2 + get bh = do + h <- getByte bh + case h of + 0 -> do return PlaySafe + 1 -> do return PlayInterruptible + _ -> do return PlayRisky + +instance Binary CExportSpec where + put_ bh (CExportStatic ss aa ab) = do + put_ bh ss + put_ bh aa + put_ bh ab + get bh = do + ss <- get bh + aa <- get bh + ab <- get bh + return (CExportStatic ss aa ab) + +instance Binary CCallSpec where + put_ bh (CCallSpec aa ab ac) = do + put_ bh aa + put_ bh ab + put_ bh ac + get bh = do + aa <- get bh + ab <- get bh + ac <- get bh + return (CCallSpec aa ab ac) + +instance Binary CCallTarget where + put_ bh (StaticTarget ss aa ab ac) = do + putByte bh 0 + put_ bh ss + put_ bh aa + put_ bh ab + put_ bh ac + put_ bh DynamicTarget = do + putByte bh 1 + get bh = do + h <- getByte bh + case h of + 0 -> do ss <- get bh + aa <- get bh + ab <- get bh + ac <- get bh + return (StaticTarget ss aa ab ac) + _ -> do return DynamicTarget + +instance Binary CCallConv where + put_ bh CCallConv = do + putByte bh 0 + put_ bh StdCallConv = do + putByte bh 1 + put_ bh PrimCallConv = do + putByte bh 2 + put_ bh CApiConv = do + putByte bh 3 + put_ bh JavaScriptCallConv = do + putByte bh 4 + get bh = do + h <- getByte bh + case h of + 0 -> do return CCallConv + 1 -> do return StdCallConv + 2 -> do return PrimCallConv + 3 -> do return CApiConv + _ -> do return JavaScriptCallConv + +instance Binary CType where + put_ bh (CType s mh fs) = do put_ bh s + put_ bh mh + put_ bh fs + get bh = do s <- get bh + mh <- get bh + fs <- get bh + return (CType s mh fs) + +instance Binary Header where + put_ bh (Header s h) = put_ bh s >> put_ bh h + get bh = do s <- get bh + h <- get bh + return (Header s h) diff --git a/compiler/prelude/KnownUniques.hs b/compiler/prelude/KnownUniques.hs new file mode 100644 --- /dev/null +++ b/compiler/prelude/KnownUniques.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE CPP #-} + +-- | This is where we define a mapping from Uniques to their associated +-- known-key Names for things associated with tuples and sums. We use this +-- mapping while deserializing known-key Names in interface file symbol tables, +-- which are encoded as their Unique. See Note [Symbol table representation of +-- names] for details. +-- + +module KnownUniques + ( -- * Looking up known-key names + knownUniqueName + + -- * Getting the 'Unique's of 'Name's + -- ** Anonymous sums + , mkSumTyConUnique + , mkSumDataConUnique + -- ** Tuples + -- *** Vanilla + , mkTupleTyConUnique + , mkTupleDataConUnique + -- *** Constraint + , mkCTupleTyConUnique + , mkCTupleDataConUnique + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import TysWiredIn +import TyCon +import DataCon +import Id +import BasicTypes +import Outputable +import Unique +import Name +import Util + +import Data.Bits +import Data.Maybe + +-- | Get the 'Name' associated with a known-key 'Unique'. +knownUniqueName :: Unique -> Maybe Name +knownUniqueName u = + case tag of + 'z' -> Just $ getUnboxedSumName n + '4' -> Just $ getTupleTyConName Boxed n + '5' -> Just $ getTupleTyConName Unboxed n + '7' -> Just $ getTupleDataConName Boxed n + '8' -> Just $ getTupleDataConName Unboxed n + 'k' -> Just $ getCTupleTyConName n + 'm' -> Just $ getCTupleDataConUnique n + _ -> Nothing + where + (tag, n) = unpkUnique u + +-------------------------------------------------- +-- Anonymous sums +-- +-- Sum arities start from 2. The encoding is a bit funny: we break up the +-- integral part into bitfields for the arity, an alternative index (which is +-- taken to be 0xff in the case of the TyCon), and, in the case of a datacon, a +-- tag (used to identify the sum's TypeRep binding). +-- +-- This layout is chosen to remain compatible with the usual unique allocation +-- for wired-in data constructors described in Unique.hs +-- +-- TyCon for sum of arity k: +-- 00000000 kkkkkkkk 11111100 + +-- TypeRep of TyCon for sum of arity k: +-- 00000000 kkkkkkkk 11111101 +-- +-- DataCon for sum of arity k and alternative n (zero-based): +-- 00000000 kkkkkkkk nnnnnn00 +-- +-- TypeRep for sum DataCon of arity k and alternative n (zero-based): +-- 00000000 kkkkkkkk nnnnnn10 + +mkSumTyConUnique :: Arity -> Unique +mkSumTyConUnique arity = + ASSERT(arity < 0x3f) -- 0x3f since we only have 6 bits to encode the + -- alternative + mkUnique 'z' (arity `shiftL` 8 .|. 0xfc) + +mkSumDataConUnique :: ConTagZ -> Arity -> Unique +mkSumDataConUnique alt arity + | alt >= arity + = panic ("mkSumDataConUnique: " ++ show alt ++ " >= " ++ show arity) + | otherwise + = mkUnique 'z' (arity `shiftL` 8 + alt `shiftL` 2) {- skip the tycon -} + +getUnboxedSumName :: Int -> Name +getUnboxedSumName n + | n .&. 0xfc == 0xfc + = case tag of + 0x0 -> tyConName $ sumTyCon arity + 0x1 -> getRep $ sumTyCon arity + _ -> pprPanic "getUnboxedSumName: invalid tag" (ppr tag) + | tag == 0x0 + = dataConName $ sumDataCon (alt + 1) arity + | tag == 0x1 + = getName $ dataConWrapId $ sumDataCon (alt + 1) arity + | tag == 0x2 + = getRep $ promoteDataCon $ sumDataCon (alt + 1) arity + | otherwise + = pprPanic "getUnboxedSumName" (ppr n) + where + arity = n `shiftR` 8 + alt = (n .&. 0xfc) `shiftR` 2 + tag = 0x3 .&. n + getRep tycon = + fromMaybe (pprPanic "getUnboxedSumName(getRep)" (ppr tycon)) + $ tyConRepName_maybe tycon + +-- Note [Uniques for tuple type and data constructors] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- Wired-in type constructor keys occupy *two* slots: +-- * u: the TyCon itself +-- * u+1: the TyConRepName of the TyCon +-- +-- Wired-in tuple data constructor keys occupy *three* slots: +-- * u: the DataCon itself +-- * u+1: its worker Id +-- * u+2: the TyConRepName of the promoted TyCon + +-------------------------------------------------- +-- Constraint tuples + +mkCTupleTyConUnique :: Arity -> Unique +mkCTupleTyConUnique a = mkUnique 'k' (2*a) + +mkCTupleDataConUnique :: Arity -> Unique +mkCTupleDataConUnique a = mkUnique 'm' (3*a) + +getCTupleTyConName :: Int -> Name +getCTupleTyConName n = + case n `divMod` 2 of + (arity, 0) -> cTupleTyConName arity + (arity, 1) -> mkPrelTyConRepName $ cTupleTyConName arity + _ -> panic "getCTupleTyConName: impossible" + +getCTupleDataConUnique :: Int -> Name +getCTupleDataConUnique n = + case n `divMod` 3 of + (arity, 0) -> cTupleDataConName arity + (_arity, 1) -> panic "getCTupleDataConName: no worker" + (arity, 2) -> mkPrelTyConRepName $ cTupleDataConName arity + _ -> panic "getCTupleDataConName: impossible" + +-------------------------------------------------- +-- Normal tuples + +mkTupleDataConUnique :: Boxity -> Arity -> Unique +mkTupleDataConUnique Boxed a = mkUnique '7' (3*a) -- may be used in C labels +mkTupleDataConUnique Unboxed a = mkUnique '8' (3*a) + +mkTupleTyConUnique :: Boxity -> Arity -> Unique +mkTupleTyConUnique Boxed a = mkUnique '4' (2*a) +mkTupleTyConUnique Unboxed a = mkUnique '5' (2*a) + +getTupleTyConName :: Boxity -> Int -> Name +getTupleTyConName boxity n = + case n `divMod` 2 of + (arity, 0) -> tyConName $ tupleTyCon boxity arity + (arity, 1) -> fromMaybe (panic "getTupleTyConName") + $ tyConRepName_maybe $ tupleTyCon boxity arity + _ -> panic "getTupleTyConName: impossible" + +getTupleDataConName :: Boxity -> Int -> Name +getTupleDataConName boxity n = + case n `divMod` 3 of + (arity, 0) -> dataConName $ tupleDataCon boxity arity + (arity, 1) -> idName $ dataConWorkId $ tupleDataCon boxity arity + (arity, 2) -> fromMaybe (panic "getTupleDataCon") + $ tyConRepName_maybe $ promotedTupleDataCon boxity arity + _ -> panic "getTupleDataConName: impossible" diff --git a/compiler/prelude/KnownUniques.hs-boot b/compiler/prelude/KnownUniques.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/prelude/KnownUniques.hs-boot @@ -0,0 +1,18 @@ +module KnownUniques where + +import GhcPrelude +import Unique +import Name +import BasicTypes + +-- Needed by TysWiredIn +knownUniqueName :: Unique -> Maybe Name + +mkSumTyConUnique :: Arity -> Unique +mkSumDataConUnique :: ConTagZ -> Arity -> Unique + +mkCTupleTyConUnique :: Arity -> Unique +mkCTupleDataConUnique :: Arity -> Unique + +mkTupleTyConUnique :: Boxity -> Arity -> Unique +mkTupleDataConUnique :: Boxity -> Arity -> Unique diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs new file mode 100644 --- /dev/null +++ b/compiler/prelude/PrelNames.hs @@ -0,0 +1,2485 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[PrelNames]{Definitions of prelude modules and names} + + +Nota Bene: all Names defined in here should come from the base package + + - ModuleNames for prelude modules, + e.g. pREL_BASE_Name :: ModuleName + + - Modules for prelude modules + e.g. pREL_Base :: Module + + - Uniques for Ids, DataCons, TyCons and Classes that the compiler + "knows about" in some way + e.g. intTyConKey :: Unique + minusClassOpKey :: Unique + + - Names for Ids, DataCons, TyCons and Classes that the compiler + "knows about" in some way + e.g. intTyConName :: Name + minusName :: Name + One of these Names contains + (a) the module and occurrence name of the thing + (b) its Unique + The way the compiler "knows about" one of these things is + where the type checker or desugarer needs to look it up. For + example, when desugaring list comprehensions the desugarer + needs to conjure up 'foldr'. It does this by looking up + foldrName in the environment. + + - RdrNames for Ids, DataCons etc that the compiler may emit into + generated code (e.g. for deriving). It's not necessary to know + the uniques for these guys, only their names + + +Note [Known-key names] +~~~~~~~~~~~~~~~~~~~~~~ +It is *very* important that the compiler gives wired-in things and +things with "known-key" names the correct Uniques wherever they +occur. We have to be careful about this in exactly two places: + + 1. When we parse some source code, renaming the AST better yield an + AST whose Names have the correct uniques + + 2. When we read an interface file, the read-in gubbins better have + the right uniques + +This is accomplished through a combination of mechanisms: + + 1. When parsing source code, the RdrName-decorated AST has some + RdrNames which are Exact. These are wired-in RdrNames where the + we could directly tell from the parsed syntax what Name to + use. For example, when we parse a [] in a type we can just insert + an Exact RdrName Name with the listTyConKey. + + Currently, I believe this is just an optimisation: it would be + equally valid to just output Orig RdrNames that correctly record + the module etc we expect the final Name to come from. However, + were we to eliminate isBuiltInOcc_maybe it would become essential + (see point 3). + + 2. The knownKeyNames (which consist of the basicKnownKeyNames from + the module, and those names reachable via the wired-in stuff from + TysWiredIn) are used to initialise the "OrigNameCache" in + IfaceEnv. This initialization ensures that when the type checker + or renamer (both of which use IfaceEnv) look up an original name + (i.e. a pair of a Module and an OccName) for a known-key name + they get the correct Unique. + + This is the most important mechanism for ensuring that known-key + stuff gets the right Unique, and is why it is so important to + place your known-key names in the appropriate lists. + + 3. For "infinite families" of known-key names (i.e. tuples and sums), we + have to be extra careful. Because there are an infinite number of + these things, we cannot add them to the list of known-key names + used to initialise the OrigNameCache. Instead, we have to + rely on never having to look them up in that cache. See + Note [Infinite families of known-key names] for details. + + +Note [Infinite families of known-key names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Infinite families of known-key things (e.g. tuples and sums) pose a tricky +problem: we can't add them to the knownKeyNames finite map which we use to +ensure that, e.g., a reference to (,) gets assigned the right unique (if this +doesn't sound familiar see Note [Known-key names] above). + +We instead handle tuples and sums separately from the "vanilla" known-key +things, + + a) The parser recognises them specially and generates an Exact Name (hence not + looked up in the orig-name cache) + + b) The known infinite families of names are specially serialised by + BinIface.putName, with that special treatment detected when we read back to + ensure that we get back to the correct uniques. See Note [Symbol table + representation of names] in BinIface and Note [How tuples work] in + TysWiredIn. + +Most of the infinite families cannot occur in source code, so mechanisms (a) and (b) +suffice to ensure that they always have the right Unique. In particular, +implicit param TyCon names, constraint tuples and Any TyCons cannot be mentioned +by the user. For those things that *can* appear in source programs, + + c) IfaceEnv.lookupOrigNameCache uses isBuiltInOcc_maybe to map built-in syntax + directly onto the corresponding name, rather than trying to find it in the + original-name cache. + + See also Note [Built-in syntax and the OrigNameCache] + + +Note [The integer library] +~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Clearly, we need to know the names of various definitions of the integer +library, e.g. the type itself, `mkInteger` etc. But there are two possible +implementations of the integer library: + + * integer-gmp (fast, but uses libgmp, which may not be available on all + targets and is GPL licensed) + * integer-simple (slow, but pure Haskell and BSD-licensed) + +We want the compiler to work with either one. The way we achieve this is: + + * When compiling the integer-{gmp,simple} library, we pass + -this-unit-id integer-wired-in + to GHC (see the cabal file libraries/integer-{gmp,simple}. + * This way, GHC can use just this UnitID (see Module.integerUnitId) when + generating code, and the linker will succeed. + +Unfortuately, the abstraction is not complete: When using integer-gmp, we +really want to use the S# constructor directly. This is controlled by +the `integerLibrary` field of `DynFlags`: If it is IntegerGMP, we use +this constructor directly (see CorePrep.lookupIntegerSDataConName) + +When GHC reads the package data base, it (internally only) pretends it has UnitId +`integer-wired-in` instead of the actual UnitId (which includes the version +number); just like for `base` and other packages, as described in +Note [Wired-in packages] in Module. This is done in Packages.findWiredInPackages. +-} + +{-# LANGUAGE CPP #-} + +module PrelNames ( + Unique, Uniquable(..), hasKey, -- Re-exported for convenience + + ----------------------------------------------------------- + module PrelNames, -- A huge bunch of (a) Names, e.g. intTyConName + -- (b) Uniques e.g. intTyConKey + -- (c) Groups of classes and types + -- (d) miscellaneous things + -- So many that we export them all + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import Module +import OccName +import RdrName +import Unique +import Name +import SrcLoc +import FastString + +{- +************************************************************************ +* * + allNameStrings +* * +************************************************************************ +-} + +allNameStrings :: [String] +-- Infinite list of a,b,c...z, aa, ab, ac, ... etc +allNameStrings = [ c:cs | cs <- "" : allNameStrings, c <- ['a'..'z'] ] + +{- +************************************************************************ +* * +\subsection{Local Names} +* * +************************************************************************ + +This *local* name is used by the interactive stuff +-} + +itName :: Unique -> SrcSpan -> Name +itName uniq loc = mkInternalName uniq (mkOccNameFS varName (fsLit "it")) loc + +-- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly +-- during compiler debugging. +mkUnboundName :: OccName -> Name +mkUnboundName occ = mkInternalName unboundKey occ noSrcSpan + +isUnboundName :: Name -> Bool +isUnboundName name = name `hasKey` unboundKey + +{- +************************************************************************ +* * +\subsection{Known key Names} +* * +************************************************************************ + +This section tells what the compiler knows about the association of +names with uniques. These ones are the *non* wired-in ones. The +wired in ones are defined in TysWiredIn etc. +-} + +basicKnownKeyNames :: [Name] -- See Note [Known-key names] +basicKnownKeyNames + = genericTyConNames + ++ [ -- Classes. *Must* include: + -- classes that are grabbed by key (e.g., eqClassKey) + -- classes in "Class.standardClassKeys" (quite a few) + eqClassName, -- mentioned, derivable + ordClassName, -- derivable + boundedClassName, -- derivable + numClassName, -- mentioned, numeric + enumClassName, -- derivable + monadClassName, + functorClassName, + realClassName, -- numeric + integralClassName, -- numeric + fractionalClassName, -- numeric + floatingClassName, -- numeric + realFracClassName, -- numeric + realFloatClassName, -- numeric + dataClassName, + isStringClassName, + applicativeClassName, + alternativeClassName, + foldableClassName, + traversableClassName, + semigroupClassName, sappendName, + monoidClassName, memptyName, mappendName, mconcatName, + + -- The IO type + -- See Note [TyConRepNames for non-wired-in TyCons] + ioTyConName, ioDataConName, + runMainIOName, + runRWName, + + -- Type representation types + trModuleTyConName, trModuleDataConName, + trNameTyConName, trNameSDataConName, trNameDDataConName, + trTyConTyConName, trTyConDataConName, + + -- Typeable + typeableClassName, + typeRepTyConName, + someTypeRepTyConName, + someTypeRepDataConName, + kindRepTyConName, + kindRepTyConAppDataConName, + kindRepVarDataConName, + kindRepAppDataConName, + kindRepFunDataConName, + kindRepTYPEDataConName, + kindRepTypeLitSDataConName, + kindRepTypeLitDDataConName, + typeLitSortTyConName, + typeLitSymbolDataConName, + typeLitNatDataConName, + typeRepIdName, + mkTrTypeName, + mkTrConName, + mkTrAppName, + mkTrFunName, + typeSymbolTypeRepName, typeNatTypeRepName, + trGhcPrimModuleName, + + -- KindReps for common cases + starKindRepName, + starArrStarKindRepName, + starArrStarArrStarKindRepName, + + -- Dynamic + toDynName, + + -- Numeric stuff + negateName, minusName, geName, eqName, + + -- Conversion functions + rationalTyConName, + ratioTyConName, ratioDataConName, + fromRationalName, fromIntegerName, + toIntegerName, toRationalName, + fromIntegralName, realToFracName, + + -- Int# stuff + divIntName, modIntName, + + -- String stuff + fromStringName, + + -- Enum stuff + enumFromName, enumFromThenName, + enumFromThenToName, enumFromToName, + + -- Applicative stuff + pureAName, apAName, thenAName, + + -- Functor stuff + fmapName, + + -- Monad stuff + thenIOName, bindIOName, returnIOName, failIOName, bindMName, thenMName, + returnMName, joinMName, + + -- MonadFail + monadFailClassName, failMName, + + -- MonadFix + monadFixClassName, mfixName, + + -- Arrow stuff + arrAName, composeAName, firstAName, + appAName, choiceAName, loopAName, + + -- Ix stuff + ixClassName, + + -- Show stuff + showClassName, + + -- Read stuff + readClassName, + + -- Stable pointers + newStablePtrName, + + -- GHC Extensions + groupWithName, + + -- Strings and lists + unpackCStringName, + unpackCStringFoldrName, unpackCStringUtf8Name, + + -- Overloaded lists + isListClassName, + fromListName, + fromListNName, + toListName, + + -- List operations + concatName, filterName, mapName, + zipName, foldrName, buildName, augmentName, appendName, + + -- FFI primitive types that are not wired-in. + stablePtrTyConName, ptrTyConName, funPtrTyConName, + int8TyConName, int16TyConName, int32TyConName, int64TyConName, + word16TyConName, word32TyConName, word64TyConName, + + -- Others + otherwiseIdName, inlineIdName, + eqStringName, assertName, breakpointName, breakpointCondName, + opaqueTyConName, + assertErrorName, traceName, + printName, fstName, sndName, + dollarName, + + -- Integer + integerTyConName, mkIntegerName, + integerToWord64Name, integerToInt64Name, + word64ToIntegerName, int64ToIntegerName, + plusIntegerName, timesIntegerName, smallIntegerName, + wordToIntegerName, + integerToWordName, integerToIntName, minusIntegerName, + negateIntegerName, eqIntegerPrimName, neqIntegerPrimName, + absIntegerName, signumIntegerName, + leIntegerPrimName, gtIntegerPrimName, ltIntegerPrimName, geIntegerPrimName, + compareIntegerName, quotRemIntegerName, divModIntegerName, + quotIntegerName, remIntegerName, divIntegerName, modIntegerName, + floatFromIntegerName, doubleFromIntegerName, + encodeFloatIntegerName, encodeDoubleIntegerName, + decodeDoubleIntegerName, + gcdIntegerName, lcmIntegerName, + andIntegerName, orIntegerName, xorIntegerName, complementIntegerName, + shiftLIntegerName, shiftRIntegerName, bitIntegerName, + integerSDataConName,naturalSDataConName, + + -- Natural + naturalTyConName, + naturalFromIntegerName, naturalToIntegerName, + plusNaturalName, minusNaturalName, timesNaturalName, mkNaturalName, + wordToNaturalName, + + -- Float/Double + rationalToFloatName, + rationalToDoubleName, + + -- Other classes + randomClassName, randomGenClassName, monadPlusClassName, + + -- Type-level naturals + knownNatClassName, knownSymbolClassName, + + -- Overloaded labels + isLabelClassName, + + -- Implicit Parameters + ipClassName, + + -- Overloaded record fields + hasFieldClassName, + + -- Call Stacks + callStackTyConName, + emptyCallStackName, pushCallStackName, + + -- Source Locations + srcLocDataConName, + + -- Annotation type checking + toAnnotationWrapperName + + -- The Ordering type + , orderingTyConName + , ordLTDataConName, ordEQDataConName, ordGTDataConName + + -- The SPEC type for SpecConstr + , specTyConName + + -- The Either type + , eitherTyConName, leftDataConName, rightDataConName + + -- Plugins + , pluginTyConName + , frontendPluginTyConName + + -- Generics + , genClassName, gen1ClassName + , datatypeClassName, constructorClassName, selectorClassName + + -- Monad comprehensions + , guardMName + , liftMName + , mzipName + + -- GHCi Sandbox + , ghciIoClassName, ghciStepIoMName + + -- StaticPtr + , makeStaticName + , staticPtrTyConName + , staticPtrDataConName, staticPtrInfoDataConName + , fromStaticPtrName + + -- Fingerprint + , fingerprintDataConName + + -- Custom type errors + , errorMessageTypeErrorFamName + , typeErrorTextDataConName + , typeErrorAppendDataConName + , typeErrorVAppendDataConName + , typeErrorShowTypeDataConName + + ] + +genericTyConNames :: [Name] +genericTyConNames = [ + v1TyConName, u1TyConName, par1TyConName, rec1TyConName, + k1TyConName, m1TyConName, sumTyConName, prodTyConName, + compTyConName, rTyConName, dTyConName, + cTyConName, sTyConName, rec0TyConName, + d1TyConName, c1TyConName, s1TyConName, noSelTyConName, + repTyConName, rep1TyConName, uRecTyConName, + uAddrTyConName, uCharTyConName, uDoubleTyConName, + uFloatTyConName, uIntTyConName, uWordTyConName, + prefixIDataConName, infixIDataConName, leftAssociativeDataConName, + rightAssociativeDataConName, notAssociativeDataConName, + sourceUnpackDataConName, sourceNoUnpackDataConName, + noSourceUnpackednessDataConName, sourceLazyDataConName, + sourceStrictDataConName, noSourceStrictnessDataConName, + decidedLazyDataConName, decidedStrictDataConName, decidedUnpackDataConName, + metaDataDataConName, metaConsDataConName, metaSelDataConName + ] + +{- +************************************************************************ +* * +\subsection{Module names} +* * +************************************************************************ + + +--MetaHaskell Extension Add a new module here +-} + +pRELUDE :: Module +pRELUDE = mkBaseModule_ pRELUDE_NAME + +gHC_PRIM, gHC_TYPES, gHC_GENERICS, gHC_MAGIC, + gHC_CLASSES, gHC_BASE, gHC_ENUM, gHC_GHCI, gHC_CSTRING, + gHC_SHOW, gHC_READ, gHC_NUM, gHC_MAYBE, gHC_INTEGER_TYPE, gHC_NATURAL, + gHC_LIST, gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING, + dATA_FOLDABLE, dATA_TRAVERSABLE, + gHC_CONC, gHC_IO, gHC_IO_Exception, + gHC_ST, gHC_ARR, gHC_STABLE, gHC_PTR, gHC_ERR, gHC_REAL, + gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC, + tYPEABLE, tYPEABLE_INTERNAL, gENERICS, + rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, mONAD_ZIP, mONAD_FAIL, + aRROW, cONTROL_APPLICATIVE, gHC_DESUGAR, rANDOM, gHC_EXTS, + cONTROL_EXCEPTION_BASE, gHC_TYPELITS, gHC_TYPENATS, dATA_TYPE_EQUALITY, + dATA_COERCE, dEBUG_TRACE :: Module + +gHC_PRIM = mkPrimModule (fsLit "GHC.Prim") -- Primitive types and values +gHC_TYPES = mkPrimModule (fsLit "GHC.Types") +gHC_MAGIC = mkPrimModule (fsLit "GHC.Magic") +gHC_CSTRING = mkPrimModule (fsLit "GHC.CString") +gHC_CLASSES = mkPrimModule (fsLit "GHC.Classes") + +gHC_BASE = mkBaseModule (fsLit "GHC.Base") +gHC_ENUM = mkBaseModule (fsLit "GHC.Enum") +gHC_GHCI = mkBaseModule (fsLit "GHC.GHCi") +gHC_SHOW = mkBaseModule (fsLit "GHC.Show") +gHC_READ = mkBaseModule (fsLit "GHC.Read") +gHC_NUM = mkBaseModule (fsLit "GHC.Num") +gHC_MAYBE = mkBaseModule (fsLit "GHC.Maybe") +gHC_INTEGER_TYPE= mkIntegerModule (fsLit "GHC.Integer.Type") +gHC_NATURAL = mkBaseModule (fsLit "GHC.Natural") +gHC_LIST = mkBaseModule (fsLit "GHC.List") +gHC_TUPLE = mkPrimModule (fsLit "GHC.Tuple") +dATA_TUPLE = mkBaseModule (fsLit "Data.Tuple") +dATA_EITHER = mkBaseModule (fsLit "Data.Either") +dATA_STRING = mkBaseModule (fsLit "Data.String") +dATA_FOLDABLE = mkBaseModule (fsLit "Data.Foldable") +dATA_TRAVERSABLE= mkBaseModule (fsLit "Data.Traversable") +gHC_CONC = mkBaseModule (fsLit "GHC.Conc") +gHC_IO = mkBaseModule (fsLit "GHC.IO") +gHC_IO_Exception = mkBaseModule (fsLit "GHC.IO.Exception") +gHC_ST = mkBaseModule (fsLit "GHC.ST") +gHC_ARR = mkBaseModule (fsLit "GHC.Arr") +gHC_STABLE = mkBaseModule (fsLit "GHC.Stable") +gHC_PTR = mkBaseModule (fsLit "GHC.Ptr") +gHC_ERR = mkBaseModule (fsLit "GHC.Err") +gHC_REAL = mkBaseModule (fsLit "GHC.Real") +gHC_FLOAT = mkBaseModule (fsLit "GHC.Float") +gHC_TOP_HANDLER = mkBaseModule (fsLit "GHC.TopHandler") +sYSTEM_IO = mkBaseModule (fsLit "System.IO") +dYNAMIC = mkBaseModule (fsLit "Data.Dynamic") +tYPEABLE = mkBaseModule (fsLit "Data.Typeable") +tYPEABLE_INTERNAL = mkBaseModule (fsLit "Data.Typeable.Internal") +gENERICS = mkBaseModule (fsLit "Data.Data") +rEAD_PREC = mkBaseModule (fsLit "Text.ParserCombinators.ReadPrec") +lEX = mkBaseModule (fsLit "Text.Read.Lex") +gHC_INT = mkBaseModule (fsLit "GHC.Int") +gHC_WORD = mkBaseModule (fsLit "GHC.Word") +mONAD = mkBaseModule (fsLit "Control.Monad") +mONAD_FIX = mkBaseModule (fsLit "Control.Monad.Fix") +mONAD_ZIP = mkBaseModule (fsLit "Control.Monad.Zip") +mONAD_FAIL = mkBaseModule (fsLit "Control.Monad.Fail") +aRROW = mkBaseModule (fsLit "Control.Arrow") +cONTROL_APPLICATIVE = mkBaseModule (fsLit "Control.Applicative") +gHC_DESUGAR = mkBaseModule (fsLit "GHC.Desugar") +rANDOM = mkBaseModule (fsLit "System.Random") +gHC_EXTS = mkBaseModule (fsLit "GHC.Exts") +cONTROL_EXCEPTION_BASE = mkBaseModule (fsLit "Control.Exception.Base") +gHC_GENERICS = mkBaseModule (fsLit "GHC.Generics") +gHC_TYPELITS = mkBaseModule (fsLit "GHC.TypeLits") +gHC_TYPENATS = mkBaseModule (fsLit "GHC.TypeNats") +dATA_TYPE_EQUALITY = mkBaseModule (fsLit "Data.Type.Equality") +dATA_COERCE = mkBaseModule (fsLit "Data.Coerce") +dEBUG_TRACE = mkBaseModule (fsLit "Debug.Trace") + +gHC_SRCLOC :: Module +gHC_SRCLOC = mkBaseModule (fsLit "GHC.SrcLoc") + +gHC_STACK, gHC_STACK_TYPES :: Module +gHC_STACK = mkBaseModule (fsLit "GHC.Stack") +gHC_STACK_TYPES = mkBaseModule (fsLit "GHC.Stack.Types") + +gHC_STATICPTR :: Module +gHC_STATICPTR = mkBaseModule (fsLit "GHC.StaticPtr") + +gHC_STATICPTR_INTERNAL :: Module +gHC_STATICPTR_INTERNAL = mkBaseModule (fsLit "GHC.StaticPtr.Internal") + +gHC_FINGERPRINT_TYPE :: Module +gHC_FINGERPRINT_TYPE = mkBaseModule (fsLit "GHC.Fingerprint.Type") + +gHC_OVER_LABELS :: Module +gHC_OVER_LABELS = mkBaseModule (fsLit "GHC.OverloadedLabels") + +gHC_RECORDS :: Module +gHC_RECORDS = mkBaseModule (fsLit "GHC.Records") + +mAIN, rOOT_MAIN :: Module +mAIN = mkMainModule_ mAIN_NAME +rOOT_MAIN = mkMainModule (fsLit ":Main") -- Root module for initialisation + +mkInteractiveModule :: Int -> Module +-- (mkInteractiveMoudule 9) makes module 'interactive:M9' +mkInteractiveModule n = mkModule interactiveUnitId (mkModuleName ("Ghci" ++ show n)) + +pRELUDE_NAME, mAIN_NAME :: ModuleName +pRELUDE_NAME = mkModuleNameFS (fsLit "Prelude") +mAIN_NAME = mkModuleNameFS (fsLit "Main") + +dATA_ARRAY_PARALLEL_NAME, dATA_ARRAY_PARALLEL_PRIM_NAME :: ModuleName +dATA_ARRAY_PARALLEL_NAME = mkModuleNameFS (fsLit "Data.Array.Parallel") +dATA_ARRAY_PARALLEL_PRIM_NAME = mkModuleNameFS (fsLit "Data.Array.Parallel.Prim") + +mkPrimModule :: FastString -> Module +mkPrimModule m = mkModule primUnitId (mkModuleNameFS m) + +mkIntegerModule :: FastString -> Module +mkIntegerModule m = mkModule integerUnitId (mkModuleNameFS m) + +mkBaseModule :: FastString -> Module +mkBaseModule m = mkModule baseUnitId (mkModuleNameFS m) + +mkBaseModule_ :: ModuleName -> Module +mkBaseModule_ m = mkModule baseUnitId m + +mkThisGhcModule :: FastString -> Module +mkThisGhcModule m = mkModule thisGhcUnitId (mkModuleNameFS m) + +mkThisGhcModule_ :: ModuleName -> Module +mkThisGhcModule_ m = mkModule thisGhcUnitId m + +mkMainModule :: FastString -> Module +mkMainModule m = mkModule mainUnitId (mkModuleNameFS m) + +mkMainModule_ :: ModuleName -> Module +mkMainModule_ m = mkModule mainUnitId m + +{- +************************************************************************ +* * + RdrNames +* * +************************************************************************ +-} + +main_RDR_Unqual :: RdrName +main_RDR_Unqual = mkUnqual varName (fsLit "main") + -- We definitely don't want an Orig RdrName, because + -- main might, in principle, be imported into module Main + +eq_RDR, ge_RDR, le_RDR, lt_RDR, gt_RDR, compare_RDR, + ltTag_RDR, eqTag_RDR, gtTag_RDR :: RdrName +eq_RDR = nameRdrName eqName +ge_RDR = nameRdrName geName +le_RDR = varQual_RDR gHC_CLASSES (fsLit "<=") +lt_RDR = varQual_RDR gHC_CLASSES (fsLit "<") +gt_RDR = varQual_RDR gHC_CLASSES (fsLit ">") +compare_RDR = varQual_RDR gHC_CLASSES (fsLit "compare") +ltTag_RDR = nameRdrName ordLTDataConName +eqTag_RDR = nameRdrName ordEQDataConName +gtTag_RDR = nameRdrName ordGTDataConName + +eqClass_RDR, numClass_RDR, ordClass_RDR, enumClass_RDR, monadClass_RDR + :: RdrName +eqClass_RDR = nameRdrName eqClassName +numClass_RDR = nameRdrName numClassName +ordClass_RDR = nameRdrName ordClassName +enumClass_RDR = nameRdrName enumClassName +monadClass_RDR = nameRdrName monadClassName + +map_RDR, append_RDR :: RdrName +map_RDR = nameRdrName mapName +append_RDR = nameRdrName appendName + +foldr_RDR, build_RDR, returnM_RDR, bindM_RDR, failM_RDR + :: RdrName +foldr_RDR = nameRdrName foldrName +build_RDR = nameRdrName buildName +returnM_RDR = nameRdrName returnMName +bindM_RDR = nameRdrName bindMName +failM_RDR = nameRdrName failMName + +left_RDR, right_RDR :: RdrName +left_RDR = nameRdrName leftDataConName +right_RDR = nameRdrName rightDataConName + +fromEnum_RDR, toEnum_RDR :: RdrName +fromEnum_RDR = varQual_RDR gHC_ENUM (fsLit "fromEnum") +toEnum_RDR = varQual_RDR gHC_ENUM (fsLit "toEnum") + +enumFrom_RDR, enumFromTo_RDR, enumFromThen_RDR, enumFromThenTo_RDR :: RdrName +enumFrom_RDR = nameRdrName enumFromName +enumFromTo_RDR = nameRdrName enumFromToName +enumFromThen_RDR = nameRdrName enumFromThenName +enumFromThenTo_RDR = nameRdrName enumFromThenToName + +ratioDataCon_RDR, plusInteger_RDR, timesInteger_RDR :: RdrName +ratioDataCon_RDR = nameRdrName ratioDataConName +plusInteger_RDR = nameRdrName plusIntegerName +timesInteger_RDR = nameRdrName timesIntegerName + +ioDataCon_RDR :: RdrName +ioDataCon_RDR = nameRdrName ioDataConName + +eqString_RDR, unpackCString_RDR, unpackCStringFoldr_RDR, + unpackCStringUtf8_RDR :: RdrName +eqString_RDR = nameRdrName eqStringName +unpackCString_RDR = nameRdrName unpackCStringName +unpackCStringFoldr_RDR = nameRdrName unpackCStringFoldrName +unpackCStringUtf8_RDR = nameRdrName unpackCStringUtf8Name + +newStablePtr_RDR :: RdrName +newStablePtr_RDR = nameRdrName newStablePtrName + +bindIO_RDR, returnIO_RDR :: RdrName +bindIO_RDR = nameRdrName bindIOName +returnIO_RDR = nameRdrName returnIOName + +fromInteger_RDR, fromRational_RDR, minus_RDR, times_RDR, plus_RDR :: RdrName +fromInteger_RDR = nameRdrName fromIntegerName +fromRational_RDR = nameRdrName fromRationalName +minus_RDR = nameRdrName minusName +times_RDR = varQual_RDR gHC_NUM (fsLit "*") +plus_RDR = varQual_RDR gHC_NUM (fsLit "+") + +toInteger_RDR, toRational_RDR, fromIntegral_RDR :: RdrName +toInteger_RDR = nameRdrName toIntegerName +toRational_RDR = nameRdrName toRationalName +fromIntegral_RDR = nameRdrName fromIntegralName + +stringTy_RDR, fromString_RDR :: RdrName +stringTy_RDR = tcQual_RDR gHC_BASE (fsLit "String") +fromString_RDR = nameRdrName fromStringName + +fromList_RDR, fromListN_RDR, toList_RDR :: RdrName +fromList_RDR = nameRdrName fromListName +fromListN_RDR = nameRdrName fromListNName +toList_RDR = nameRdrName toListName + +compose_RDR :: RdrName +compose_RDR = varQual_RDR gHC_BASE (fsLit ".") + +not_RDR, getTag_RDR, succ_RDR, pred_RDR, minBound_RDR, maxBound_RDR, + and_RDR, range_RDR, inRange_RDR, index_RDR, + unsafeIndex_RDR, unsafeRangeSize_RDR :: RdrName +and_RDR = varQual_RDR gHC_CLASSES (fsLit "&&") +not_RDR = varQual_RDR gHC_CLASSES (fsLit "not") +getTag_RDR = varQual_RDR gHC_BASE (fsLit "getTag") +succ_RDR = varQual_RDR gHC_ENUM (fsLit "succ") +pred_RDR = varQual_RDR gHC_ENUM (fsLit "pred") +minBound_RDR = varQual_RDR gHC_ENUM (fsLit "minBound") +maxBound_RDR = varQual_RDR gHC_ENUM (fsLit "maxBound") +range_RDR = varQual_RDR gHC_ARR (fsLit "range") +inRange_RDR = varQual_RDR gHC_ARR (fsLit "inRange") +index_RDR = varQual_RDR gHC_ARR (fsLit "index") +unsafeIndex_RDR = varQual_RDR gHC_ARR (fsLit "unsafeIndex") +unsafeRangeSize_RDR = varQual_RDR gHC_ARR (fsLit "unsafeRangeSize") + +readList_RDR, readListDefault_RDR, readListPrec_RDR, readListPrecDefault_RDR, + readPrec_RDR, parens_RDR, choose_RDR, lexP_RDR, expectP_RDR :: RdrName +readList_RDR = varQual_RDR gHC_READ (fsLit "readList") +readListDefault_RDR = varQual_RDR gHC_READ (fsLit "readListDefault") +readListPrec_RDR = varQual_RDR gHC_READ (fsLit "readListPrec") +readListPrecDefault_RDR = varQual_RDR gHC_READ (fsLit "readListPrecDefault") +readPrec_RDR = varQual_RDR gHC_READ (fsLit "readPrec") +parens_RDR = varQual_RDR gHC_READ (fsLit "parens") +choose_RDR = varQual_RDR gHC_READ (fsLit "choose") +lexP_RDR = varQual_RDR gHC_READ (fsLit "lexP") +expectP_RDR = varQual_RDR gHC_READ (fsLit "expectP") + +readField_RDR, readFieldHash_RDR, readSymField_RDR :: RdrName +readField_RDR = varQual_RDR gHC_READ (fsLit "readField") +readFieldHash_RDR = varQual_RDR gHC_READ (fsLit "readFieldHash") +readSymField_RDR = varQual_RDR gHC_READ (fsLit "readSymField") + +punc_RDR, ident_RDR, symbol_RDR :: RdrName +punc_RDR = dataQual_RDR lEX (fsLit "Punc") +ident_RDR = dataQual_RDR lEX (fsLit "Ident") +symbol_RDR = dataQual_RDR lEX (fsLit "Symbol") + +step_RDR, alt_RDR, reset_RDR, prec_RDR, pfail_RDR :: RdrName +step_RDR = varQual_RDR rEAD_PREC (fsLit "step") +alt_RDR = varQual_RDR rEAD_PREC (fsLit "+++") +reset_RDR = varQual_RDR rEAD_PREC (fsLit "reset") +prec_RDR = varQual_RDR rEAD_PREC (fsLit "prec") +pfail_RDR = varQual_RDR rEAD_PREC (fsLit "pfail") + +showsPrec_RDR, shows_RDR, showString_RDR, + showSpace_RDR, showCommaSpace_RDR, showParen_RDR :: RdrName +showsPrec_RDR = varQual_RDR gHC_SHOW (fsLit "showsPrec") +shows_RDR = varQual_RDR gHC_SHOW (fsLit "shows") +showString_RDR = varQual_RDR gHC_SHOW (fsLit "showString") +showSpace_RDR = varQual_RDR gHC_SHOW (fsLit "showSpace") +showCommaSpace_RDR = varQual_RDR gHC_SHOW (fsLit "showCommaSpace") +showParen_RDR = varQual_RDR gHC_SHOW (fsLit "showParen") + +undefined_RDR :: RdrName +undefined_RDR = varQual_RDR gHC_ERR (fsLit "undefined") + +error_RDR :: RdrName +error_RDR = varQual_RDR gHC_ERR (fsLit "error") + +-- Generics (constructors and functions) +u1DataCon_RDR, par1DataCon_RDR, rec1DataCon_RDR, + k1DataCon_RDR, m1DataCon_RDR, l1DataCon_RDR, r1DataCon_RDR, + prodDataCon_RDR, comp1DataCon_RDR, + unPar1_RDR, unRec1_RDR, unK1_RDR, unComp1_RDR, + from_RDR, from1_RDR, to_RDR, to1_RDR, + datatypeName_RDR, moduleName_RDR, packageName_RDR, isNewtypeName_RDR, + conName_RDR, conFixity_RDR, conIsRecord_RDR, selName_RDR, + prefixDataCon_RDR, infixDataCon_RDR, leftAssocDataCon_RDR, + rightAssocDataCon_RDR, notAssocDataCon_RDR, + uAddrDataCon_RDR, uCharDataCon_RDR, uDoubleDataCon_RDR, + uFloatDataCon_RDR, uIntDataCon_RDR, uWordDataCon_RDR, + uAddrHash_RDR, uCharHash_RDR, uDoubleHash_RDR, + uFloatHash_RDR, uIntHash_RDR, uWordHash_RDR :: RdrName + +u1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "U1") +par1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Par1") +rec1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Rec1") +k1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "K1") +m1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "M1") + +l1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "L1") +r1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "R1") + +prodDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit ":*:") +comp1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Comp1") + +unPar1_RDR = varQual_RDR gHC_GENERICS (fsLit "unPar1") +unRec1_RDR = varQual_RDR gHC_GENERICS (fsLit "unRec1") +unK1_RDR = varQual_RDR gHC_GENERICS (fsLit "unK1") +unComp1_RDR = varQual_RDR gHC_GENERICS (fsLit "unComp1") + +from_RDR = varQual_RDR gHC_GENERICS (fsLit "from") +from1_RDR = varQual_RDR gHC_GENERICS (fsLit "from1") +to_RDR = varQual_RDR gHC_GENERICS (fsLit "to") +to1_RDR = varQual_RDR gHC_GENERICS (fsLit "to1") + +datatypeName_RDR = varQual_RDR gHC_GENERICS (fsLit "datatypeName") +moduleName_RDR = varQual_RDR gHC_GENERICS (fsLit "moduleName") +packageName_RDR = varQual_RDR gHC_GENERICS (fsLit "packageName") +isNewtypeName_RDR = varQual_RDR gHC_GENERICS (fsLit "isNewtype") +selName_RDR = varQual_RDR gHC_GENERICS (fsLit "selName") +conName_RDR = varQual_RDR gHC_GENERICS (fsLit "conName") +conFixity_RDR = varQual_RDR gHC_GENERICS (fsLit "conFixity") +conIsRecord_RDR = varQual_RDR gHC_GENERICS (fsLit "conIsRecord") + +prefixDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Prefix") +infixDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Infix") +leftAssocDataCon_RDR = nameRdrName leftAssociativeDataConName +rightAssocDataCon_RDR = nameRdrName rightAssociativeDataConName +notAssocDataCon_RDR = nameRdrName notAssociativeDataConName + +uAddrDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UAddr") +uCharDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UChar") +uDoubleDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UDouble") +uFloatDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UFloat") +uIntDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UInt") +uWordDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UWord") + +uAddrHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uAddr#") +uCharHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uChar#") +uDoubleHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uDouble#") +uFloatHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uFloat#") +uIntHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uInt#") +uWordHash_RDR = varQual_RDR gHC_GENERICS (fsLit "uWord#") + +fmap_RDR, replace_RDR, pure_RDR, ap_RDR, liftA2_RDR, foldable_foldr_RDR, + foldMap_RDR, null_RDR, all_RDR, traverse_RDR, mempty_RDR, + mappend_RDR :: RdrName +fmap_RDR = nameRdrName fmapName +replace_RDR = varQual_RDR gHC_BASE (fsLit "<$") +pure_RDR = nameRdrName pureAName +ap_RDR = nameRdrName apAName +liftA2_RDR = varQual_RDR gHC_BASE (fsLit "liftA2") +foldable_foldr_RDR = varQual_RDR dATA_FOLDABLE (fsLit "foldr") +foldMap_RDR = varQual_RDR dATA_FOLDABLE (fsLit "foldMap") +null_RDR = varQual_RDR dATA_FOLDABLE (fsLit "null") +all_RDR = varQual_RDR dATA_FOLDABLE (fsLit "all") +traverse_RDR = varQual_RDR dATA_TRAVERSABLE (fsLit "traverse") +mempty_RDR = nameRdrName memptyName +mappend_RDR = nameRdrName mappendName + +---------------------- +varQual_RDR, tcQual_RDR, clsQual_RDR, dataQual_RDR + :: Module -> FastString -> RdrName +varQual_RDR mod str = mkOrig mod (mkOccNameFS varName str) +tcQual_RDR mod str = mkOrig mod (mkOccNameFS tcName str) +clsQual_RDR mod str = mkOrig mod (mkOccNameFS clsName str) +dataQual_RDR mod str = mkOrig mod (mkOccNameFS dataName str) + +{- +************************************************************************ +* * +\subsection{Known-key names} +* * +************************************************************************ + +Many of these Names are not really "built in", but some parts of the +compiler (notably the deriving mechanism) need to mention their names, +and it's convenient to write them all down in one place. +-} + +wildCardName :: Name +wildCardName = mkSystemVarName wildCardKey (fsLit "wild") + +runMainIOName, runRWName :: Name +runMainIOName = varQual gHC_TOP_HANDLER (fsLit "runMainIO") runMainKey +runRWName = varQual gHC_MAGIC (fsLit "runRW#") runRWKey + +orderingTyConName, ordLTDataConName, ordEQDataConName, ordGTDataConName :: Name +orderingTyConName = tcQual gHC_TYPES (fsLit "Ordering") orderingTyConKey +ordLTDataConName = dcQual gHC_TYPES (fsLit "LT") ordLTDataConKey +ordEQDataConName = dcQual gHC_TYPES (fsLit "EQ") ordEQDataConKey +ordGTDataConName = dcQual gHC_TYPES (fsLit "GT") ordGTDataConKey + +specTyConName :: Name +specTyConName = tcQual gHC_TYPES (fsLit "SPEC") specTyConKey + +eitherTyConName, leftDataConName, rightDataConName :: Name +eitherTyConName = tcQual dATA_EITHER (fsLit "Either") eitherTyConKey +leftDataConName = dcQual dATA_EITHER (fsLit "Left") leftDataConKey +rightDataConName = dcQual dATA_EITHER (fsLit "Right") rightDataConKey + +-- Generics (types) +v1TyConName, u1TyConName, par1TyConName, rec1TyConName, + k1TyConName, m1TyConName, sumTyConName, prodTyConName, + compTyConName, rTyConName, dTyConName, + cTyConName, sTyConName, rec0TyConName, + d1TyConName, c1TyConName, s1TyConName, noSelTyConName, + repTyConName, rep1TyConName, uRecTyConName, + uAddrTyConName, uCharTyConName, uDoubleTyConName, + uFloatTyConName, uIntTyConName, uWordTyConName, + prefixIDataConName, infixIDataConName, leftAssociativeDataConName, + rightAssociativeDataConName, notAssociativeDataConName, + sourceUnpackDataConName, sourceNoUnpackDataConName, + noSourceUnpackednessDataConName, sourceLazyDataConName, + sourceStrictDataConName, noSourceStrictnessDataConName, + decidedLazyDataConName, decidedStrictDataConName, decidedUnpackDataConName, + metaDataDataConName, metaConsDataConName, metaSelDataConName :: Name + +v1TyConName = tcQual gHC_GENERICS (fsLit "V1") v1TyConKey +u1TyConName = tcQual gHC_GENERICS (fsLit "U1") u1TyConKey +par1TyConName = tcQual gHC_GENERICS (fsLit "Par1") par1TyConKey +rec1TyConName = tcQual gHC_GENERICS (fsLit "Rec1") rec1TyConKey +k1TyConName = tcQual gHC_GENERICS (fsLit "K1") k1TyConKey +m1TyConName = tcQual gHC_GENERICS (fsLit "M1") m1TyConKey + +sumTyConName = tcQual gHC_GENERICS (fsLit ":+:") sumTyConKey +prodTyConName = tcQual gHC_GENERICS (fsLit ":*:") prodTyConKey +compTyConName = tcQual gHC_GENERICS (fsLit ":.:") compTyConKey + +rTyConName = tcQual gHC_GENERICS (fsLit "R") rTyConKey +dTyConName = tcQual gHC_GENERICS (fsLit "D") dTyConKey +cTyConName = tcQual gHC_GENERICS (fsLit "C") cTyConKey +sTyConName = tcQual gHC_GENERICS (fsLit "S") sTyConKey + +rec0TyConName = tcQual gHC_GENERICS (fsLit "Rec0") rec0TyConKey +d1TyConName = tcQual gHC_GENERICS (fsLit "D1") d1TyConKey +c1TyConName = tcQual gHC_GENERICS (fsLit "C1") c1TyConKey +s1TyConName = tcQual gHC_GENERICS (fsLit "S1") s1TyConKey +noSelTyConName = tcQual gHC_GENERICS (fsLit "NoSelector") noSelTyConKey + +repTyConName = tcQual gHC_GENERICS (fsLit "Rep") repTyConKey +rep1TyConName = tcQual gHC_GENERICS (fsLit "Rep1") rep1TyConKey + +uRecTyConName = tcQual gHC_GENERICS (fsLit "URec") uRecTyConKey +uAddrTyConName = tcQual gHC_GENERICS (fsLit "UAddr") uAddrTyConKey +uCharTyConName = tcQual gHC_GENERICS (fsLit "UChar") uCharTyConKey +uDoubleTyConName = tcQual gHC_GENERICS (fsLit "UDouble") uDoubleTyConKey +uFloatTyConName = tcQual gHC_GENERICS (fsLit "UFloat") uFloatTyConKey +uIntTyConName = tcQual gHC_GENERICS (fsLit "UInt") uIntTyConKey +uWordTyConName = tcQual gHC_GENERICS (fsLit "UWord") uWordTyConKey + +prefixIDataConName = dcQual gHC_GENERICS (fsLit "PrefixI") prefixIDataConKey +infixIDataConName = dcQual gHC_GENERICS (fsLit "InfixI") infixIDataConKey +leftAssociativeDataConName = dcQual gHC_GENERICS (fsLit "LeftAssociative") leftAssociativeDataConKey +rightAssociativeDataConName = dcQual gHC_GENERICS (fsLit "RightAssociative") rightAssociativeDataConKey +notAssociativeDataConName = dcQual gHC_GENERICS (fsLit "NotAssociative") notAssociativeDataConKey + +sourceUnpackDataConName = dcQual gHC_GENERICS (fsLit "SourceUnpack") sourceUnpackDataConKey +sourceNoUnpackDataConName = dcQual gHC_GENERICS (fsLit "SourceNoUnpack") sourceNoUnpackDataConKey +noSourceUnpackednessDataConName = dcQual gHC_GENERICS (fsLit "NoSourceUnpackedness") noSourceUnpackednessDataConKey +sourceLazyDataConName = dcQual gHC_GENERICS (fsLit "SourceLazy") sourceLazyDataConKey +sourceStrictDataConName = dcQual gHC_GENERICS (fsLit "SourceStrict") sourceStrictDataConKey +noSourceStrictnessDataConName = dcQual gHC_GENERICS (fsLit "NoSourceStrictness") noSourceStrictnessDataConKey +decidedLazyDataConName = dcQual gHC_GENERICS (fsLit "DecidedLazy") decidedLazyDataConKey +decidedStrictDataConName = dcQual gHC_GENERICS (fsLit "DecidedStrict") decidedStrictDataConKey +decidedUnpackDataConName = dcQual gHC_GENERICS (fsLit "DecidedUnpack") decidedUnpackDataConKey + +metaDataDataConName = dcQual gHC_GENERICS (fsLit "MetaData") metaDataDataConKey +metaConsDataConName = dcQual gHC_GENERICS (fsLit "MetaCons") metaConsDataConKey +metaSelDataConName = dcQual gHC_GENERICS (fsLit "MetaSel") metaSelDataConKey + +-- Primitive Int +divIntName, modIntName :: Name +divIntName = varQual gHC_CLASSES (fsLit "divInt#") divIntIdKey +modIntName = varQual gHC_CLASSES (fsLit "modInt#") modIntIdKey + +-- Base strings Strings +unpackCStringName, unpackCStringFoldrName, + unpackCStringUtf8Name, eqStringName :: Name +unpackCStringName = varQual gHC_CSTRING (fsLit "unpackCString#") unpackCStringIdKey +unpackCStringFoldrName = varQual gHC_CSTRING (fsLit "unpackFoldrCString#") unpackCStringFoldrIdKey +unpackCStringUtf8Name = varQual gHC_CSTRING (fsLit "unpackCStringUtf8#") unpackCStringUtf8IdKey +eqStringName = varQual gHC_BASE (fsLit "eqString") eqStringIdKey + +-- The 'inline' function +inlineIdName :: Name +inlineIdName = varQual gHC_MAGIC (fsLit "inline") inlineIdKey + +-- Base classes (Eq, Ord, Functor) +fmapName, eqClassName, eqName, ordClassName, geName, functorClassName :: Name +eqClassName = clsQual gHC_CLASSES (fsLit "Eq") eqClassKey +eqName = varQual gHC_CLASSES (fsLit "==") eqClassOpKey +ordClassName = clsQual gHC_CLASSES (fsLit "Ord") ordClassKey +geName = varQual gHC_CLASSES (fsLit ">=") geClassOpKey +functorClassName = clsQual gHC_BASE (fsLit "Functor") functorClassKey +fmapName = varQual gHC_BASE (fsLit "fmap") fmapClassOpKey + +-- Class Monad +monadClassName, thenMName, bindMName, returnMName :: Name +monadClassName = clsQual gHC_BASE (fsLit "Monad") monadClassKey +thenMName = varQual gHC_BASE (fsLit ">>") thenMClassOpKey +bindMName = varQual gHC_BASE (fsLit ">>=") bindMClassOpKey +returnMName = varQual gHC_BASE (fsLit "return") returnMClassOpKey + +-- Class MonadFail +monadFailClassName, failMName :: Name +monadFailClassName = clsQual mONAD_FAIL (fsLit "MonadFail") monadFailClassKey +failMName = varQual mONAD_FAIL (fsLit "fail") failMClassOpKey + +-- Class Applicative +applicativeClassName, pureAName, apAName, thenAName :: Name +applicativeClassName = clsQual gHC_BASE (fsLit "Applicative") applicativeClassKey +apAName = varQual gHC_BASE (fsLit "<*>") apAClassOpKey +pureAName = varQual gHC_BASE (fsLit "pure") pureAClassOpKey +thenAName = varQual gHC_BASE (fsLit "*>") thenAClassOpKey + +-- Classes (Foldable, Traversable) +foldableClassName, traversableClassName :: Name +foldableClassName = clsQual dATA_FOLDABLE (fsLit "Foldable") foldableClassKey +traversableClassName = clsQual dATA_TRAVERSABLE (fsLit "Traversable") traversableClassKey + +-- Classes (Semigroup, Monoid) +semigroupClassName, sappendName :: Name +semigroupClassName = clsQual gHC_BASE (fsLit "Semigroup") semigroupClassKey +sappendName = varQual gHC_BASE (fsLit "<>") sappendClassOpKey +monoidClassName, memptyName, mappendName, mconcatName :: Name +monoidClassName = clsQual gHC_BASE (fsLit "Monoid") monoidClassKey +memptyName = varQual gHC_BASE (fsLit "mempty") memptyClassOpKey +mappendName = varQual gHC_BASE (fsLit "mappend") mappendClassOpKey +mconcatName = varQual gHC_BASE (fsLit "mconcat") mconcatClassOpKey + + + +-- AMP additions + +joinMName, alternativeClassName :: Name +joinMName = varQual gHC_BASE (fsLit "join") joinMIdKey +alternativeClassName = clsQual mONAD (fsLit "Alternative") alternativeClassKey + +-- +joinMIdKey, apAClassOpKey, pureAClassOpKey, thenAClassOpKey, + alternativeClassKey :: Unique +joinMIdKey = mkPreludeMiscIdUnique 750 +apAClassOpKey = mkPreludeMiscIdUnique 751 -- <*> +pureAClassOpKey = mkPreludeMiscIdUnique 752 +thenAClassOpKey = mkPreludeMiscIdUnique 753 +alternativeClassKey = mkPreludeMiscIdUnique 754 + + +-- Functions for GHC extensions +groupWithName :: Name +groupWithName = varQual gHC_EXTS (fsLit "groupWith") groupWithIdKey + +-- Random PrelBase functions +fromStringName, otherwiseIdName, foldrName, buildName, augmentName, + mapName, appendName, assertName, + breakpointName, breakpointCondName, + opaqueTyConName, dollarName :: Name +dollarName = varQual gHC_BASE (fsLit "$") dollarIdKey +otherwiseIdName = varQual gHC_BASE (fsLit "otherwise") otherwiseIdKey +foldrName = varQual gHC_BASE (fsLit "foldr") foldrIdKey +buildName = varQual gHC_BASE (fsLit "build") buildIdKey +augmentName = varQual gHC_BASE (fsLit "augment") augmentIdKey +mapName = varQual gHC_BASE (fsLit "map") mapIdKey +appendName = varQual gHC_BASE (fsLit "++") appendIdKey +assertName = varQual gHC_BASE (fsLit "assert") assertIdKey +breakpointName = varQual gHC_BASE (fsLit "breakpoint") breakpointIdKey +breakpointCondName= varQual gHC_BASE (fsLit "breakpointCond") breakpointCondIdKey +opaqueTyConName = tcQual gHC_BASE (fsLit "Opaque") opaqueTyConKey +fromStringName = varQual dATA_STRING (fsLit "fromString") fromStringClassOpKey + +-- PrelTup +fstName, sndName :: Name +fstName = varQual dATA_TUPLE (fsLit "fst") fstIdKey +sndName = varQual dATA_TUPLE (fsLit "snd") sndIdKey + +-- Module GHC.Num +numClassName, fromIntegerName, minusName, negateName :: Name +numClassName = clsQual gHC_NUM (fsLit "Num") numClassKey +fromIntegerName = varQual gHC_NUM (fsLit "fromInteger") fromIntegerClassOpKey +minusName = varQual gHC_NUM (fsLit "-") minusClassOpKey +negateName = varQual gHC_NUM (fsLit "negate") negateClassOpKey + +integerTyConName, mkIntegerName, integerSDataConName, + integerToWord64Name, integerToInt64Name, + word64ToIntegerName, int64ToIntegerName, + plusIntegerName, timesIntegerName, smallIntegerName, + wordToIntegerName, + integerToWordName, integerToIntName, minusIntegerName, + negateIntegerName, eqIntegerPrimName, neqIntegerPrimName, + absIntegerName, signumIntegerName, + leIntegerPrimName, gtIntegerPrimName, ltIntegerPrimName, geIntegerPrimName, + compareIntegerName, quotRemIntegerName, divModIntegerName, + quotIntegerName, remIntegerName, divIntegerName, modIntegerName, + floatFromIntegerName, doubleFromIntegerName, + encodeFloatIntegerName, encodeDoubleIntegerName, + decodeDoubleIntegerName, + gcdIntegerName, lcmIntegerName, + andIntegerName, orIntegerName, xorIntegerName, complementIntegerName, + shiftLIntegerName, shiftRIntegerName, bitIntegerName :: Name +integerTyConName = tcQual gHC_INTEGER_TYPE (fsLit "Integer") integerTyConKey +integerSDataConName = dcQual gHC_INTEGER_TYPE (fsLit "S#") integerSDataConKey +mkIntegerName = varQual gHC_INTEGER_TYPE (fsLit "mkInteger") mkIntegerIdKey +integerToWord64Name = varQual gHC_INTEGER_TYPE (fsLit "integerToWord64") integerToWord64IdKey +integerToInt64Name = varQual gHC_INTEGER_TYPE (fsLit "integerToInt64") integerToInt64IdKey +word64ToIntegerName = varQual gHC_INTEGER_TYPE (fsLit "word64ToInteger") word64ToIntegerIdKey +int64ToIntegerName = varQual gHC_INTEGER_TYPE (fsLit "int64ToInteger") int64ToIntegerIdKey +plusIntegerName = varQual gHC_INTEGER_TYPE (fsLit "plusInteger") plusIntegerIdKey +timesIntegerName = varQual gHC_INTEGER_TYPE (fsLit "timesInteger") timesIntegerIdKey +smallIntegerName = varQual gHC_INTEGER_TYPE (fsLit "smallInteger") smallIntegerIdKey +wordToIntegerName = varQual gHC_INTEGER_TYPE (fsLit "wordToInteger") wordToIntegerIdKey +integerToWordName = varQual gHC_INTEGER_TYPE (fsLit "integerToWord") integerToWordIdKey +integerToIntName = varQual gHC_INTEGER_TYPE (fsLit "integerToInt") integerToIntIdKey +minusIntegerName = varQual gHC_INTEGER_TYPE (fsLit "minusInteger") minusIntegerIdKey +negateIntegerName = varQual gHC_INTEGER_TYPE (fsLit "negateInteger") negateIntegerIdKey +eqIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "eqInteger#") eqIntegerPrimIdKey +neqIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "neqInteger#") neqIntegerPrimIdKey +absIntegerName = varQual gHC_INTEGER_TYPE (fsLit "absInteger") absIntegerIdKey +signumIntegerName = varQual gHC_INTEGER_TYPE (fsLit "signumInteger") signumIntegerIdKey +leIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "leInteger#") leIntegerPrimIdKey +gtIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "gtInteger#") gtIntegerPrimIdKey +ltIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "ltInteger#") ltIntegerPrimIdKey +geIntegerPrimName = varQual gHC_INTEGER_TYPE (fsLit "geInteger#") geIntegerPrimIdKey +compareIntegerName = varQual gHC_INTEGER_TYPE (fsLit "compareInteger") compareIntegerIdKey +quotRemIntegerName = varQual gHC_INTEGER_TYPE (fsLit "quotRemInteger") quotRemIntegerIdKey +divModIntegerName = varQual gHC_INTEGER_TYPE (fsLit "divModInteger") divModIntegerIdKey +quotIntegerName = varQual gHC_INTEGER_TYPE (fsLit "quotInteger") quotIntegerIdKey +remIntegerName = varQual gHC_INTEGER_TYPE (fsLit "remInteger") remIntegerIdKey +divIntegerName = varQual gHC_INTEGER_TYPE (fsLit "divInteger") divIntegerIdKey +modIntegerName = varQual gHC_INTEGER_TYPE (fsLit "modInteger") modIntegerIdKey +floatFromIntegerName = varQual gHC_INTEGER_TYPE (fsLit "floatFromInteger") floatFromIntegerIdKey +doubleFromIntegerName = varQual gHC_INTEGER_TYPE (fsLit "doubleFromInteger") doubleFromIntegerIdKey +encodeFloatIntegerName = varQual gHC_INTEGER_TYPE (fsLit "encodeFloatInteger") encodeFloatIntegerIdKey +encodeDoubleIntegerName = varQual gHC_INTEGER_TYPE (fsLit "encodeDoubleInteger") encodeDoubleIntegerIdKey +decodeDoubleIntegerName = varQual gHC_INTEGER_TYPE (fsLit "decodeDoubleInteger") decodeDoubleIntegerIdKey +gcdIntegerName = varQual gHC_INTEGER_TYPE (fsLit "gcdInteger") gcdIntegerIdKey +lcmIntegerName = varQual gHC_INTEGER_TYPE (fsLit "lcmInteger") lcmIntegerIdKey +andIntegerName = varQual gHC_INTEGER_TYPE (fsLit "andInteger") andIntegerIdKey +orIntegerName = varQual gHC_INTEGER_TYPE (fsLit "orInteger") orIntegerIdKey +xorIntegerName = varQual gHC_INTEGER_TYPE (fsLit "xorInteger") xorIntegerIdKey +complementIntegerName = varQual gHC_INTEGER_TYPE (fsLit "complementInteger") complementIntegerIdKey +shiftLIntegerName = varQual gHC_INTEGER_TYPE (fsLit "shiftLInteger") shiftLIntegerIdKey +shiftRIntegerName = varQual gHC_INTEGER_TYPE (fsLit "shiftRInteger") shiftRIntegerIdKey +bitIntegerName = varQual gHC_INTEGER_TYPE (fsLit "bitInteger") bitIntegerIdKey + +-- GHC.Natural types +naturalTyConName, naturalSDataConName :: Name +naturalTyConName = tcQual gHC_NATURAL (fsLit "Natural") naturalTyConKey +naturalSDataConName = dcQual gHC_NATURAL (fsLit "NatS#") naturalSDataConKey + +naturalFromIntegerName :: Name +naturalFromIntegerName = varQual gHC_NATURAL (fsLit "naturalFromInteger") naturalFromIntegerIdKey + +naturalToIntegerName, plusNaturalName, minusNaturalName, timesNaturalName, + mkNaturalName, wordToNaturalName :: Name +naturalToIntegerName = varQual gHC_NATURAL (fsLit "naturalToInteger") naturalToIntegerIdKey +plusNaturalName = varQual gHC_NATURAL (fsLit "plusNatural") plusNaturalIdKey +minusNaturalName = varQual gHC_NATURAL (fsLit "minusNatural") minusNaturalIdKey +timesNaturalName = varQual gHC_NATURAL (fsLit "timesNatural") timesNaturalIdKey +mkNaturalName = varQual gHC_NATURAL (fsLit "mkNatural") mkNaturalIdKey +wordToNaturalName = varQual gHC_NATURAL (fsLit "wordToNatural#") wordToNaturalIdKey + +-- GHC.Real types and classes +rationalTyConName, ratioTyConName, ratioDataConName, realClassName, + integralClassName, realFracClassName, fractionalClassName, + fromRationalName, toIntegerName, toRationalName, fromIntegralName, + realToFracName :: Name +rationalTyConName = tcQual gHC_REAL (fsLit "Rational") rationalTyConKey +ratioTyConName = tcQual gHC_REAL (fsLit "Ratio") ratioTyConKey +ratioDataConName = dcQual gHC_REAL (fsLit ":%") ratioDataConKey +realClassName = clsQual gHC_REAL (fsLit "Real") realClassKey +integralClassName = clsQual gHC_REAL (fsLit "Integral") integralClassKey +realFracClassName = clsQual gHC_REAL (fsLit "RealFrac") realFracClassKey +fractionalClassName = clsQual gHC_REAL (fsLit "Fractional") fractionalClassKey +fromRationalName = varQual gHC_REAL (fsLit "fromRational") fromRationalClassOpKey +toIntegerName = varQual gHC_REAL (fsLit "toInteger") toIntegerClassOpKey +toRationalName = varQual gHC_REAL (fsLit "toRational") toRationalClassOpKey +fromIntegralName = varQual gHC_REAL (fsLit "fromIntegral")fromIntegralIdKey +realToFracName = varQual gHC_REAL (fsLit "realToFrac") realToFracIdKey + +-- PrelFloat classes +floatingClassName, realFloatClassName :: Name +floatingClassName = clsQual gHC_FLOAT (fsLit "Floating") floatingClassKey +realFloatClassName = clsQual gHC_FLOAT (fsLit "RealFloat") realFloatClassKey + +-- other GHC.Float functions +rationalToFloatName, rationalToDoubleName :: Name +rationalToFloatName = varQual gHC_FLOAT (fsLit "rationalToFloat") rationalToFloatIdKey +rationalToDoubleName = varQual gHC_FLOAT (fsLit "rationalToDouble") rationalToDoubleIdKey + +-- Class Ix +ixClassName :: Name +ixClassName = clsQual gHC_ARR (fsLit "Ix") ixClassKey + +-- Typeable representation types +trModuleTyConName + , trModuleDataConName + , trNameTyConName + , trNameSDataConName + , trNameDDataConName + , trTyConTyConName + , trTyConDataConName + :: Name +trModuleTyConName = tcQual gHC_TYPES (fsLit "Module") trModuleTyConKey +trModuleDataConName = dcQual gHC_TYPES (fsLit "Module") trModuleDataConKey +trNameTyConName = tcQual gHC_TYPES (fsLit "TrName") trNameTyConKey +trNameSDataConName = dcQual gHC_TYPES (fsLit "TrNameS") trNameSDataConKey +trNameDDataConName = dcQual gHC_TYPES (fsLit "TrNameD") trNameDDataConKey +trTyConTyConName = tcQual gHC_TYPES (fsLit "TyCon") trTyConTyConKey +trTyConDataConName = dcQual gHC_TYPES (fsLit "TyCon") trTyConDataConKey + +kindRepTyConName + , kindRepTyConAppDataConName + , kindRepVarDataConName + , kindRepAppDataConName + , kindRepFunDataConName + , kindRepTYPEDataConName + , kindRepTypeLitSDataConName + , kindRepTypeLitDDataConName + :: Name +kindRepTyConName = tcQual gHC_TYPES (fsLit "KindRep") kindRepTyConKey +kindRepTyConAppDataConName = dcQual gHC_TYPES (fsLit "KindRepTyConApp") kindRepTyConAppDataConKey +kindRepVarDataConName = dcQual gHC_TYPES (fsLit "KindRepVar") kindRepVarDataConKey +kindRepAppDataConName = dcQual gHC_TYPES (fsLit "KindRepApp") kindRepAppDataConKey +kindRepFunDataConName = dcQual gHC_TYPES (fsLit "KindRepFun") kindRepFunDataConKey +kindRepTYPEDataConName = dcQual gHC_TYPES (fsLit "KindRepTYPE") kindRepTYPEDataConKey +kindRepTypeLitSDataConName = dcQual gHC_TYPES (fsLit "KindRepTypeLitS") kindRepTypeLitSDataConKey +kindRepTypeLitDDataConName = dcQual gHC_TYPES (fsLit "KindRepTypeLitD") kindRepTypeLitDDataConKey + +typeLitSortTyConName + , typeLitSymbolDataConName + , typeLitNatDataConName + :: Name +typeLitSortTyConName = tcQual gHC_TYPES (fsLit "TypeLitSort") typeLitSortTyConKey +typeLitSymbolDataConName = dcQual gHC_TYPES (fsLit "TypeLitSymbol") typeLitSymbolDataConKey +typeLitNatDataConName = dcQual gHC_TYPES (fsLit "TypeLitNat") typeLitNatDataConKey + +-- Class Typeable, and functions for constructing `Typeable` dictionaries +typeableClassName + , typeRepTyConName + , someTypeRepTyConName + , someTypeRepDataConName + , mkTrTypeName + , mkTrConName + , mkTrAppName + , mkTrFunName + , typeRepIdName + , typeNatTypeRepName + , typeSymbolTypeRepName + , trGhcPrimModuleName + :: Name +typeableClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable") typeableClassKey +typeRepTyConName = tcQual tYPEABLE_INTERNAL (fsLit "TypeRep") typeRepTyConKey +someTypeRepTyConName = tcQual tYPEABLE_INTERNAL (fsLit "SomeTypeRep") someTypeRepTyConKey +someTypeRepDataConName = dcQual tYPEABLE_INTERNAL (fsLit "SomeTypeRep") someTypeRepDataConKey +typeRepIdName = varQual tYPEABLE_INTERNAL (fsLit "typeRep#") typeRepIdKey +mkTrTypeName = varQual tYPEABLE_INTERNAL (fsLit "mkTrType") mkTrTypeKey +mkTrConName = varQual tYPEABLE_INTERNAL (fsLit "mkTrCon") mkTrConKey +mkTrAppName = varQual tYPEABLE_INTERNAL (fsLit "mkTrApp") mkTrAppKey +mkTrFunName = varQual tYPEABLE_INTERNAL (fsLit "mkTrFun") mkTrFunKey +typeNatTypeRepName = varQual tYPEABLE_INTERNAL (fsLit "typeNatTypeRep") typeNatTypeRepKey +typeSymbolTypeRepName = varQual tYPEABLE_INTERNAL (fsLit "typeSymbolTypeRep") typeSymbolTypeRepKey +-- this is the Typeable 'Module' for GHC.Prim (which has no code, so we place in GHC.Types) +-- See Note [Grand plan for Typeable] in TcTypeable. +trGhcPrimModuleName = varQual gHC_TYPES (fsLit "tr$ModuleGHCPrim") trGhcPrimModuleKey + +-- Typeable KindReps for some common cases +starKindRepName, starArrStarKindRepName, starArrStarArrStarKindRepName :: Name +starKindRepName = varQual gHC_TYPES (fsLit "krep$*") starKindRepKey +starArrStarKindRepName = varQual gHC_TYPES (fsLit "krep$*Arr*") starArrStarKindRepKey +starArrStarArrStarKindRepName = varQual gHC_TYPES (fsLit "krep$*->*->*") starArrStarArrStarKindRepKey + +-- Custom type errors +errorMessageTypeErrorFamName + , typeErrorTextDataConName + , typeErrorAppendDataConName + , typeErrorVAppendDataConName + , typeErrorShowTypeDataConName + :: Name + +errorMessageTypeErrorFamName = + tcQual gHC_TYPELITS (fsLit "TypeError") errorMessageTypeErrorFamKey + +typeErrorTextDataConName = + dcQual gHC_TYPELITS (fsLit "Text") typeErrorTextDataConKey + +typeErrorAppendDataConName = + dcQual gHC_TYPELITS (fsLit ":<>:") typeErrorAppendDataConKey + +typeErrorVAppendDataConName = + dcQual gHC_TYPELITS (fsLit ":$$:") typeErrorVAppendDataConKey + +typeErrorShowTypeDataConName = + dcQual gHC_TYPELITS (fsLit "ShowType") typeErrorShowTypeDataConKey + + + +-- Dynamic +toDynName :: Name +toDynName = varQual dYNAMIC (fsLit "toDyn") toDynIdKey + +-- Class Data +dataClassName :: Name +dataClassName = clsQual gENERICS (fsLit "Data") dataClassKey + +-- Error module +assertErrorName :: Name +assertErrorName = varQual gHC_IO_Exception (fsLit "assertError") assertErrorIdKey + +-- Debug.Trace +traceName :: Name +traceName = varQual dEBUG_TRACE (fsLit "trace") traceKey + +-- Enum module (Enum, Bounded) +enumClassName, enumFromName, enumFromToName, enumFromThenName, + enumFromThenToName, boundedClassName :: Name +enumClassName = clsQual gHC_ENUM (fsLit "Enum") enumClassKey +enumFromName = varQual gHC_ENUM (fsLit "enumFrom") enumFromClassOpKey +enumFromToName = varQual gHC_ENUM (fsLit "enumFromTo") enumFromToClassOpKey +enumFromThenName = varQual gHC_ENUM (fsLit "enumFromThen") enumFromThenClassOpKey +enumFromThenToName = varQual gHC_ENUM (fsLit "enumFromThenTo") enumFromThenToClassOpKey +boundedClassName = clsQual gHC_ENUM (fsLit "Bounded") boundedClassKey + +-- List functions +concatName, filterName, zipName :: Name +concatName = varQual gHC_LIST (fsLit "concat") concatIdKey +filterName = varQual gHC_LIST (fsLit "filter") filterIdKey +zipName = varQual gHC_LIST (fsLit "zip") zipIdKey + +-- Overloaded lists +isListClassName, fromListName, fromListNName, toListName :: Name +isListClassName = clsQual gHC_EXTS (fsLit "IsList") isListClassKey +fromListName = varQual gHC_EXTS (fsLit "fromList") fromListClassOpKey +fromListNName = varQual gHC_EXTS (fsLit "fromListN") fromListNClassOpKey +toListName = varQual gHC_EXTS (fsLit "toList") toListClassOpKey + +-- Class Show +showClassName :: Name +showClassName = clsQual gHC_SHOW (fsLit "Show") showClassKey + +-- Class Read +readClassName :: Name +readClassName = clsQual gHC_READ (fsLit "Read") readClassKey + +-- Classes Generic and Generic1, Datatype, Constructor and Selector +genClassName, gen1ClassName, datatypeClassName, constructorClassName, + selectorClassName :: Name +genClassName = clsQual gHC_GENERICS (fsLit "Generic") genClassKey +gen1ClassName = clsQual gHC_GENERICS (fsLit "Generic1") gen1ClassKey + +datatypeClassName = clsQual gHC_GENERICS (fsLit "Datatype") datatypeClassKey +constructorClassName = clsQual gHC_GENERICS (fsLit "Constructor") constructorClassKey +selectorClassName = clsQual gHC_GENERICS (fsLit "Selector") selectorClassKey + +genericClassNames :: [Name] +genericClassNames = [genClassName, gen1ClassName] + +-- GHCi things +ghciIoClassName, ghciStepIoMName :: Name +ghciIoClassName = clsQual gHC_GHCI (fsLit "GHCiSandboxIO") ghciIoClassKey +ghciStepIoMName = varQual gHC_GHCI (fsLit "ghciStepIO") ghciStepIoMClassOpKey + +-- IO things +ioTyConName, ioDataConName, + thenIOName, bindIOName, returnIOName, failIOName :: Name +ioTyConName = tcQual gHC_TYPES (fsLit "IO") ioTyConKey +ioDataConName = dcQual gHC_TYPES (fsLit "IO") ioDataConKey +thenIOName = varQual gHC_BASE (fsLit "thenIO") thenIOIdKey +bindIOName = varQual gHC_BASE (fsLit "bindIO") bindIOIdKey +returnIOName = varQual gHC_BASE (fsLit "returnIO") returnIOIdKey +failIOName = varQual gHC_IO (fsLit "failIO") failIOIdKey + +-- IO things +printName :: Name +printName = varQual sYSTEM_IO (fsLit "print") printIdKey + +-- Int, Word, and Addr things +int8TyConName, int16TyConName, int32TyConName, int64TyConName :: Name +int8TyConName = tcQual gHC_INT (fsLit "Int8") int8TyConKey +int16TyConName = tcQual gHC_INT (fsLit "Int16") int16TyConKey +int32TyConName = tcQual gHC_INT (fsLit "Int32") int32TyConKey +int64TyConName = tcQual gHC_INT (fsLit "Int64") int64TyConKey + +-- Word module +word16TyConName, word32TyConName, word64TyConName :: Name +word16TyConName = tcQual gHC_WORD (fsLit "Word16") word16TyConKey +word32TyConName = tcQual gHC_WORD (fsLit "Word32") word32TyConKey +word64TyConName = tcQual gHC_WORD (fsLit "Word64") word64TyConKey + +-- PrelPtr module +ptrTyConName, funPtrTyConName :: Name +ptrTyConName = tcQual gHC_PTR (fsLit "Ptr") ptrTyConKey +funPtrTyConName = tcQual gHC_PTR (fsLit "FunPtr") funPtrTyConKey + +-- Foreign objects and weak pointers +stablePtrTyConName, newStablePtrName :: Name +stablePtrTyConName = tcQual gHC_STABLE (fsLit "StablePtr") stablePtrTyConKey +newStablePtrName = varQual gHC_STABLE (fsLit "newStablePtr") newStablePtrIdKey + +-- Recursive-do notation +monadFixClassName, mfixName :: Name +monadFixClassName = clsQual mONAD_FIX (fsLit "MonadFix") monadFixClassKey +mfixName = varQual mONAD_FIX (fsLit "mfix") mfixIdKey + +-- Arrow notation +arrAName, composeAName, firstAName, appAName, choiceAName, loopAName :: Name +arrAName = varQual aRROW (fsLit "arr") arrAIdKey +composeAName = varQual gHC_DESUGAR (fsLit ">>>") composeAIdKey +firstAName = varQual aRROW (fsLit "first") firstAIdKey +appAName = varQual aRROW (fsLit "app") appAIdKey +choiceAName = varQual aRROW (fsLit "|||") choiceAIdKey +loopAName = varQual aRROW (fsLit "loop") loopAIdKey + +-- Monad comprehensions +guardMName, liftMName, mzipName :: Name +guardMName = varQual mONAD (fsLit "guard") guardMIdKey +liftMName = varQual mONAD (fsLit "liftM") liftMIdKey +mzipName = varQual mONAD_ZIP (fsLit "mzip") mzipIdKey + + +-- Annotation type checking +toAnnotationWrapperName :: Name +toAnnotationWrapperName = varQual gHC_DESUGAR (fsLit "toAnnotationWrapper") toAnnotationWrapperIdKey + +-- Other classes, needed for type defaulting +monadPlusClassName, randomClassName, randomGenClassName, + isStringClassName :: Name +monadPlusClassName = clsQual mONAD (fsLit "MonadPlus") monadPlusClassKey +randomClassName = clsQual rANDOM (fsLit "Random") randomClassKey +randomGenClassName = clsQual rANDOM (fsLit "RandomGen") randomGenClassKey +isStringClassName = clsQual dATA_STRING (fsLit "IsString") isStringClassKey + +-- Type-level naturals +knownNatClassName :: Name +knownNatClassName = clsQual gHC_TYPENATS (fsLit "KnownNat") knownNatClassNameKey +knownSymbolClassName :: Name +knownSymbolClassName = clsQual gHC_TYPELITS (fsLit "KnownSymbol") knownSymbolClassNameKey + +-- Overloaded labels +isLabelClassName :: Name +isLabelClassName + = clsQual gHC_OVER_LABELS (fsLit "IsLabel") isLabelClassNameKey + +-- Implicit Parameters +ipClassName :: Name +ipClassName + = clsQual gHC_CLASSES (fsLit "IP") ipClassKey + +-- Overloaded record fields +hasFieldClassName :: Name +hasFieldClassName + = clsQual gHC_RECORDS (fsLit "HasField") hasFieldClassNameKey + +-- Source Locations +callStackTyConName, emptyCallStackName, pushCallStackName, + srcLocDataConName :: Name +callStackTyConName + = tcQual gHC_STACK_TYPES (fsLit "CallStack") callStackTyConKey +emptyCallStackName + = varQual gHC_STACK_TYPES (fsLit "emptyCallStack") emptyCallStackKey +pushCallStackName + = varQual gHC_STACK_TYPES (fsLit "pushCallStack") pushCallStackKey +srcLocDataConName + = dcQual gHC_STACK_TYPES (fsLit "SrcLoc") srcLocDataConKey + +-- plugins +pLUGINS :: Module +pLUGINS = mkThisGhcModule (fsLit "Plugins") +pluginTyConName :: Name +pluginTyConName = tcQual pLUGINS (fsLit "Plugin") pluginTyConKey +frontendPluginTyConName :: Name +frontendPluginTyConName = tcQual pLUGINS (fsLit "FrontendPlugin") frontendPluginTyConKey + +-- Static pointers +makeStaticName :: Name +makeStaticName = + varQual gHC_STATICPTR_INTERNAL (fsLit "makeStatic") makeStaticKey + +staticPtrInfoTyConName :: Name +staticPtrInfoTyConName = + tcQual gHC_STATICPTR (fsLit "StaticPtrInfo") staticPtrInfoTyConKey + +staticPtrInfoDataConName :: Name +staticPtrInfoDataConName = + dcQual gHC_STATICPTR (fsLit "StaticPtrInfo") staticPtrInfoDataConKey + +staticPtrTyConName :: Name +staticPtrTyConName = + tcQual gHC_STATICPTR (fsLit "StaticPtr") staticPtrTyConKey + +staticPtrDataConName :: Name +staticPtrDataConName = + dcQual gHC_STATICPTR (fsLit "StaticPtr") staticPtrDataConKey + +fromStaticPtrName :: Name +fromStaticPtrName = + varQual gHC_STATICPTR (fsLit "fromStaticPtr") fromStaticPtrClassOpKey + +fingerprintDataConName :: Name +fingerprintDataConName = + dcQual gHC_FINGERPRINT_TYPE (fsLit "Fingerprint") fingerprintDataConKey + +{- +************************************************************************ +* * +\subsection{Local helpers} +* * +************************************************************************ + +All these are original names; hence mkOrig +-} + +varQual, tcQual, clsQual, dcQual :: Module -> FastString -> Unique -> Name +varQual = mk_known_key_name varName +tcQual = mk_known_key_name tcName +clsQual = mk_known_key_name clsName +dcQual = mk_known_key_name dataName + +mk_known_key_name :: NameSpace -> Module -> FastString -> Unique -> Name +mk_known_key_name space modu str unique + = mkExternalName unique modu (mkOccNameFS space str) noSrcSpan + + +{- +************************************************************************ +* * +\subsubsection[Uniques-prelude-Classes]{@Uniques@ for wired-in @Classes@} +* * +************************************************************************ +--MetaHaskell extension hand allocate keys here +-} + +boundedClassKey, enumClassKey, eqClassKey, floatingClassKey, + fractionalClassKey, integralClassKey, monadClassKey, dataClassKey, + functorClassKey, numClassKey, ordClassKey, readClassKey, realClassKey, + realFloatClassKey, realFracClassKey, showClassKey, ixClassKey :: Unique +boundedClassKey = mkPreludeClassUnique 1 +enumClassKey = mkPreludeClassUnique 2 +eqClassKey = mkPreludeClassUnique 3 +floatingClassKey = mkPreludeClassUnique 5 +fractionalClassKey = mkPreludeClassUnique 6 +integralClassKey = mkPreludeClassUnique 7 +monadClassKey = mkPreludeClassUnique 8 +dataClassKey = mkPreludeClassUnique 9 +functorClassKey = mkPreludeClassUnique 10 +numClassKey = mkPreludeClassUnique 11 +ordClassKey = mkPreludeClassUnique 12 +readClassKey = mkPreludeClassUnique 13 +realClassKey = mkPreludeClassUnique 14 +realFloatClassKey = mkPreludeClassUnique 15 +realFracClassKey = mkPreludeClassUnique 16 +showClassKey = mkPreludeClassUnique 17 +ixClassKey = mkPreludeClassUnique 18 + +typeableClassKey, typeable1ClassKey, typeable2ClassKey, typeable3ClassKey, + typeable4ClassKey, typeable5ClassKey, typeable6ClassKey, typeable7ClassKey + :: Unique +typeableClassKey = mkPreludeClassUnique 20 +typeable1ClassKey = mkPreludeClassUnique 21 +typeable2ClassKey = mkPreludeClassUnique 22 +typeable3ClassKey = mkPreludeClassUnique 23 +typeable4ClassKey = mkPreludeClassUnique 24 +typeable5ClassKey = mkPreludeClassUnique 25 +typeable6ClassKey = mkPreludeClassUnique 26 +typeable7ClassKey = mkPreludeClassUnique 27 + +monadFixClassKey :: Unique +monadFixClassKey = mkPreludeClassUnique 28 + +monadFailClassKey :: Unique +monadFailClassKey = mkPreludeClassUnique 29 + +monadPlusClassKey, randomClassKey, randomGenClassKey :: Unique +monadPlusClassKey = mkPreludeClassUnique 30 +randomClassKey = mkPreludeClassUnique 31 +randomGenClassKey = mkPreludeClassUnique 32 + +isStringClassKey :: Unique +isStringClassKey = mkPreludeClassUnique 33 + +applicativeClassKey, foldableClassKey, traversableClassKey :: Unique +applicativeClassKey = mkPreludeClassUnique 34 +foldableClassKey = mkPreludeClassUnique 35 +traversableClassKey = mkPreludeClassUnique 36 + +genClassKey, gen1ClassKey, datatypeClassKey, constructorClassKey, + selectorClassKey :: Unique +genClassKey = mkPreludeClassUnique 37 +gen1ClassKey = mkPreludeClassUnique 38 + +datatypeClassKey = mkPreludeClassUnique 39 +constructorClassKey = mkPreludeClassUnique 40 +selectorClassKey = mkPreludeClassUnique 41 + +-- KnownNat: see Note [KnowNat & KnownSymbol and EvLit] in TcEvidence +knownNatClassNameKey :: Unique +knownNatClassNameKey = mkPreludeClassUnique 42 + +-- KnownSymbol: see Note [KnownNat & KnownSymbol and EvLit] in TcEvidence +knownSymbolClassNameKey :: Unique +knownSymbolClassNameKey = mkPreludeClassUnique 43 + +ghciIoClassKey :: Unique +ghciIoClassKey = mkPreludeClassUnique 44 + +isLabelClassNameKey :: Unique +isLabelClassNameKey = mkPreludeClassUnique 45 + +semigroupClassKey, monoidClassKey :: Unique +semigroupClassKey = mkPreludeClassUnique 46 +monoidClassKey = mkPreludeClassUnique 47 + +-- Implicit Parameters +ipClassKey :: Unique +ipClassKey = mkPreludeClassUnique 48 + +-- Overloaded record fields +hasFieldClassNameKey :: Unique +hasFieldClassNameKey = mkPreludeClassUnique 49 + + +---------------- Template Haskell ------------------- +-- THNames.hs: USES ClassUniques 200-299 +----------------------------------------------------- + +{- +************************************************************************ +* * +\subsubsection[Uniques-prelude-TyCons]{@Uniques@ for wired-in @TyCons@} +* * +************************************************************************ +-} + +addrPrimTyConKey, arrayPrimTyConKey, arrayArrayPrimTyConKey, boolTyConKey, + byteArrayPrimTyConKey, charPrimTyConKey, charTyConKey, doublePrimTyConKey, + doubleTyConKey, floatPrimTyConKey, floatTyConKey, funTyConKey, + intPrimTyConKey, intTyConKey, int8TyConKey, int16TyConKey, + int8PrimTyConKey, int16PrimTyConKey, int32PrimTyConKey, int32TyConKey, + int64PrimTyConKey, int64TyConKey, + integerTyConKey, naturalTyConKey, + listTyConKey, foreignObjPrimTyConKey, maybeTyConKey, + weakPrimTyConKey, mutableArrayPrimTyConKey, mutableArrayArrayPrimTyConKey, + mutableByteArrayPrimTyConKey, orderingTyConKey, mVarPrimTyConKey, + ratioTyConKey, rationalTyConKey, realWorldTyConKey, stablePtrPrimTyConKey, + stablePtrTyConKey, eqTyConKey, heqTyConKey, + smallArrayPrimTyConKey, smallMutableArrayPrimTyConKey :: Unique +addrPrimTyConKey = mkPreludeTyConUnique 1 +arrayPrimTyConKey = mkPreludeTyConUnique 3 +boolTyConKey = mkPreludeTyConUnique 4 +byteArrayPrimTyConKey = mkPreludeTyConUnique 5 +charPrimTyConKey = mkPreludeTyConUnique 7 +charTyConKey = mkPreludeTyConUnique 8 +doublePrimTyConKey = mkPreludeTyConUnique 9 +doubleTyConKey = mkPreludeTyConUnique 10 +floatPrimTyConKey = mkPreludeTyConUnique 11 +floatTyConKey = mkPreludeTyConUnique 12 +funTyConKey = mkPreludeTyConUnique 13 +intPrimTyConKey = mkPreludeTyConUnique 14 +intTyConKey = mkPreludeTyConUnique 15 +int8PrimTyConKey = mkPreludeTyConUnique 16 +int8TyConKey = mkPreludeTyConUnique 17 +int16PrimTyConKey = mkPreludeTyConUnique 18 +int16TyConKey = mkPreludeTyConUnique 19 +int32PrimTyConKey = mkPreludeTyConUnique 20 +int32TyConKey = mkPreludeTyConUnique 21 +int64PrimTyConKey = mkPreludeTyConUnique 22 +int64TyConKey = mkPreludeTyConUnique 23 +integerTyConKey = mkPreludeTyConUnique 24 +naturalTyConKey = mkPreludeTyConUnique 25 + +listTyConKey = mkPreludeTyConUnique 26 +foreignObjPrimTyConKey = mkPreludeTyConUnique 27 +maybeTyConKey = mkPreludeTyConUnique 28 +weakPrimTyConKey = mkPreludeTyConUnique 29 +mutableArrayPrimTyConKey = mkPreludeTyConUnique 30 +mutableByteArrayPrimTyConKey = mkPreludeTyConUnique 31 +orderingTyConKey = mkPreludeTyConUnique 32 +mVarPrimTyConKey = mkPreludeTyConUnique 33 +ratioTyConKey = mkPreludeTyConUnique 34 +rationalTyConKey = mkPreludeTyConUnique 35 +realWorldTyConKey = mkPreludeTyConUnique 36 +stablePtrPrimTyConKey = mkPreludeTyConUnique 37 +stablePtrTyConKey = mkPreludeTyConUnique 38 +eqTyConKey = mkPreludeTyConUnique 40 +heqTyConKey = mkPreludeTyConUnique 41 +arrayArrayPrimTyConKey = mkPreludeTyConUnique 42 +mutableArrayArrayPrimTyConKey = mkPreludeTyConUnique 43 + +statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey, + mutVarPrimTyConKey, ioTyConKey, + wordPrimTyConKey, wordTyConKey, word8PrimTyConKey, word8TyConKey, + word16PrimTyConKey, word16TyConKey, word32PrimTyConKey, word32TyConKey, + word64PrimTyConKey, word64TyConKey, + liftedConKey, unliftedConKey, anyBoxConKey, kindConKey, boxityConKey, + typeConKey, threadIdPrimTyConKey, bcoPrimTyConKey, ptrTyConKey, + funPtrTyConKey, tVarPrimTyConKey, eqPrimTyConKey, + eqReprPrimTyConKey, eqPhantPrimTyConKey, voidPrimTyConKey, + compactPrimTyConKey :: Unique +statePrimTyConKey = mkPreludeTyConUnique 50 +stableNamePrimTyConKey = mkPreludeTyConUnique 51 +stableNameTyConKey = mkPreludeTyConUnique 52 +eqPrimTyConKey = mkPreludeTyConUnique 53 +eqReprPrimTyConKey = mkPreludeTyConUnique 54 +eqPhantPrimTyConKey = mkPreludeTyConUnique 55 +mutVarPrimTyConKey = mkPreludeTyConUnique 56 +ioTyConKey = mkPreludeTyConUnique 57 +voidPrimTyConKey = mkPreludeTyConUnique 58 +wordPrimTyConKey = mkPreludeTyConUnique 59 +wordTyConKey = mkPreludeTyConUnique 60 +word8PrimTyConKey = mkPreludeTyConUnique 61 +word8TyConKey = mkPreludeTyConUnique 62 +word16PrimTyConKey = mkPreludeTyConUnique 63 +word16TyConKey = mkPreludeTyConUnique 64 +word32PrimTyConKey = mkPreludeTyConUnique 65 +word32TyConKey = mkPreludeTyConUnique 66 +word64PrimTyConKey = mkPreludeTyConUnique 67 +word64TyConKey = mkPreludeTyConUnique 68 +liftedConKey = mkPreludeTyConUnique 69 +unliftedConKey = mkPreludeTyConUnique 70 +anyBoxConKey = mkPreludeTyConUnique 71 +kindConKey = mkPreludeTyConUnique 72 +boxityConKey = mkPreludeTyConUnique 73 +typeConKey = mkPreludeTyConUnique 74 +threadIdPrimTyConKey = mkPreludeTyConUnique 75 +bcoPrimTyConKey = mkPreludeTyConUnique 76 +ptrTyConKey = mkPreludeTyConUnique 77 +funPtrTyConKey = mkPreludeTyConUnique 78 +tVarPrimTyConKey = mkPreludeTyConUnique 79 +compactPrimTyConKey = mkPreludeTyConUnique 80 + +-- dotnet interop +objectTyConKey :: Unique +objectTyConKey = mkPreludeTyConUnique 83 + +eitherTyConKey :: Unique +eitherTyConKey = mkPreludeTyConUnique 84 + +-- Kind constructors +liftedTypeKindTyConKey, tYPETyConKey, + constraintKindTyConKey, runtimeRepTyConKey, + vecCountTyConKey, vecElemTyConKey :: Unique +liftedTypeKindTyConKey = mkPreludeTyConUnique 87 +tYPETyConKey = mkPreludeTyConUnique 88 +constraintKindTyConKey = mkPreludeTyConUnique 92 +runtimeRepTyConKey = mkPreludeTyConUnique 95 +vecCountTyConKey = mkPreludeTyConUnique 96 +vecElemTyConKey = mkPreludeTyConUnique 97 + +pluginTyConKey, frontendPluginTyConKey :: Unique +pluginTyConKey = mkPreludeTyConUnique 102 +frontendPluginTyConKey = mkPreludeTyConUnique 103 + +unknownTyConKey, unknown1TyConKey, unknown2TyConKey, unknown3TyConKey, + opaqueTyConKey :: Unique +unknownTyConKey = mkPreludeTyConUnique 129 +unknown1TyConKey = mkPreludeTyConUnique 130 +unknown2TyConKey = mkPreludeTyConUnique 131 +unknown3TyConKey = mkPreludeTyConUnique 132 +opaqueTyConKey = mkPreludeTyConUnique 133 + +-- Generics (Unique keys) +v1TyConKey, u1TyConKey, par1TyConKey, rec1TyConKey, + k1TyConKey, m1TyConKey, sumTyConKey, prodTyConKey, + compTyConKey, rTyConKey, dTyConKey, + cTyConKey, sTyConKey, rec0TyConKey, + d1TyConKey, c1TyConKey, s1TyConKey, noSelTyConKey, + repTyConKey, rep1TyConKey, uRecTyConKey, + uAddrTyConKey, uCharTyConKey, uDoubleTyConKey, + uFloatTyConKey, uIntTyConKey, uWordTyConKey :: Unique + +v1TyConKey = mkPreludeTyConUnique 135 +u1TyConKey = mkPreludeTyConUnique 136 +par1TyConKey = mkPreludeTyConUnique 137 +rec1TyConKey = mkPreludeTyConUnique 138 +k1TyConKey = mkPreludeTyConUnique 139 +m1TyConKey = mkPreludeTyConUnique 140 + +sumTyConKey = mkPreludeTyConUnique 141 +prodTyConKey = mkPreludeTyConUnique 142 +compTyConKey = mkPreludeTyConUnique 143 + +rTyConKey = mkPreludeTyConUnique 144 +dTyConKey = mkPreludeTyConUnique 146 +cTyConKey = mkPreludeTyConUnique 147 +sTyConKey = mkPreludeTyConUnique 148 + +rec0TyConKey = mkPreludeTyConUnique 149 +d1TyConKey = mkPreludeTyConUnique 151 +c1TyConKey = mkPreludeTyConUnique 152 +s1TyConKey = mkPreludeTyConUnique 153 +noSelTyConKey = mkPreludeTyConUnique 154 + +repTyConKey = mkPreludeTyConUnique 155 +rep1TyConKey = mkPreludeTyConUnique 156 + +uRecTyConKey = mkPreludeTyConUnique 157 +uAddrTyConKey = mkPreludeTyConUnique 158 +uCharTyConKey = mkPreludeTyConUnique 159 +uDoubleTyConKey = mkPreludeTyConUnique 160 +uFloatTyConKey = mkPreludeTyConUnique 161 +uIntTyConKey = mkPreludeTyConUnique 162 +uWordTyConKey = mkPreludeTyConUnique 163 + +-- Type-level naturals +typeNatKindConNameKey, typeSymbolKindConNameKey, + typeNatAddTyFamNameKey, typeNatMulTyFamNameKey, typeNatExpTyFamNameKey, + typeNatLeqTyFamNameKey, typeNatSubTyFamNameKey + , typeSymbolCmpTyFamNameKey, typeNatCmpTyFamNameKey + , typeNatDivTyFamNameKey + , typeNatModTyFamNameKey + , typeNatLogTyFamNameKey + :: Unique +typeNatKindConNameKey = mkPreludeTyConUnique 164 +typeSymbolKindConNameKey = mkPreludeTyConUnique 165 +typeNatAddTyFamNameKey = mkPreludeTyConUnique 166 +typeNatMulTyFamNameKey = mkPreludeTyConUnique 167 +typeNatExpTyFamNameKey = mkPreludeTyConUnique 168 +typeNatLeqTyFamNameKey = mkPreludeTyConUnique 169 +typeNatSubTyFamNameKey = mkPreludeTyConUnique 170 +typeSymbolCmpTyFamNameKey = mkPreludeTyConUnique 171 +typeNatCmpTyFamNameKey = mkPreludeTyConUnique 172 +typeNatDivTyFamNameKey = mkPreludeTyConUnique 173 +typeNatModTyFamNameKey = mkPreludeTyConUnique 174 +typeNatLogTyFamNameKey = mkPreludeTyConUnique 175 + +-- Custom user type-errors +errorMessageTypeErrorFamKey :: Unique +errorMessageTypeErrorFamKey = mkPreludeTyConUnique 176 + + + +ntTyConKey:: Unique +ntTyConKey = mkPreludeTyConUnique 177 +coercibleTyConKey :: Unique +coercibleTyConKey = mkPreludeTyConUnique 178 + +proxyPrimTyConKey :: Unique +proxyPrimTyConKey = mkPreludeTyConUnique 179 + +specTyConKey :: Unique +specTyConKey = mkPreludeTyConUnique 180 + +anyTyConKey :: Unique +anyTyConKey = mkPreludeTyConUnique 181 + +smallArrayPrimTyConKey = mkPreludeTyConUnique 182 +smallMutableArrayPrimTyConKey = mkPreludeTyConUnique 183 + +staticPtrTyConKey :: Unique +staticPtrTyConKey = mkPreludeTyConUnique 184 + +staticPtrInfoTyConKey :: Unique +staticPtrInfoTyConKey = mkPreludeTyConUnique 185 + +callStackTyConKey :: Unique +callStackTyConKey = mkPreludeTyConUnique 186 + +-- Typeables +typeRepTyConKey, someTypeRepTyConKey, someTypeRepDataConKey :: Unique +typeRepTyConKey = mkPreludeTyConUnique 187 +someTypeRepTyConKey = mkPreludeTyConUnique 188 +someTypeRepDataConKey = mkPreludeTyConUnique 189 + + +typeSymbolAppendFamNameKey :: Unique +typeSymbolAppendFamNameKey = mkPreludeTyConUnique 190 + +---------------- Template Haskell ------------------- +-- THNames.hs: USES TyConUniques 200-299 +----------------------------------------------------- + +----------------------- SIMD ------------------------ +-- USES TyConUniques 300-399 +----------------------------------------------------- + +#include "primop-vector-uniques.hs-incl" + +{- +************************************************************************ +* * +\subsubsection[Uniques-prelude-DataCons]{@Uniques@ for wired-in @DataCons@} +* * +************************************************************************ +-} + +charDataConKey, consDataConKey, doubleDataConKey, falseDataConKey, + floatDataConKey, intDataConKey, integerSDataConKey, nilDataConKey, + ratioDataConKey, stableNameDataConKey, trueDataConKey, wordDataConKey, + word8DataConKey, ioDataConKey, integerDataConKey, heqDataConKey, + coercibleDataConKey, eqDataConKey, nothingDataConKey, justDataConKey :: Unique + +charDataConKey = mkPreludeDataConUnique 1 +consDataConKey = mkPreludeDataConUnique 2 +doubleDataConKey = mkPreludeDataConUnique 3 +falseDataConKey = mkPreludeDataConUnique 4 +floatDataConKey = mkPreludeDataConUnique 5 +intDataConKey = mkPreludeDataConUnique 6 +integerSDataConKey = mkPreludeDataConUnique 7 +nothingDataConKey = mkPreludeDataConUnique 8 +justDataConKey = mkPreludeDataConUnique 9 +eqDataConKey = mkPreludeDataConUnique 10 +nilDataConKey = mkPreludeDataConUnique 11 +ratioDataConKey = mkPreludeDataConUnique 12 +word8DataConKey = mkPreludeDataConUnique 13 +stableNameDataConKey = mkPreludeDataConUnique 14 +trueDataConKey = mkPreludeDataConUnique 15 +wordDataConKey = mkPreludeDataConUnique 16 +ioDataConKey = mkPreludeDataConUnique 17 +integerDataConKey = mkPreludeDataConUnique 18 +heqDataConKey = mkPreludeDataConUnique 19 + +-- Generic data constructors +crossDataConKey, inlDataConKey, inrDataConKey, genUnitDataConKey :: Unique +crossDataConKey = mkPreludeDataConUnique 20 +inlDataConKey = mkPreludeDataConUnique 21 +inrDataConKey = mkPreludeDataConUnique 22 +genUnitDataConKey = mkPreludeDataConUnique 23 + +leftDataConKey, rightDataConKey :: Unique +leftDataConKey = mkPreludeDataConUnique 25 +rightDataConKey = mkPreludeDataConUnique 26 + +ordLTDataConKey, ordEQDataConKey, ordGTDataConKey :: Unique +ordLTDataConKey = mkPreludeDataConUnique 27 +ordEQDataConKey = mkPreludeDataConUnique 28 +ordGTDataConKey = mkPreludeDataConUnique 29 + + +coercibleDataConKey = mkPreludeDataConUnique 32 + +staticPtrDataConKey :: Unique +staticPtrDataConKey = mkPreludeDataConUnique 33 + +staticPtrInfoDataConKey :: Unique +staticPtrInfoDataConKey = mkPreludeDataConUnique 34 + +fingerprintDataConKey :: Unique +fingerprintDataConKey = mkPreludeDataConUnique 35 + +srcLocDataConKey :: Unique +srcLocDataConKey = mkPreludeDataConUnique 37 + +trTyConTyConKey, trTyConDataConKey, + trModuleTyConKey, trModuleDataConKey, + trNameTyConKey, trNameSDataConKey, trNameDDataConKey, + trGhcPrimModuleKey, kindRepTyConKey, + typeLitSortTyConKey :: Unique +trTyConTyConKey = mkPreludeDataConUnique 40 +trTyConDataConKey = mkPreludeDataConUnique 41 +trModuleTyConKey = mkPreludeDataConUnique 42 +trModuleDataConKey = mkPreludeDataConUnique 43 +trNameTyConKey = mkPreludeDataConUnique 44 +trNameSDataConKey = mkPreludeDataConUnique 45 +trNameDDataConKey = mkPreludeDataConUnique 46 +trGhcPrimModuleKey = mkPreludeDataConUnique 47 +kindRepTyConKey = mkPreludeDataConUnique 48 +typeLitSortTyConKey = mkPreludeDataConUnique 49 + +typeErrorTextDataConKey, + typeErrorAppendDataConKey, + typeErrorVAppendDataConKey, + typeErrorShowTypeDataConKey + :: Unique +typeErrorTextDataConKey = mkPreludeDataConUnique 50 +typeErrorAppendDataConKey = mkPreludeDataConUnique 51 +typeErrorVAppendDataConKey = mkPreludeDataConUnique 52 +typeErrorShowTypeDataConKey = mkPreludeDataConUnique 53 + +prefixIDataConKey, infixIDataConKey, leftAssociativeDataConKey, + rightAssociativeDataConKey, notAssociativeDataConKey, + sourceUnpackDataConKey, sourceNoUnpackDataConKey, + noSourceUnpackednessDataConKey, sourceLazyDataConKey, + sourceStrictDataConKey, noSourceStrictnessDataConKey, + decidedLazyDataConKey, decidedStrictDataConKey, decidedUnpackDataConKey, + metaDataDataConKey, metaConsDataConKey, metaSelDataConKey :: Unique +prefixIDataConKey = mkPreludeDataConUnique 54 +infixIDataConKey = mkPreludeDataConUnique 55 +leftAssociativeDataConKey = mkPreludeDataConUnique 56 +rightAssociativeDataConKey = mkPreludeDataConUnique 57 +notAssociativeDataConKey = mkPreludeDataConUnique 58 +sourceUnpackDataConKey = mkPreludeDataConUnique 59 +sourceNoUnpackDataConKey = mkPreludeDataConUnique 60 +noSourceUnpackednessDataConKey = mkPreludeDataConUnique 61 +sourceLazyDataConKey = mkPreludeDataConUnique 62 +sourceStrictDataConKey = mkPreludeDataConUnique 63 +noSourceStrictnessDataConKey = mkPreludeDataConUnique 64 +decidedLazyDataConKey = mkPreludeDataConUnique 65 +decidedStrictDataConKey = mkPreludeDataConUnique 66 +decidedUnpackDataConKey = mkPreludeDataConUnique 67 +metaDataDataConKey = mkPreludeDataConUnique 68 +metaConsDataConKey = mkPreludeDataConUnique 69 +metaSelDataConKey = mkPreludeDataConUnique 70 + +vecRepDataConKey, tupleRepDataConKey, sumRepDataConKey :: Unique +vecRepDataConKey = mkPreludeDataConUnique 71 +tupleRepDataConKey = mkPreludeDataConUnique 72 +sumRepDataConKey = mkPreludeDataConUnique 73 + +-- See Note [Wiring in RuntimeRep] in TysWiredIn +runtimeRepSimpleDataConKeys, unliftedSimpleRepDataConKeys, unliftedRepDataConKeys :: [Unique] +liftedRepDataConKey :: Unique +runtimeRepSimpleDataConKeys@(liftedRepDataConKey : unliftedSimpleRepDataConKeys) + = map mkPreludeDataConUnique [74..86] + +unliftedRepDataConKeys = vecRepDataConKey : + tupleRepDataConKey : + sumRepDataConKey : + unliftedSimpleRepDataConKeys + +-- See Note [Wiring in RuntimeRep] in TysWiredIn +-- VecCount +vecCountDataConKeys :: [Unique] +vecCountDataConKeys = map mkPreludeDataConUnique [87..92] + +-- See Note [Wiring in RuntimeRep] in TysWiredIn +-- VecElem +vecElemDataConKeys :: [Unique] +vecElemDataConKeys = map mkPreludeDataConUnique [93..102] + +-- Typeable things +kindRepTyConAppDataConKey, kindRepVarDataConKey, kindRepAppDataConKey, + kindRepFunDataConKey, kindRepTYPEDataConKey, + kindRepTypeLitSDataConKey, kindRepTypeLitDDataConKey + :: Unique +kindRepTyConAppDataConKey = mkPreludeDataConUnique 103 +kindRepVarDataConKey = mkPreludeDataConUnique 104 +kindRepAppDataConKey = mkPreludeDataConUnique 105 +kindRepFunDataConKey = mkPreludeDataConUnique 106 +kindRepTYPEDataConKey = mkPreludeDataConUnique 107 +kindRepTypeLitSDataConKey = mkPreludeDataConUnique 108 +kindRepTypeLitDDataConKey = mkPreludeDataConUnique 109 + +typeLitSymbolDataConKey, typeLitNatDataConKey :: Unique +typeLitSymbolDataConKey = mkPreludeDataConUnique 110 +typeLitNatDataConKey = mkPreludeDataConUnique 111 + + +---------------- Template Haskell ------------------- +-- THNames.hs: USES DataUniques 200-250 +----------------------------------------------------- + + +{- +************************************************************************ +* * +\subsubsection[Uniques-prelude-Ids]{@Uniques@ for wired-in @Ids@ (except @DataCons@)} +* * +************************************************************************ +-} + +wildCardKey, absentErrorIdKey, augmentIdKey, appendIdKey, + buildIdKey, errorIdKey, foldrIdKey, recSelErrorIdKey, + seqIdKey, eqStringIdKey, + noMethodBindingErrorIdKey, nonExhaustiveGuardsErrorIdKey, + runtimeErrorIdKey, patErrorIdKey, voidPrimIdKey, + realWorldPrimIdKey, recConErrorIdKey, + unpackCStringUtf8IdKey, unpackCStringAppendIdKey, + unpackCStringFoldrIdKey, unpackCStringIdKey, + typeErrorIdKey, divIntIdKey, modIntIdKey, + absentSumFieldErrorIdKey :: Unique + +wildCardKey = mkPreludeMiscIdUnique 0 -- See Note [WildCard binders] +absentErrorIdKey = mkPreludeMiscIdUnique 1 +augmentIdKey = mkPreludeMiscIdUnique 2 +appendIdKey = mkPreludeMiscIdUnique 3 +buildIdKey = mkPreludeMiscIdUnique 4 +errorIdKey = mkPreludeMiscIdUnique 5 +foldrIdKey = mkPreludeMiscIdUnique 6 +recSelErrorIdKey = mkPreludeMiscIdUnique 7 +seqIdKey = mkPreludeMiscIdUnique 8 +eqStringIdKey = mkPreludeMiscIdUnique 10 +noMethodBindingErrorIdKey = mkPreludeMiscIdUnique 11 +nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 12 +runtimeErrorIdKey = mkPreludeMiscIdUnique 13 +patErrorIdKey = mkPreludeMiscIdUnique 14 +realWorldPrimIdKey = mkPreludeMiscIdUnique 15 +recConErrorIdKey = mkPreludeMiscIdUnique 16 +unpackCStringUtf8IdKey = mkPreludeMiscIdUnique 17 +unpackCStringAppendIdKey = mkPreludeMiscIdUnique 18 +unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 19 +unpackCStringIdKey = mkPreludeMiscIdUnique 20 +voidPrimIdKey = mkPreludeMiscIdUnique 21 +typeErrorIdKey = mkPreludeMiscIdUnique 22 +divIntIdKey = mkPreludeMiscIdUnique 23 +modIntIdKey = mkPreludeMiscIdUnique 24 +absentSumFieldErrorIdKey = mkPreludeMiscIdUnique 9 + +unsafeCoerceIdKey, concatIdKey, filterIdKey, zipIdKey, bindIOIdKey, + returnIOIdKey, newStablePtrIdKey, + printIdKey, failIOIdKey, nullAddrIdKey, voidArgIdKey, + fstIdKey, sndIdKey, otherwiseIdKey, assertIdKey :: Unique +unsafeCoerceIdKey = mkPreludeMiscIdUnique 30 +concatIdKey = mkPreludeMiscIdUnique 31 +filterIdKey = mkPreludeMiscIdUnique 32 +zipIdKey = mkPreludeMiscIdUnique 33 +bindIOIdKey = mkPreludeMiscIdUnique 34 +returnIOIdKey = mkPreludeMiscIdUnique 35 +newStablePtrIdKey = mkPreludeMiscIdUnique 36 +printIdKey = mkPreludeMiscIdUnique 37 +failIOIdKey = mkPreludeMiscIdUnique 38 +nullAddrIdKey = mkPreludeMiscIdUnique 39 +voidArgIdKey = mkPreludeMiscIdUnique 40 +fstIdKey = mkPreludeMiscIdUnique 41 +sndIdKey = mkPreludeMiscIdUnique 42 +otherwiseIdKey = mkPreludeMiscIdUnique 43 +assertIdKey = mkPreludeMiscIdUnique 44 + +mkIntegerIdKey, smallIntegerIdKey, wordToIntegerIdKey, + integerToWordIdKey, integerToIntIdKey, + integerToWord64IdKey, integerToInt64IdKey, + word64ToIntegerIdKey, int64ToIntegerIdKey, + plusIntegerIdKey, timesIntegerIdKey, minusIntegerIdKey, + negateIntegerIdKey, + eqIntegerPrimIdKey, neqIntegerPrimIdKey, absIntegerIdKey, signumIntegerIdKey, + leIntegerPrimIdKey, gtIntegerPrimIdKey, ltIntegerPrimIdKey, geIntegerPrimIdKey, + compareIntegerIdKey, quotRemIntegerIdKey, divModIntegerIdKey, + quotIntegerIdKey, remIntegerIdKey, divIntegerIdKey, modIntegerIdKey, + floatFromIntegerIdKey, doubleFromIntegerIdKey, + encodeFloatIntegerIdKey, encodeDoubleIntegerIdKey, + decodeDoubleIntegerIdKey, + gcdIntegerIdKey, lcmIntegerIdKey, + andIntegerIdKey, orIntegerIdKey, xorIntegerIdKey, complementIntegerIdKey, + shiftLIntegerIdKey, shiftRIntegerIdKey :: Unique +mkIntegerIdKey = mkPreludeMiscIdUnique 60 +smallIntegerIdKey = mkPreludeMiscIdUnique 61 +integerToWordIdKey = mkPreludeMiscIdUnique 62 +integerToIntIdKey = mkPreludeMiscIdUnique 63 +integerToWord64IdKey = mkPreludeMiscIdUnique 64 +integerToInt64IdKey = mkPreludeMiscIdUnique 65 +plusIntegerIdKey = mkPreludeMiscIdUnique 66 +timesIntegerIdKey = mkPreludeMiscIdUnique 67 +minusIntegerIdKey = mkPreludeMiscIdUnique 68 +negateIntegerIdKey = mkPreludeMiscIdUnique 69 +eqIntegerPrimIdKey = mkPreludeMiscIdUnique 70 +neqIntegerPrimIdKey = mkPreludeMiscIdUnique 71 +absIntegerIdKey = mkPreludeMiscIdUnique 72 +signumIntegerIdKey = mkPreludeMiscIdUnique 73 +leIntegerPrimIdKey = mkPreludeMiscIdUnique 74 +gtIntegerPrimIdKey = mkPreludeMiscIdUnique 75 +ltIntegerPrimIdKey = mkPreludeMiscIdUnique 76 +geIntegerPrimIdKey = mkPreludeMiscIdUnique 77 +compareIntegerIdKey = mkPreludeMiscIdUnique 78 +quotIntegerIdKey = mkPreludeMiscIdUnique 79 +remIntegerIdKey = mkPreludeMiscIdUnique 80 +divIntegerIdKey = mkPreludeMiscIdUnique 81 +modIntegerIdKey = mkPreludeMiscIdUnique 82 +divModIntegerIdKey = mkPreludeMiscIdUnique 83 +quotRemIntegerIdKey = mkPreludeMiscIdUnique 84 +floatFromIntegerIdKey = mkPreludeMiscIdUnique 85 +doubleFromIntegerIdKey = mkPreludeMiscIdUnique 86 +encodeFloatIntegerIdKey = mkPreludeMiscIdUnique 87 +encodeDoubleIntegerIdKey = mkPreludeMiscIdUnique 88 +gcdIntegerIdKey = mkPreludeMiscIdUnique 89 +lcmIntegerIdKey = mkPreludeMiscIdUnique 90 +andIntegerIdKey = mkPreludeMiscIdUnique 91 +orIntegerIdKey = mkPreludeMiscIdUnique 92 +xorIntegerIdKey = mkPreludeMiscIdUnique 93 +complementIntegerIdKey = mkPreludeMiscIdUnique 94 +shiftLIntegerIdKey = mkPreludeMiscIdUnique 95 +shiftRIntegerIdKey = mkPreludeMiscIdUnique 96 +wordToIntegerIdKey = mkPreludeMiscIdUnique 97 +word64ToIntegerIdKey = mkPreludeMiscIdUnique 98 +int64ToIntegerIdKey = mkPreludeMiscIdUnique 99 +decodeDoubleIntegerIdKey = mkPreludeMiscIdUnique 100 + +rootMainKey, runMainKey :: Unique +rootMainKey = mkPreludeMiscIdUnique 101 +runMainKey = mkPreludeMiscIdUnique 102 + +thenIOIdKey, lazyIdKey, assertErrorIdKey, oneShotKey, runRWKey :: Unique +thenIOIdKey = mkPreludeMiscIdUnique 103 +lazyIdKey = mkPreludeMiscIdUnique 104 +assertErrorIdKey = mkPreludeMiscIdUnique 105 +oneShotKey = mkPreludeMiscIdUnique 106 +runRWKey = mkPreludeMiscIdUnique 107 + +traceKey :: Unique +traceKey = mkPreludeMiscIdUnique 108 + +breakpointIdKey, breakpointCondIdKey :: Unique +breakpointIdKey = mkPreludeMiscIdUnique 110 +breakpointCondIdKey = mkPreludeMiscIdUnique 111 + +inlineIdKey, noinlineIdKey :: Unique +inlineIdKey = mkPreludeMiscIdUnique 120 +-- see below + +mapIdKey, groupWithIdKey, dollarIdKey :: Unique +mapIdKey = mkPreludeMiscIdUnique 121 +groupWithIdKey = mkPreludeMiscIdUnique 122 +dollarIdKey = mkPreludeMiscIdUnique 123 + +coercionTokenIdKey :: Unique +coercionTokenIdKey = mkPreludeMiscIdUnique 124 + +noinlineIdKey = mkPreludeMiscIdUnique 125 + +rationalToFloatIdKey, rationalToDoubleIdKey :: Unique +rationalToFloatIdKey = mkPreludeMiscIdUnique 130 +rationalToDoubleIdKey = mkPreludeMiscIdUnique 131 + +-- dotnet interop +unmarshalObjectIdKey, marshalObjectIdKey, marshalStringIdKey, + unmarshalStringIdKey, checkDotnetResNameIdKey :: Unique +unmarshalObjectIdKey = mkPreludeMiscIdUnique 150 +marshalObjectIdKey = mkPreludeMiscIdUnique 151 +marshalStringIdKey = mkPreludeMiscIdUnique 152 +unmarshalStringIdKey = mkPreludeMiscIdUnique 153 +checkDotnetResNameIdKey = mkPreludeMiscIdUnique 154 + +undefinedKey :: Unique +undefinedKey = mkPreludeMiscIdUnique 155 + +magicDictKey :: Unique +magicDictKey = mkPreludeMiscIdUnique 156 + +coerceKey :: Unique +coerceKey = mkPreludeMiscIdUnique 157 + +{- +Certain class operations from Prelude classes. They get their own +uniques so we can look them up easily when we want to conjure them up +during type checking. +-} + +-- Just a placeholder for unbound variables produced by the renamer: +unboundKey :: Unique +unboundKey = mkPreludeMiscIdUnique 158 + +fromIntegerClassOpKey, minusClassOpKey, fromRationalClassOpKey, + enumFromClassOpKey, enumFromThenClassOpKey, enumFromToClassOpKey, + enumFromThenToClassOpKey, eqClassOpKey, geClassOpKey, negateClassOpKey, + bindMClassOpKey, thenMClassOpKey, returnMClassOpKey, fmapClassOpKey + :: Unique +fromIntegerClassOpKey = mkPreludeMiscIdUnique 160 +minusClassOpKey = mkPreludeMiscIdUnique 161 +fromRationalClassOpKey = mkPreludeMiscIdUnique 162 +enumFromClassOpKey = mkPreludeMiscIdUnique 163 +enumFromThenClassOpKey = mkPreludeMiscIdUnique 164 +enumFromToClassOpKey = mkPreludeMiscIdUnique 165 +enumFromThenToClassOpKey = mkPreludeMiscIdUnique 166 +eqClassOpKey = mkPreludeMiscIdUnique 167 +geClassOpKey = mkPreludeMiscIdUnique 168 +negateClassOpKey = mkPreludeMiscIdUnique 169 +bindMClassOpKey = mkPreludeMiscIdUnique 171 -- (>>=) +thenMClassOpKey = mkPreludeMiscIdUnique 172 -- (>>) +fmapClassOpKey = mkPreludeMiscIdUnique 173 +returnMClassOpKey = mkPreludeMiscIdUnique 174 + +-- Recursive do notation +mfixIdKey :: Unique +mfixIdKey = mkPreludeMiscIdUnique 175 + +-- MonadFail operations +failMClassOpKey :: Unique +failMClassOpKey = mkPreludeMiscIdUnique 176 + +-- Arrow notation +arrAIdKey, composeAIdKey, firstAIdKey, appAIdKey, choiceAIdKey, + loopAIdKey :: Unique +arrAIdKey = mkPreludeMiscIdUnique 180 +composeAIdKey = mkPreludeMiscIdUnique 181 -- >>> +firstAIdKey = mkPreludeMiscIdUnique 182 +appAIdKey = mkPreludeMiscIdUnique 183 +choiceAIdKey = mkPreludeMiscIdUnique 184 -- ||| +loopAIdKey = mkPreludeMiscIdUnique 185 + +fromStringClassOpKey :: Unique +fromStringClassOpKey = mkPreludeMiscIdUnique 186 + +-- Annotation type checking +toAnnotationWrapperIdKey :: Unique +toAnnotationWrapperIdKey = mkPreludeMiscIdUnique 187 + +-- Conversion functions +fromIntegralIdKey, realToFracIdKey, toIntegerClassOpKey, toRationalClassOpKey :: Unique +fromIntegralIdKey = mkPreludeMiscIdUnique 190 +realToFracIdKey = mkPreludeMiscIdUnique 191 +toIntegerClassOpKey = mkPreludeMiscIdUnique 192 +toRationalClassOpKey = mkPreludeMiscIdUnique 193 + +-- Monad comprehensions +guardMIdKey, liftMIdKey, mzipIdKey :: Unique +guardMIdKey = mkPreludeMiscIdUnique 194 +liftMIdKey = mkPreludeMiscIdUnique 195 +mzipIdKey = mkPreludeMiscIdUnique 196 + +-- GHCi +ghciStepIoMClassOpKey :: Unique +ghciStepIoMClassOpKey = mkPreludeMiscIdUnique 197 + +-- Overloaded lists +isListClassKey, fromListClassOpKey, fromListNClassOpKey, toListClassOpKey :: Unique +isListClassKey = mkPreludeMiscIdUnique 198 +fromListClassOpKey = mkPreludeMiscIdUnique 199 +fromListNClassOpKey = mkPreludeMiscIdUnique 500 +toListClassOpKey = mkPreludeMiscIdUnique 501 + +proxyHashKey :: Unique +proxyHashKey = mkPreludeMiscIdUnique 502 + +---------------- Template Haskell ------------------- +-- THNames.hs: USES IdUniques 200-499 +----------------------------------------------------- + +-- Used to make `Typeable` dictionaries +mkTyConKey + , mkTrTypeKey + , mkTrConKey + , mkTrAppKey + , mkTrFunKey + , typeNatTypeRepKey + , typeSymbolTypeRepKey + , typeRepIdKey + :: Unique +mkTyConKey = mkPreludeMiscIdUnique 503 +mkTrTypeKey = mkPreludeMiscIdUnique 504 +mkTrConKey = mkPreludeMiscIdUnique 505 +mkTrAppKey = mkPreludeMiscIdUnique 506 +typeNatTypeRepKey = mkPreludeMiscIdUnique 507 +typeSymbolTypeRepKey = mkPreludeMiscIdUnique 508 +typeRepIdKey = mkPreludeMiscIdUnique 509 +mkTrFunKey = mkPreludeMiscIdUnique 510 + +-- Representations for primitive types +trTYPEKey + ,trTYPE'PtrRepLiftedKey + , trRuntimeRepKey + , tr'PtrRepLiftedKey + :: Unique +trTYPEKey = mkPreludeMiscIdUnique 511 +trTYPE'PtrRepLiftedKey = mkPreludeMiscIdUnique 512 +trRuntimeRepKey = mkPreludeMiscIdUnique 513 +tr'PtrRepLiftedKey = mkPreludeMiscIdUnique 514 + +-- KindReps for common cases +starKindRepKey, starArrStarKindRepKey, starArrStarArrStarKindRepKey :: Unique +starKindRepKey = mkPreludeMiscIdUnique 520 +starArrStarKindRepKey = mkPreludeMiscIdUnique 521 +starArrStarArrStarKindRepKey = mkPreludeMiscIdUnique 522 + +-- Dynamic +toDynIdKey :: Unique +toDynIdKey = mkPreludeMiscIdUnique 523 + + +bitIntegerIdKey :: Unique +bitIntegerIdKey = mkPreludeMiscIdUnique 550 + +heqSCSelIdKey, eqSCSelIdKey, coercibleSCSelIdKey :: Unique +eqSCSelIdKey = mkPreludeMiscIdUnique 551 +heqSCSelIdKey = mkPreludeMiscIdUnique 552 +coercibleSCSelIdKey = mkPreludeMiscIdUnique 553 + +sappendClassOpKey :: Unique +sappendClassOpKey = mkPreludeMiscIdUnique 554 + +memptyClassOpKey, mappendClassOpKey, mconcatClassOpKey :: Unique +memptyClassOpKey = mkPreludeMiscIdUnique 555 +mappendClassOpKey = mkPreludeMiscIdUnique 556 +mconcatClassOpKey = mkPreludeMiscIdUnique 557 + +emptyCallStackKey, pushCallStackKey :: Unique +emptyCallStackKey = mkPreludeMiscIdUnique 558 +pushCallStackKey = mkPreludeMiscIdUnique 559 + +fromStaticPtrClassOpKey :: Unique +fromStaticPtrClassOpKey = mkPreludeMiscIdUnique 560 + +makeStaticKey :: Unique +makeStaticKey = mkPreludeMiscIdUnique 561 + +-- Natural +naturalFromIntegerIdKey, naturalToIntegerIdKey, plusNaturalIdKey, + minusNaturalIdKey, timesNaturalIdKey, mkNaturalIdKey, + naturalSDataConKey, wordToNaturalIdKey :: Unique +naturalFromIntegerIdKey = mkPreludeMiscIdUnique 562 +naturalToIntegerIdKey = mkPreludeMiscIdUnique 563 +plusNaturalIdKey = mkPreludeMiscIdUnique 564 +minusNaturalIdKey = mkPreludeMiscIdUnique 565 +timesNaturalIdKey = mkPreludeMiscIdUnique 566 +mkNaturalIdKey = mkPreludeMiscIdUnique 567 +naturalSDataConKey = mkPreludeMiscIdUnique 568 +wordToNaturalIdKey = mkPreludeMiscIdUnique 569 + +{- +************************************************************************ +* * +\subsection[Class-std-groups]{Standard groups of Prelude classes} +* * +************************************************************************ + +NOTE: @Eq@ and @Text@ do need to appear in @standardClasses@ +even though every numeric class has these two as a superclass, +because the list of ambiguous dictionaries hasn't been simplified. +-} + +numericClassKeys :: [Unique] +numericClassKeys = + [ numClassKey + , realClassKey + , integralClassKey + ] + ++ fractionalClassKeys + +fractionalClassKeys :: [Unique] +fractionalClassKeys = + [ fractionalClassKey + , floatingClassKey + , realFracClassKey + , realFloatClassKey + ] + +-- The "standard classes" are used in defaulting (Haskell 98 report 4.3.4), +-- and are: "classes defined in the Prelude or a standard library" +standardClassKeys :: [Unique] +standardClassKeys = derivableClassKeys ++ numericClassKeys + ++ [randomClassKey, randomGenClassKey, + functorClassKey, + monadClassKey, monadPlusClassKey, monadFailClassKey, + semigroupClassKey, monoidClassKey, + isStringClassKey, + applicativeClassKey, foldableClassKey, + traversableClassKey, alternativeClassKey + ] + +{- +@derivableClassKeys@ is also used in checking \tr{deriving} constructs +(@TcDeriv@). +-} + +derivableClassKeys :: [Unique] +derivableClassKeys + = [ eqClassKey, ordClassKey, enumClassKey, ixClassKey, + boundedClassKey, showClassKey, readClassKey ] + + +-- These are the "interactive classes" that are consulted when doing +-- defaulting. Does not include Num or IsString, which have special +-- handling. +interactiveClassNames :: [Name] +interactiveClassNames + = [ showClassName, eqClassName, ordClassName, foldableClassName + , traversableClassName ] + +interactiveClassKeys :: [Unique] +interactiveClassKeys = map getUnique interactiveClassNames + +{- +************************************************************************ +* * + Semi-builtin names +* * +************************************************************************ + +The following names should be considered by GHCi to be in scope always. + +-} + +pretendNameIsInScope :: Name -> Bool +pretendNameIsInScope n + = any (n `hasKey`) + [ liftedTypeKindTyConKey, tYPETyConKey + , runtimeRepTyConKey, liftedRepDataConKey ] diff --git a/compiler/prelude/PrelNames.hs-boot b/compiler/prelude/PrelNames.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/prelude/PrelNames.hs-boot @@ -0,0 +1,7 @@ +module PrelNames where + +import Module +import Unique + +mAIN :: Module +liftedTypeKindTyConKey :: Unique diff --git a/compiler/prelude/PrelRules.hs b/compiler/prelude/PrelRules.hs new file mode 100644 --- /dev/null +++ b/compiler/prelude/PrelRules.hs @@ -0,0 +1,2172 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[ConFold]{Constant Folder} + +Conceptually, constant folding should be parameterized with the kind +of target machine to get identical behaviour during compilation time +and runtime. We cheat a little bit here... + +ToDo: + check boundaries before folding, e.g. we can fold the Float addition + (i1 + i2) only if it results in a valid Float. +-} + +{-# LANGUAGE CPP, RankNTypes, PatternSynonyms, ViewPatterns, RecordWildCards #-} +{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} + +module PrelRules + ( primOpRules + , builtinRules + , caseRules + ) +where + +#include "HsVersions.h" +#include "../includes/MachDeps.h" + +import GhcPrelude + +import {-# SOURCE #-} MkId ( mkPrimOpId, magicDictId ) + +import CoreSyn +import MkCore +import Id +import Literal +import CoreOpt ( exprIsLiteral_maybe ) +import PrimOp ( PrimOp(..), tagToEnumKey ) +import TysWiredIn +import TysPrim +import TyCon ( tyConDataCons_maybe, isAlgTyCon, isEnumerationTyCon + , isNewTyCon, unwrapNewTyCon_maybe, tyConDataCons + , tyConFamilySize ) +import DataCon ( dataConTagZ, dataConTyCon, dataConWorkId ) +import CoreUtils ( cheapEqExpr, exprIsHNF, exprType ) +import CoreUnfold ( exprIsConApp_maybe ) +import Type +import OccName ( occNameFS ) +import PrelNames +import Maybes ( orElse ) +import Name ( Name, nameOccName ) +import Outputable +import FastString +import BasicTypes +import DynFlags +import Platform +import Util +import Coercion (mkUnbranchedAxInstCo,mkSymCo,Role(..)) + +import Control.Applicative ( Alternative(..) ) + +import Control.Monad +import qualified Control.Monad.Fail as MonadFail +import Data.Bits as Bits +import qualified Data.ByteString as BS +import Data.Int +import Data.Ratio +import Data.Word + +{- +Note [Constant folding] +~~~~~~~~~~~~~~~~~~~~~~~ +primOpRules generates a rewrite rule for each primop +These rules do what is often called "constant folding" +E.g. the rules for +# might say + 4 +# 5 = 9 +Well, of course you'd need a lot of rules if you did it +like that, so we use a BuiltinRule instead, so that we +can match in any two literal values. So the rule is really +more like + (Lit x) +# (Lit y) = Lit (x+#y) +where the (+#) on the rhs is done at compile time + +That is why these rules are built in here. +-} + +primOpRules :: Name -> PrimOp -> Maybe CoreRule + -- ToDo: something for integer-shift ops? + -- NotOp +primOpRules nm TagToEnumOp = mkPrimOpRule nm 2 [ tagToEnumRule ] +primOpRules nm DataToTagOp = mkPrimOpRule nm 2 [ dataToTagRule ] + +-- Int operations +primOpRules nm IntAddOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (+)) + , identityDynFlags zeroi + , numFoldingRules IntAddOp intPrimOps + ] +primOpRules nm IntSubOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (-)) + , rightIdentityDynFlags zeroi + , equalArgs >> retLit zeroi + , numFoldingRules IntSubOp intPrimOps + ] +primOpRules nm IntAddCOp = mkPrimOpRule nm 2 [ binaryLit (intOpC2 (+)) + , identityCDynFlags zeroi ] +primOpRules nm IntSubCOp = mkPrimOpRule nm 2 [ binaryLit (intOpC2 (-)) + , rightIdentityCDynFlags zeroi + , equalArgs >> retLitNoC zeroi ] +primOpRules nm IntMulOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (*)) + , zeroElem zeroi + , identityDynFlags onei + , numFoldingRules IntMulOp intPrimOps + ] +primOpRules nm IntQuotOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 quot) + , leftZero zeroi + , rightIdentityDynFlags onei + , equalArgs >> retLit onei ] +primOpRules nm IntRemOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 rem) + , leftZero zeroi + , do l <- getLiteral 1 + dflags <- getDynFlags + guard (l == onei dflags) + retLit zeroi + , equalArgs >> retLit zeroi + , equalArgs >> retLit zeroi ] +primOpRules nm AndIOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (.&.)) + , idempotent + , zeroElem zeroi ] +primOpRules nm OrIOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 (.|.)) + , idempotent + , identityDynFlags zeroi ] +primOpRules nm XorIOp = mkPrimOpRule nm 2 [ binaryLit (intOp2 xor) + , identityDynFlags zeroi + , equalArgs >> retLit zeroi ] +primOpRules nm NotIOp = mkPrimOpRule nm 1 [ unaryLit complementOp + , inversePrimOp NotIOp ] +primOpRules nm IntNegOp = mkPrimOpRule nm 1 [ unaryLit negOp + , inversePrimOp IntNegOp ] +primOpRules nm ISllOp = mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftL) + , rightIdentityDynFlags zeroi ] +primOpRules nm ISraOp = mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftR) + , rightIdentityDynFlags zeroi ] +primOpRules nm ISrlOp = mkPrimOpRule nm 2 [ shiftRule shiftRightLogical + , rightIdentityDynFlags zeroi ] + +-- Word operations +primOpRules nm WordAddOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (+)) + , identityDynFlags zerow + , numFoldingRules WordAddOp wordPrimOps + ] +primOpRules nm WordSubOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (-)) + , rightIdentityDynFlags zerow + , equalArgs >> retLit zerow + , numFoldingRules WordSubOp wordPrimOps + ] +primOpRules nm WordAddCOp = mkPrimOpRule nm 2 [ binaryLit (wordOpC2 (+)) + , identityCDynFlags zerow ] +primOpRules nm WordSubCOp = mkPrimOpRule nm 2 [ binaryLit (wordOpC2 (-)) + , rightIdentityCDynFlags zerow + , equalArgs >> retLitNoC zerow ] +primOpRules nm WordMulOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (*)) + , identityDynFlags onew + , numFoldingRules WordMulOp wordPrimOps + ] +primOpRules nm WordQuotOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 quot) + , rightIdentityDynFlags onew ] +primOpRules nm WordRemOp = mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 rem) + , leftZero zerow + , do l <- getLiteral 1 + dflags <- getDynFlags + guard (l == onew dflags) + retLit zerow + , equalArgs >> retLit zerow ] +primOpRules nm AndOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.&.)) + , idempotent + , zeroElem zerow ] +primOpRules nm OrOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.|.)) + , idempotent + , identityDynFlags zerow ] +primOpRules nm XorOp = mkPrimOpRule nm 2 [ binaryLit (wordOp2 xor) + , identityDynFlags zerow + , equalArgs >> retLit zerow ] +primOpRules nm NotOp = mkPrimOpRule nm 1 [ unaryLit complementOp + , inversePrimOp NotOp ] +primOpRules nm SllOp = mkPrimOpRule nm 2 [ shiftRule (const Bits.shiftL) ] +primOpRules nm SrlOp = mkPrimOpRule nm 2 [ shiftRule shiftRightLogical ] + +-- coercions +primOpRules nm Word2IntOp = mkPrimOpRule nm 1 [ liftLitDynFlags word2IntLit + , inversePrimOp Int2WordOp ] +primOpRules nm Int2WordOp = mkPrimOpRule nm 1 [ liftLitDynFlags int2WordLit + , inversePrimOp Word2IntOp ] +primOpRules nm Narrow8IntOp = mkPrimOpRule nm 1 [ liftLit narrow8IntLit + , subsumedByPrimOp Narrow8IntOp + , Narrow8IntOp `subsumesPrimOp` Narrow16IntOp + , Narrow8IntOp `subsumesPrimOp` Narrow32IntOp ] +primOpRules nm Narrow16IntOp = mkPrimOpRule nm 1 [ liftLit narrow16IntLit + , subsumedByPrimOp Narrow8IntOp + , subsumedByPrimOp Narrow16IntOp + , Narrow16IntOp `subsumesPrimOp` Narrow32IntOp ] +primOpRules nm Narrow32IntOp = mkPrimOpRule nm 1 [ liftLit narrow32IntLit + , subsumedByPrimOp Narrow8IntOp + , subsumedByPrimOp Narrow16IntOp + , subsumedByPrimOp Narrow32IntOp + , removeOp32 ] +primOpRules nm Narrow8WordOp = mkPrimOpRule nm 1 [ liftLit narrow8WordLit + , subsumedByPrimOp Narrow8WordOp + , Narrow8WordOp `subsumesPrimOp` Narrow16WordOp + , Narrow8WordOp `subsumesPrimOp` Narrow32WordOp ] +primOpRules nm Narrow16WordOp = mkPrimOpRule nm 1 [ liftLit narrow16WordLit + , subsumedByPrimOp Narrow8WordOp + , subsumedByPrimOp Narrow16WordOp + , Narrow16WordOp `subsumesPrimOp` Narrow32WordOp ] +primOpRules nm Narrow32WordOp = mkPrimOpRule nm 1 [ liftLit narrow32WordLit + , subsumedByPrimOp Narrow8WordOp + , subsumedByPrimOp Narrow16WordOp + , subsumedByPrimOp Narrow32WordOp + , removeOp32 ] +primOpRules nm OrdOp = mkPrimOpRule nm 1 [ liftLit char2IntLit + , inversePrimOp ChrOp ] +primOpRules nm ChrOp = mkPrimOpRule nm 1 [ do [Lit lit] <- getArgs + guard (litFitsInChar lit) + liftLit int2CharLit + , inversePrimOp OrdOp ] +primOpRules nm Float2IntOp = mkPrimOpRule nm 1 [ liftLit float2IntLit ] +primOpRules nm Int2FloatOp = mkPrimOpRule nm 1 [ liftLit int2FloatLit ] +primOpRules nm Double2IntOp = mkPrimOpRule nm 1 [ liftLit double2IntLit ] +primOpRules nm Int2DoubleOp = mkPrimOpRule nm 1 [ liftLit int2DoubleLit ] +-- SUP: Not sure what the standard says about precision in the following 2 cases +primOpRules nm Float2DoubleOp = mkPrimOpRule nm 1 [ liftLit float2DoubleLit ] +primOpRules nm Double2FloatOp = mkPrimOpRule nm 1 [ liftLit double2FloatLit ] + +-- Float +primOpRules nm FloatAddOp = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (+)) + , identity zerof ] +primOpRules nm FloatSubOp = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (-)) + , rightIdentity zerof ] +primOpRules nm FloatMulOp = mkPrimOpRule nm 2 [ binaryLit (floatOp2 (*)) + , identity onef + , strengthReduction twof FloatAddOp ] + -- zeroElem zerof doesn't hold because of NaN +primOpRules nm FloatDivOp = mkPrimOpRule nm 2 [ guardFloatDiv >> binaryLit (floatOp2 (/)) + , rightIdentity onef ] +primOpRules nm FloatNegOp = mkPrimOpRule nm 1 [ unaryLit negOp + , inversePrimOp FloatNegOp ] + +-- Double +primOpRules nm DoubleAddOp = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (+)) + , identity zerod ] +primOpRules nm DoubleSubOp = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (-)) + , rightIdentity zerod ] +primOpRules nm DoubleMulOp = mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (*)) + , identity oned + , strengthReduction twod DoubleAddOp ] + -- zeroElem zerod doesn't hold because of NaN +primOpRules nm DoubleDivOp = mkPrimOpRule nm 2 [ guardDoubleDiv >> binaryLit (doubleOp2 (/)) + , rightIdentity oned ] +primOpRules nm DoubleNegOp = mkPrimOpRule nm 1 [ unaryLit negOp + , inversePrimOp DoubleNegOp ] + +-- Relational operators + +primOpRules nm IntEqOp = mkRelOpRule nm (==) [ litEq True ] +primOpRules nm IntNeOp = mkRelOpRule nm (/=) [ litEq False ] +primOpRules nm CharEqOp = mkRelOpRule nm (==) [ litEq True ] +primOpRules nm CharNeOp = mkRelOpRule nm (/=) [ litEq False ] + +primOpRules nm IntGtOp = mkRelOpRule nm (>) [ boundsCmp Gt ] +primOpRules nm IntGeOp = mkRelOpRule nm (>=) [ boundsCmp Ge ] +primOpRules nm IntLeOp = mkRelOpRule nm (<=) [ boundsCmp Le ] +primOpRules nm IntLtOp = mkRelOpRule nm (<) [ boundsCmp Lt ] + +primOpRules nm CharGtOp = mkRelOpRule nm (>) [ boundsCmp Gt ] +primOpRules nm CharGeOp = mkRelOpRule nm (>=) [ boundsCmp Ge ] +primOpRules nm CharLeOp = mkRelOpRule nm (<=) [ boundsCmp Le ] +primOpRules nm CharLtOp = mkRelOpRule nm (<) [ boundsCmp Lt ] + +primOpRules nm FloatGtOp = mkFloatingRelOpRule nm (>) +primOpRules nm FloatGeOp = mkFloatingRelOpRule nm (>=) +primOpRules nm FloatLeOp = mkFloatingRelOpRule nm (<=) +primOpRules nm FloatLtOp = mkFloatingRelOpRule nm (<) +primOpRules nm FloatEqOp = mkFloatingRelOpRule nm (==) +primOpRules nm FloatNeOp = mkFloatingRelOpRule nm (/=) + +primOpRules nm DoubleGtOp = mkFloatingRelOpRule nm (>) +primOpRules nm DoubleGeOp = mkFloatingRelOpRule nm (>=) +primOpRules nm DoubleLeOp = mkFloatingRelOpRule nm (<=) +primOpRules nm DoubleLtOp = mkFloatingRelOpRule nm (<) +primOpRules nm DoubleEqOp = mkFloatingRelOpRule nm (==) +primOpRules nm DoubleNeOp = mkFloatingRelOpRule nm (/=) + +primOpRules nm WordGtOp = mkRelOpRule nm (>) [ boundsCmp Gt ] +primOpRules nm WordGeOp = mkRelOpRule nm (>=) [ boundsCmp Ge ] +primOpRules nm WordLeOp = mkRelOpRule nm (<=) [ boundsCmp Le ] +primOpRules nm WordLtOp = mkRelOpRule nm (<) [ boundsCmp Lt ] +primOpRules nm WordEqOp = mkRelOpRule nm (==) [ litEq True ] +primOpRules nm WordNeOp = mkRelOpRule nm (/=) [ litEq False ] + +primOpRules nm AddrAddOp = mkPrimOpRule nm 2 [ rightIdentityDynFlags zeroi ] + +primOpRules nm SeqOp = mkPrimOpRule nm 4 [ seqRule ] +primOpRules nm SparkOp = mkPrimOpRule nm 4 [ sparkRule ] + +primOpRules _ _ = Nothing + +{- +************************************************************************ +* * +\subsection{Doing the business} +* * +************************************************************************ +-} + +-- useful shorthands +mkPrimOpRule :: Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule +mkPrimOpRule nm arity rules = Just $ mkBasicRule nm arity (msum rules) + +mkRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool) + -> [RuleM CoreExpr] -> Maybe CoreRule +mkRelOpRule nm cmp extra + = mkPrimOpRule nm 2 $ + binaryCmpLit cmp : equal_rule : extra + where + -- x `cmp` x does not depend on x, so + -- compute it for the arbitrary value 'True' + -- and use that result + equal_rule = do { equalArgs + ; dflags <- getDynFlags + ; return (if cmp True True + then trueValInt dflags + else falseValInt dflags) } + +{- Note [Rules for floating-point comparisons] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need different rules for floating-point values because for floats +it is not true that x = x (for NaNs); so we do not want the equal_rule +rule that mkRelOpRule uses. + +Note also that, in the case of equality/inequality, we do /not/ +want to switch to a case-expression. For example, we do not want +to convert + case (eqFloat# x 3.8#) of + True -> this + False -> that +to + case x of + 3.8#::Float# -> this + _ -> that +See #9238. Reason: comparing floating-point values for equality +delicate, and we don't want to implement that delicacy in the code for +case expressions. So we make it an invariant of Core that a case +expression never scrutinises a Float# or Double#. + +This transformation is what the litEq rule does; +see Note [The litEq rule: converting equality to case]. +So we /refrain/ from using litEq for mkFloatingRelOpRule. +-} + +mkFloatingRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool) + -> Maybe CoreRule +-- See Note [Rules for floating-point comparisons] +mkFloatingRelOpRule nm cmp + = mkPrimOpRule nm 2 [binaryCmpLit cmp] + +-- common constants +zeroi, onei, zerow, onew :: DynFlags -> Literal +zeroi dflags = mkLitInt dflags 0 +onei dflags = mkLitInt dflags 1 +zerow dflags = mkLitWord dflags 0 +onew dflags = mkLitWord dflags 1 + +zerof, onef, twof, zerod, oned, twod :: Literal +zerof = mkLitFloat 0.0 +onef = mkLitFloat 1.0 +twof = mkLitFloat 2.0 +zerod = mkLitDouble 0.0 +oned = mkLitDouble 1.0 +twod = mkLitDouble 2.0 + +cmpOp :: DynFlags -> (forall a . Ord a => a -> a -> Bool) + -> Literal -> Literal -> Maybe CoreExpr +cmpOp dflags cmp = go + where + done True = Just $ trueValInt dflags + done False = Just $ falseValInt dflags + + -- These compares are at different types + go (LitChar i1) (LitChar i2) = done (i1 `cmp` i2) + go (LitFloat i1) (LitFloat i2) = done (i1 `cmp` i2) + go (LitDouble i1) (LitDouble i2) = done (i1 `cmp` i2) + go (LitNumber nt1 i1 _) (LitNumber nt2 i2 _) + | nt1 /= nt2 = Nothing + | otherwise = done (i1 `cmp` i2) + go _ _ = Nothing + +-------------------------- + +negOp :: DynFlags -> Literal -> Maybe CoreExpr -- Negate +negOp _ (LitFloat 0.0) = Nothing -- can't represent -0.0 as a Rational +negOp dflags (LitFloat f) = Just (mkFloatVal dflags (-f)) +negOp _ (LitDouble 0.0) = Nothing +negOp dflags (LitDouble d) = Just (mkDoubleVal dflags (-d)) +negOp dflags (LitNumber nt i t) + | litNumIsSigned nt = Just (Lit (mkLitNumberWrap dflags nt (-i) t)) +negOp _ _ = Nothing + +complementOp :: DynFlags -> Literal -> Maybe CoreExpr -- Binary complement +complementOp dflags (LitNumber nt i t) = + Just (Lit (mkLitNumberWrap dflags nt (complement i) t)) +complementOp _ _ = Nothing + +-------------------------- +intOp2 :: (Integral a, Integral b) + => (a -> b -> Integer) + -> DynFlags -> Literal -> Literal -> Maybe CoreExpr +intOp2 = intOp2' . const + +intOp2' :: (Integral a, Integral b) + => (DynFlags -> a -> b -> Integer) + -> DynFlags -> Literal -> Literal -> Maybe CoreExpr +intOp2' op dflags (LitNumber LitNumInt i1 _) (LitNumber LitNumInt i2 _) = + let o = op dflags + in intResult dflags (fromInteger i1 `o` fromInteger i2) +intOp2' _ _ _ _ = Nothing -- Could find LitLit + +intOpC2 :: (Integral a, Integral b) + => (a -> b -> Integer) + -> DynFlags -> Literal -> Literal -> Maybe CoreExpr +intOpC2 op dflags (LitNumber LitNumInt i1 _) (LitNumber LitNumInt i2 _) = do + intCResult dflags (fromInteger i1 `op` fromInteger i2) +intOpC2 _ _ _ _ = Nothing -- Could find LitLit + +shiftRightLogical :: DynFlags -> Integer -> Int -> Integer +-- Shift right, putting zeros in rather than sign-propagating as Bits.shiftR would do +-- Do this by converting to Word and back. Obviously this won't work for big +-- values, but its ok as we use it here +shiftRightLogical dflags x n + | wordSizeInBits dflags == 32 = fromIntegral (fromInteger x `shiftR` n :: Word32) + | wordSizeInBits dflags == 64 = fromIntegral (fromInteger x `shiftR` n :: Word64) + | otherwise = panic "shiftRightLogical: unsupported word size" + +-------------------------- +retLit :: (DynFlags -> Literal) -> RuleM CoreExpr +retLit l = do dflags <- getDynFlags + return $ Lit $ l dflags + +retLitNoC :: (DynFlags -> Literal) -> RuleM CoreExpr +retLitNoC l = do dflags <- getDynFlags + let lit = l dflags + let ty = literalType lit + return $ mkCoreUbxTup [ty, ty] [Lit lit, Lit (zeroi dflags)] + +wordOp2 :: (Integral a, Integral b) + => (a -> b -> Integer) + -> DynFlags -> Literal -> Literal -> Maybe CoreExpr +wordOp2 op dflags (LitNumber LitNumWord w1 _) (LitNumber LitNumWord w2 _) + = wordResult dflags (fromInteger w1 `op` fromInteger w2) +wordOp2 _ _ _ _ = Nothing -- Could find LitLit + +wordOpC2 :: (Integral a, Integral b) + => (a -> b -> Integer) + -> DynFlags -> Literal -> Literal -> Maybe CoreExpr +wordOpC2 op dflags (LitNumber LitNumWord w1 _) (LitNumber LitNumWord w2 _) = + wordCResult dflags (fromInteger w1 `op` fromInteger w2) +wordOpC2 _ _ _ _ = Nothing -- Could find LitLit + +shiftRule :: (DynFlags -> Integer -> Int -> Integer) -> RuleM CoreExpr +-- Shifts take an Int; hence third arg of op is Int +-- Used for shift primops +-- ISllOp, ISraOp, ISrlOp :: Word# -> Int# -> Word# +-- SllOp, SrlOp :: Word# -> Int# -> Word# +-- See Note [Guarding against silly shifts] +shiftRule shift_op + = do { dflags <- getDynFlags + ; [e1, Lit (LitNumber LitNumInt shift_len _)] <- getArgs + ; case e1 of + _ | shift_len == 0 + -> return e1 + + -- Do the shift at type Integer, but shift length is Int + Lit (LitNumber nt x t) + | 0 < shift_len + , shift_len <= wordSizeInBits dflags + -> let op = shift_op dflags + y = x `op` fromInteger shift_len + in liftMaybe $ Just (Lit (mkLitNumberWrap dflags nt y t)) + + _ -> mzero } + +wordSizeInBits :: DynFlags -> Integer +wordSizeInBits dflags = toInteger (platformWordSize (targetPlatform dflags) `shiftL` 3) + +-------------------------- +floatOp2 :: (Rational -> Rational -> Rational) + -> DynFlags -> Literal -> Literal + -> Maybe (Expr CoreBndr) +floatOp2 op dflags (LitFloat f1) (LitFloat f2) + = Just (mkFloatVal dflags (f1 `op` f2)) +floatOp2 _ _ _ _ = Nothing + +-------------------------- +doubleOp2 :: (Rational -> Rational -> Rational) + -> DynFlags -> Literal -> Literal + -> Maybe (Expr CoreBndr) +doubleOp2 op dflags (LitDouble f1) (LitDouble f2) + = Just (mkDoubleVal dflags (f1 `op` f2)) +doubleOp2 _ _ _ _ = Nothing + +-------------------------- +{- Note [The litEq rule: converting equality to case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This stuff turns + n ==# 3# +into + case n of + 3# -> True + m -> False + +This is a Good Thing, because it allows case-of case things +to happen, and case-default absorption to happen. For +example: + + if (n ==# 3#) || (n ==# 4#) then e1 else e2 +will transform to + case n of + 3# -> e1 + 4# -> e1 + m -> e2 +(modulo the usual precautions to avoid duplicating e1) +-} + +litEq :: Bool -- True <=> equality, False <=> inequality + -> RuleM CoreExpr +litEq is_eq = msum + [ do [Lit lit, expr] <- getArgs + dflags <- getDynFlags + do_lit_eq dflags lit expr + , do [expr, Lit lit] <- getArgs + dflags <- getDynFlags + do_lit_eq dflags lit expr ] + where + do_lit_eq dflags lit expr = do + guard (not (litIsLifted lit)) + return (mkWildCase expr (literalType lit) intPrimTy + [(DEFAULT, [], val_if_neq), + (LitAlt lit, [], val_if_eq)]) + where + val_if_eq | is_eq = trueValInt dflags + | otherwise = falseValInt dflags + val_if_neq | is_eq = falseValInt dflags + | otherwise = trueValInt dflags + + +-- | Check if there is comparison with minBound or maxBound, that is +-- always true or false. For instance, an Int cannot be smaller than its +-- minBound, so we can replace such comparison with False. +boundsCmp :: Comparison -> RuleM CoreExpr +boundsCmp op = do + dflags <- getDynFlags + [a, b] <- getArgs + liftMaybe $ mkRuleFn dflags op a b + +data Comparison = Gt | Ge | Lt | Le + +mkRuleFn :: DynFlags -> Comparison -> CoreExpr -> CoreExpr -> Maybe CoreExpr +mkRuleFn dflags Gt (Lit lit) _ | isMinBound dflags lit = Just $ falseValInt dflags +mkRuleFn dflags Le (Lit lit) _ | isMinBound dflags lit = Just $ trueValInt dflags +mkRuleFn dflags Ge _ (Lit lit) | isMinBound dflags lit = Just $ trueValInt dflags +mkRuleFn dflags Lt _ (Lit lit) | isMinBound dflags lit = Just $ falseValInt dflags +mkRuleFn dflags Ge (Lit lit) _ | isMaxBound dflags lit = Just $ trueValInt dflags +mkRuleFn dflags Lt (Lit lit) _ | isMaxBound dflags lit = Just $ falseValInt dflags +mkRuleFn dflags Gt _ (Lit lit) | isMaxBound dflags lit = Just $ falseValInt dflags +mkRuleFn dflags Le _ (Lit lit) | isMaxBound dflags lit = Just $ trueValInt dflags +mkRuleFn _ _ _ _ = Nothing + +isMinBound :: DynFlags -> Literal -> Bool +isMinBound _ (LitChar c) = c == minBound +isMinBound dflags (LitNumber nt i _) = case nt of + LitNumInt -> i == tARGET_MIN_INT dflags + LitNumInt64 -> i == toInteger (minBound :: Int64) + LitNumWord -> i == 0 + LitNumWord64 -> i == 0 + LitNumNatural -> i == 0 + LitNumInteger -> False +isMinBound _ _ = False + +isMaxBound :: DynFlags -> Literal -> Bool +isMaxBound _ (LitChar c) = c == maxBound +isMaxBound dflags (LitNumber nt i _) = case nt of + LitNumInt -> i == tARGET_MAX_INT dflags + LitNumInt64 -> i == toInteger (maxBound :: Int64) + LitNumWord -> i == tARGET_MAX_WORD dflags + LitNumWord64 -> i == toInteger (maxBound :: Word64) + LitNumNatural -> False + LitNumInteger -> False +isMaxBound _ _ = False + +-- | Create an Int literal expression while ensuring the given Integer is in the +-- target Int range +intResult :: DynFlags -> Integer -> Maybe CoreExpr +intResult dflags result = Just (intResult' dflags result) + +intResult' :: DynFlags -> Integer -> CoreExpr +intResult' dflags result = Lit (mkLitIntWrap dflags result) + +-- | Create an unboxed pair of an Int literal expression, ensuring the given +-- Integer is in the target Int range and the corresponding overflow flag +-- (@0#@/@1#@) if it wasn't. +intCResult :: DynFlags -> Integer -> Maybe CoreExpr +intCResult dflags result = Just (mkPair [Lit lit, Lit c]) + where + mkPair = mkCoreUbxTup [intPrimTy, intPrimTy] + (lit, b) = mkLitIntWrapC dflags result + c = if b then onei dflags else zeroi dflags + +-- | Create a Word literal expression while ensuring the given Integer is in the +-- target Word range +wordResult :: DynFlags -> Integer -> Maybe CoreExpr +wordResult dflags result = Just (wordResult' dflags result) + +wordResult' :: DynFlags -> Integer -> CoreExpr +wordResult' dflags result = Lit (mkLitWordWrap dflags result) + +-- | Create an unboxed pair of a Word literal expression, ensuring the given +-- Integer is in the target Word range and the corresponding carry flag +-- (@0#@/@1#@) if it wasn't. +wordCResult :: DynFlags -> Integer -> Maybe CoreExpr +wordCResult dflags result = Just (mkPair [Lit lit, Lit c]) + where + mkPair = mkCoreUbxTup [wordPrimTy, intPrimTy] + (lit, b) = mkLitWordWrapC dflags result + c = if b then onei dflags else zeroi dflags + +inversePrimOp :: PrimOp -> RuleM CoreExpr +inversePrimOp primop = do + [Var primop_id `App` e] <- getArgs + matchPrimOpId primop primop_id + return e + +subsumesPrimOp :: PrimOp -> PrimOp -> RuleM CoreExpr +this `subsumesPrimOp` that = do + [Var primop_id `App` e] <- getArgs + matchPrimOpId that primop_id + return (Var (mkPrimOpId this) `App` e) + +subsumedByPrimOp :: PrimOp -> RuleM CoreExpr +subsumedByPrimOp primop = do + [e@(Var primop_id `App` _)] <- getArgs + matchPrimOpId primop primop_id + return e + +idempotent :: RuleM CoreExpr +idempotent = do [e1, e2] <- getArgs + guard $ cheapEqExpr e1 e2 + return e1 + +{- +Note [Guarding against silly shifts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this code: + + import Data.Bits( (.|.), shiftL ) + chunkToBitmap :: [Bool] -> Word32 + chunkToBitmap chunk = foldr (.|.) 0 [ 1 `shiftL` n | (True,n) <- zip chunk [0..] ] + +This optimises to: +Shift.$wgo = \ (w_sCS :: GHC.Prim.Int#) (w1_sCT :: [GHC.Types.Bool]) -> + case w1_sCT of _ { + [] -> 0##; + : x_aAW xs_aAX -> + case x_aAW of _ { + GHC.Types.False -> + case w_sCS of wild2_Xh { + __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild2_Xh 1) xs_aAX; + 9223372036854775807 -> 0## }; + GHC.Types.True -> + case GHC.Prim.>=# w_sCS 64 of _ { + GHC.Types.False -> + case w_sCS of wild3_Xh { + __DEFAULT -> + case Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX of ww_sCW { __DEFAULT -> + GHC.Prim.or# (GHC.Prim.narrow32Word# + (GHC.Prim.uncheckedShiftL# 1## wild3_Xh)) + ww_sCW + }; + 9223372036854775807 -> + GHC.Prim.narrow32Word# +!!!!--> (GHC.Prim.uncheckedShiftL# 1## 9223372036854775807) + }; + GHC.Types.True -> + case w_sCS of wild3_Xh { + __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX; + 9223372036854775807 -> 0## + } } } } + +Note the massive shift on line "!!!!". It can't happen, because we've checked +that w < 64, but the optimiser didn't spot that. We DO NOT want to constant-fold this! +Moreover, if the programmer writes (n `uncheckedShiftL` 9223372036854775807), we +can't constant fold it, but if it gets to the assember we get + Error: operand type mismatch for `shl' + +So the best thing to do is to rewrite the shift with a call to error, +when the second arg is stupid. + +There are two cases: + +- Shifting fixed-width things: the primops ISll, Sll, etc + These are handled by shiftRule. + + We are happy to shift by any amount up to wordSize but no more. + +- Shifting Integers: the function shiftLInteger, shiftRInteger + from the 'integer' library. These are handled by rule_shift_op, + and match_Integer_shift_op. + + Here we could in principle shift by any amount, but we arbitary + limit the shift to 4 bits; in particualr we do not want shift by a + huge amount, which can happen in code like that above. + +The two cases are more different in their code paths that is comfortable, +but that is only a historical accident. + + +************************************************************************ +* * +\subsection{Vaguely generic functions} +* * +************************************************************************ +-} + +mkBasicRule :: Name -> Int -> RuleM CoreExpr -> CoreRule +-- Gives the Rule the same name as the primop itself +mkBasicRule op_name n_args rm + = BuiltinRule { ru_name = occNameFS (nameOccName op_name), + ru_fn = op_name, + ru_nargs = n_args, + ru_try = \ dflags in_scope _ -> runRuleM rm dflags in_scope } + +newtype RuleM r = RuleM + { runRuleM :: DynFlags -> InScopeEnv -> [CoreExpr] -> Maybe r } + +instance Functor RuleM where + fmap = liftM + +instance Applicative RuleM where + pure x = RuleM $ \_ _ _ -> Just x + (<*>) = ap + +instance Monad RuleM where + RuleM f >>= g = RuleM $ \dflags iu e -> case f dflags iu e of + Nothing -> Nothing + Just r -> runRuleM (g r) dflags iu e +#if !MIN_VERSION_base(4,13,0) + fail = MonadFail.fail +#endif + +instance MonadFail.MonadFail RuleM where + fail _ = mzero + +instance Alternative RuleM where + empty = RuleM $ \_ _ _ -> Nothing + RuleM f1 <|> RuleM f2 = RuleM $ \dflags iu args -> + f1 dflags iu args <|> f2 dflags iu args + +instance MonadPlus RuleM + +instance HasDynFlags RuleM where + getDynFlags = RuleM $ \dflags _ _ -> Just dflags + +liftMaybe :: Maybe a -> RuleM a +liftMaybe Nothing = mzero +liftMaybe (Just x) = return x + +liftLit :: (Literal -> Literal) -> RuleM CoreExpr +liftLit f = liftLitDynFlags (const f) + +liftLitDynFlags :: (DynFlags -> Literal -> Literal) -> RuleM CoreExpr +liftLitDynFlags f = do + dflags <- getDynFlags + [Lit lit] <- getArgs + return $ Lit (f dflags lit) + +removeOp32 :: RuleM CoreExpr +removeOp32 = do + dflags <- getDynFlags + if wordSizeInBits dflags == 32 + then do + [e] <- getArgs + return e + else mzero + +getArgs :: RuleM [CoreExpr] +getArgs = RuleM $ \_ _ args -> Just args + +getInScopeEnv :: RuleM InScopeEnv +getInScopeEnv = RuleM $ \_ iu _ -> Just iu + +-- return the n-th argument of this rule, if it is a literal +-- argument indices start from 0 +getLiteral :: Int -> RuleM Literal +getLiteral n = RuleM $ \_ _ exprs -> case drop n exprs of + (Lit l:_) -> Just l + _ -> Nothing + +unaryLit :: (DynFlags -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr +unaryLit op = do + dflags <- getDynFlags + [Lit l] <- getArgs + liftMaybe $ op dflags (convFloating dflags l) + +binaryLit :: (DynFlags -> Literal -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr +binaryLit op = do + dflags <- getDynFlags + [Lit l1, Lit l2] <- getArgs + liftMaybe $ op dflags (convFloating dflags l1) (convFloating dflags l2) + +binaryCmpLit :: (forall a . Ord a => a -> a -> Bool) -> RuleM CoreExpr +binaryCmpLit op = do + dflags <- getDynFlags + binaryLit (\_ -> cmpOp dflags op) + +leftIdentity :: Literal -> RuleM CoreExpr +leftIdentity id_lit = leftIdentityDynFlags (const id_lit) + +rightIdentity :: Literal -> RuleM CoreExpr +rightIdentity id_lit = rightIdentityDynFlags (const id_lit) + +identity :: Literal -> RuleM CoreExpr +identity lit = leftIdentity lit `mplus` rightIdentity lit + +leftIdentityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr +leftIdentityDynFlags id_lit = do + dflags <- getDynFlags + [Lit l1, e2] <- getArgs + guard $ l1 == id_lit dflags + return e2 + +-- | Left identity rule for PrimOps like 'IntAddC' and 'WordAddC', where, in +-- addition to the result, we have to indicate that no carry/overflow occured. +leftIdentityCDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr +leftIdentityCDynFlags id_lit = do + dflags <- getDynFlags + [Lit l1, e2] <- getArgs + guard $ l1 == id_lit dflags + let no_c = Lit (zeroi dflags) + return (mkCoreUbxTup [exprType e2, intPrimTy] [e2, no_c]) + +rightIdentityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr +rightIdentityDynFlags id_lit = do + dflags <- getDynFlags + [e1, Lit l2] <- getArgs + guard $ l2 == id_lit dflags + return e1 + +-- | Right identity rule for PrimOps like 'IntSubC' and 'WordSubC', where, in +-- addition to the result, we have to indicate that no carry/overflow occured. +rightIdentityCDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr +rightIdentityCDynFlags id_lit = do + dflags <- getDynFlags + [e1, Lit l2] <- getArgs + guard $ l2 == id_lit dflags + let no_c = Lit (zeroi dflags) + return (mkCoreUbxTup [exprType e1, intPrimTy] [e1, no_c]) + +identityDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr +identityDynFlags lit = + leftIdentityDynFlags lit `mplus` rightIdentityDynFlags lit + +-- | Identity rule for PrimOps like 'IntAddC' and 'WordAddC', where, in addition +-- to the result, we have to indicate that no carry/overflow occured. +identityCDynFlags :: (DynFlags -> Literal) -> RuleM CoreExpr +identityCDynFlags lit = + leftIdentityCDynFlags lit `mplus` rightIdentityCDynFlags lit + +leftZero :: (DynFlags -> Literal) -> RuleM CoreExpr +leftZero zero = do + dflags <- getDynFlags + [Lit l1, _] <- getArgs + guard $ l1 == zero dflags + return $ Lit l1 + +rightZero :: (DynFlags -> Literal) -> RuleM CoreExpr +rightZero zero = do + dflags <- getDynFlags + [_, Lit l2] <- getArgs + guard $ l2 == zero dflags + return $ Lit l2 + +zeroElem :: (DynFlags -> Literal) -> RuleM CoreExpr +zeroElem lit = leftZero lit `mplus` rightZero lit + +equalArgs :: RuleM () +equalArgs = do + [e1, e2] <- getArgs + guard $ e1 `cheapEqExpr` e2 + +nonZeroLit :: Int -> RuleM () +nonZeroLit n = getLiteral n >>= guard . not . isZeroLit + +-- When excess precision is not requested, cut down the precision of the +-- Rational value to that of Float/Double. We confuse host architecture +-- and target architecture here, but it's convenient (and wrong :-). +convFloating :: DynFlags -> Literal -> Literal +convFloating dflags (LitFloat f) | not (gopt Opt_ExcessPrecision dflags) = + LitFloat (toRational (fromRational f :: Float )) +convFloating dflags (LitDouble d) | not (gopt Opt_ExcessPrecision dflags) = + LitDouble (toRational (fromRational d :: Double)) +convFloating _ l = l + +guardFloatDiv :: RuleM () +guardFloatDiv = do + [Lit (LitFloat f1), Lit (LitFloat f2)] <- getArgs + guard $ (f1 /=0 || f2 > 0) -- see Note [negative zero] + && f2 /= 0 -- avoid NaN and Infinity/-Infinity + +guardDoubleDiv :: RuleM () +guardDoubleDiv = do + [Lit (LitDouble d1), Lit (LitDouble d2)] <- getArgs + guard $ (d1 /=0 || d2 > 0) -- see Note [negative zero] + && d2 /= 0 -- avoid NaN and Infinity/-Infinity +-- Note [negative zero] Avoid (0 / -d), otherwise 0/(-1) reduces to +-- zero, but we might want to preserve the negative zero here which +-- is representable in Float/Double but not in (normalised) +-- Rational. (#3676) Perhaps we should generate (0 :% (-1)) instead? + +strengthReduction :: Literal -> PrimOp -> RuleM CoreExpr +strengthReduction two_lit add_op = do -- Note [Strength reduction] + arg <- msum [ do [arg, Lit mult_lit] <- getArgs + guard (mult_lit == two_lit) + return arg + , do [Lit mult_lit, arg] <- getArgs + guard (mult_lit == two_lit) + return arg ] + return $ Var (mkPrimOpId add_op) `App` arg `App` arg + +-- Note [Strength reduction] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- This rule turns floating point multiplications of the form 2.0 * x and +-- x * 2.0 into x + x addition, because addition costs less than multiplication. +-- See #7116 + +-- Note [What's true and false] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- trueValInt and falseValInt represent true and false values returned by +-- comparison primops for Char, Int, Word, Integer, Double, Float and Addr. +-- True is represented as an unboxed 1# literal, while false is represented +-- as 0# literal. +-- We still need Bool data constructors (True and False) to use in a rule +-- for constant folding of equal Strings + +trueValInt, falseValInt :: DynFlags -> Expr CoreBndr +trueValInt dflags = Lit $ onei dflags -- see Note [What's true and false] +falseValInt dflags = Lit $ zeroi dflags + +trueValBool, falseValBool :: Expr CoreBndr +trueValBool = Var trueDataConId -- see Note [What's true and false] +falseValBool = Var falseDataConId + +ltVal, eqVal, gtVal :: Expr CoreBndr +ltVal = Var ordLTDataConId +eqVal = Var ordEQDataConId +gtVal = Var ordGTDataConId + +mkIntVal :: DynFlags -> Integer -> Expr CoreBndr +mkIntVal dflags i = Lit (mkLitInt dflags i) +mkFloatVal :: DynFlags -> Rational -> Expr CoreBndr +mkFloatVal dflags f = Lit (convFloating dflags (LitFloat f)) +mkDoubleVal :: DynFlags -> Rational -> Expr CoreBndr +mkDoubleVal dflags d = Lit (convFloating dflags (LitDouble d)) + +matchPrimOpId :: PrimOp -> Id -> RuleM () +matchPrimOpId op id = do + op' <- liftMaybe $ isPrimOpId_maybe id + guard $ op == op' + +{- +************************************************************************ +* * +\subsection{Special rules for seq, tagToEnum, dataToTag} +* * +************************************************************************ + +Note [tagToEnum#] +~~~~~~~~~~~~~~~~~ +Nasty check to ensure that tagToEnum# is applied to a type that is an +enumeration TyCon. Unification may refine the type later, but this +check won't see that, alas. It's crude but it works. + +Here's are two cases that should fail + f :: forall a. a + f = tagToEnum# 0 -- Can't do tagToEnum# at a type variable + + g :: Int + g = tagToEnum# 0 -- Int is not an enumeration + +We used to make this check in the type inference engine, but it's quite +ugly to do so, because the delayed constraint solving means that we don't +really know what's going on until the end. It's very much a corner case +because we don't expect the user to call tagToEnum# at all; we merely +generate calls in derived instances of Enum. So we compromise: a +rewrite rule rewrites a bad instance of tagToEnum# to an error call, +and emits a warning. +-} + +tagToEnumRule :: RuleM CoreExpr +-- If data T a = A | B | C +-- then tag2Enum# (T ty) 2# --> B ty +tagToEnumRule = do + [Type ty, Lit (LitNumber LitNumInt i _)] <- getArgs + case splitTyConApp_maybe ty of + Just (tycon, tc_args) | isEnumerationTyCon tycon -> do + let tag = fromInteger i + correct_tag dc = (dataConTagZ dc) == tag + (dc:rest) <- return $ filter correct_tag (tyConDataCons_maybe tycon `orElse` []) + ASSERT(null rest) return () + return $ mkTyApps (Var (dataConWorkId dc)) tc_args + + -- See Note [tagToEnum#] + _ -> WARN( True, text "tagToEnum# on non-enumeration type" <+> ppr ty ) + return $ mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type" + +------------------------------ +dataToTagRule :: RuleM CoreExpr +-- See Note [dataToTag#] in primops.txt.pp +dataToTagRule = a `mplus` b + where + -- dataToTag (tagToEnum x) ==> x + a = do + [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] <- getArgs + guard $ tag_to_enum `hasKey` tagToEnumKey + guard $ ty1 `eqType` ty2 + return tag + + -- dataToTag (K e1 e2) ==> tag-of K + -- This also works (via exprIsConApp_maybe) for + -- dataToTag x + -- where x's unfolding is a constructor application + b = do + dflags <- getDynFlags + [_, val_arg] <- getArgs + in_scope <- getInScopeEnv + (_,floats, dc,_,_) <- liftMaybe $ exprIsConApp_maybe in_scope val_arg + ASSERT( not (isNewTyCon (dataConTyCon dc)) ) return () + return $ wrapFloats floats (mkIntVal dflags (toInteger (dataConTagZ dc))) + +{- Note [dataToTag# magic] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +The primop dataToTag# is unusual because it evaluates its argument. +Only `SeqOp` shares that property. (Other primops do not do anything +as fancy as argument evaluation.) The special handling for dataToTag# +is: + +* CoreUtils.exprOkForSpeculation has a special case for DataToTagOp, + (actually in app_ok). Most primops with lifted arguments do not + evaluate those arguments, but DataToTagOp and SeqOp are two + exceptions. We say that they are /never/ ok-for-speculation, + regardless of the evaluated-ness of their argument. + See CoreUtils Note [exprOkForSpeculation and SeqOp/DataToTagOp] + +* There is a special case for DataToTagOp in StgCmmExpr.cgExpr, + that evaluates its argument and then extracts the tag from + the returned value. + +* An application like (dataToTag# (Just x)) is optimised by + dataToTagRule in PrelRules. + +* A case expression like + case (dataToTag# e) of + gets transformed t + case e of + by PrelRules.caseRules; see Note [caseRules for dataToTag] + +See #15696 for a long saga. + + +************************************************************************ +* * +\subsection{Rules for seq# and spark#} +* * +************************************************************************ +-} + +{- Note [seq# magic] +~~~~~~~~~~~~~~~~~~~~ +The primop + seq# :: forall a s . a -> State# s -> (# State# s, a #) + +is /not/ the same as the Prelude function seq :: a -> b -> b +as you can see from its type. In fact, seq# is the implementation +mechanism for 'evaluate' + + evaluate :: a -> IO a + evaluate a = IO $ \s -> seq# a s + +The semantics of seq# is + * evaluate its first argument + * and return it + +Things to note + +* Why do we need a primop at all? That is, instead of + case seq# x s of (# x, s #) -> blah + why not instead say this? + case x of { DEFAULT -> blah) + + Reason (see #5129): if we saw + catch# (\s -> case x of { DEFAULT -> raiseIO# exn s }) handler + + then we'd drop the 'case x' because the body of the case is bottom + anyway. But we don't want to do that; the whole /point/ of + seq#/evaluate is to evaluate 'x' first in the IO monad. + + In short, we /always/ evaluate the first argument and never + just discard it. + +* Why return the value? So that we can control sharing of seq'd + values: in + let x = e in x `seq` ... x ... + We don't want to inline x, so better to represent it as + let x = e in case seq# x RW of (# _, x' #) -> ... x' ... + also it matches the type of rseq in the Eval monad. + +Implementing seq#. The compiler has magic for SeqOp in + +- PrelRules.seqRule: eliminate (seq# s) + +- StgCmmExpr.cgExpr, and cgCase: special case for seq# + +- CoreUtils.exprOkForSpeculation; + see Note [exprOkForSpeculation and SeqOp/DataToTagOp] in CoreUtils + +- Simplify.addEvals records evaluated-ness for the result; see + Note [Adding evaluatedness info to pattern-bound variables] + in Simplify +-} + +seqRule :: RuleM CoreExpr +seqRule = do + [Type ty_a, Type _ty_s, a, s] <- getArgs + guard $ exprIsHNF a + return $ mkCoreUbxTup [exprType s, ty_a] [s, a] + +-- spark# :: forall a s . a -> State# s -> (# State# s, a #) +sparkRule :: RuleM CoreExpr +sparkRule = seqRule -- reduce on HNF, just the same + -- XXX perhaps we shouldn't do this, because a spark eliminated by + -- this rule won't be counted as a dud at runtime? + +{- +************************************************************************ +* * +\subsection{Built in rules} +* * +************************************************************************ + +Note [Scoping for Builtin rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When compiling a (base-package) module that defines one of the +functions mentioned in the RHS of a built-in rule, there's a danger +that we'll see + + f = ...(eq String x).... + + ....and lower down... + + eqString = ... + +Then a rewrite would give + + f = ...(eqString x)... + ....and lower down... + eqString = ... + +and lo, eqString is not in scope. This only really matters when we get to code +generation. With -O we do a GlomBinds step that does a new SCC analysis on the whole +set of bindings, which sorts out the dependency. Without -O we don't do any rule +rewriting so again we are fine. + +(This whole thing doesn't show up for non-built-in rules because their dependencies +are explicit.) +-} + +builtinRules :: [CoreRule] +-- Rules for non-primops that can't be expressed using a RULE pragma +builtinRules + = [BuiltinRule { ru_name = fsLit "AppendLitString", + ru_fn = unpackCStringFoldrName, + ru_nargs = 4, ru_try = match_append_lit }, + BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName, + ru_nargs = 2, ru_try = match_eq_string }, + BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName, + ru_nargs = 2, ru_try = \_ _ _ -> match_inline }, + BuiltinRule { ru_name = fsLit "MagicDict", ru_fn = idName magicDictId, + ru_nargs = 4, ru_try = \_ _ _ -> match_magicDict }, + mkBasicRule divIntName 2 $ msum + [ nonZeroLit 1 >> binaryLit (intOp2 div) + , leftZero zeroi + , do + [arg, Lit (LitNumber LitNumInt d _)] <- getArgs + Just n <- return $ exactLog2 d + dflags <- getDynFlags + return $ Var (mkPrimOpId ISraOp) `App` arg `App` mkIntVal dflags n + ], + mkBasicRule modIntName 2 $ msum + [ nonZeroLit 1 >> binaryLit (intOp2 mod) + , leftZero zeroi + , do + [arg, Lit (LitNumber LitNumInt d _)] <- getArgs + Just _ <- return $ exactLog2 d + dflags <- getDynFlags + return $ Var (mkPrimOpId AndIOp) + `App` arg `App` mkIntVal dflags (d - 1) + ] + ] + ++ builtinIntegerRules + ++ builtinNaturalRules +{-# NOINLINE builtinRules #-} +-- there is no benefit to inlining these yet, despite this, GHC produces +-- unfoldings for this regardless since the floated list entries look small. + +builtinIntegerRules :: [CoreRule] +builtinIntegerRules = + [rule_IntToInteger "smallInteger" smallIntegerName, + rule_WordToInteger "wordToInteger" wordToIntegerName, + rule_Int64ToInteger "int64ToInteger" int64ToIntegerName, + rule_Word64ToInteger "word64ToInteger" word64ToIntegerName, + rule_convert "integerToWord" integerToWordName mkWordLitWord, + rule_convert "integerToInt" integerToIntName mkIntLitInt, + rule_convert "integerToWord64" integerToWord64Name (\_ -> mkWord64LitWord64), + rule_convert "integerToInt64" integerToInt64Name (\_ -> mkInt64LitInt64), + rule_binop "plusInteger" plusIntegerName (+), + rule_binop "minusInteger" minusIntegerName (-), + rule_binop "timesInteger" timesIntegerName (*), + rule_unop "negateInteger" negateIntegerName negate, + rule_binop_Prim "eqInteger#" eqIntegerPrimName (==), + rule_binop_Prim "neqInteger#" neqIntegerPrimName (/=), + rule_unop "absInteger" absIntegerName abs, + rule_unop "signumInteger" signumIntegerName signum, + rule_binop_Prim "leInteger#" leIntegerPrimName (<=), + rule_binop_Prim "gtInteger#" gtIntegerPrimName (>), + rule_binop_Prim "ltInteger#" ltIntegerPrimName (<), + rule_binop_Prim "geInteger#" geIntegerPrimName (>=), + rule_binop_Ordering "compareInteger" compareIntegerName compare, + rule_encodeFloat "encodeFloatInteger" encodeFloatIntegerName mkFloatLitFloat, + rule_convert "floatFromInteger" floatFromIntegerName (\_ -> mkFloatLitFloat), + rule_encodeFloat "encodeDoubleInteger" encodeDoubleIntegerName mkDoubleLitDouble, + rule_decodeDouble "decodeDoubleInteger" decodeDoubleIntegerName, + rule_convert "doubleFromInteger" doubleFromIntegerName (\_ -> mkDoubleLitDouble), + rule_rationalTo "rationalToFloat" rationalToFloatName mkFloatExpr, + rule_rationalTo "rationalToDouble" rationalToDoubleName mkDoubleExpr, + rule_binop "gcdInteger" gcdIntegerName gcd, + rule_binop "lcmInteger" lcmIntegerName lcm, + rule_binop "andInteger" andIntegerName (.&.), + rule_binop "orInteger" orIntegerName (.|.), + rule_binop "xorInteger" xorIntegerName xor, + rule_unop "complementInteger" complementIntegerName complement, + rule_shift_op "shiftLInteger" shiftLIntegerName shiftL, + rule_shift_op "shiftRInteger" shiftRIntegerName shiftR, + rule_bitInteger "bitInteger" bitIntegerName, + -- See Note [Integer division constant folding] in libraries/base/GHC/Real.hs + rule_divop_one "quotInteger" quotIntegerName quot, + rule_divop_one "remInteger" remIntegerName rem, + rule_divop_one "divInteger" divIntegerName div, + rule_divop_one "modInteger" modIntegerName mod, + rule_divop_both "divModInteger" divModIntegerName divMod, + rule_divop_both "quotRemInteger" quotRemIntegerName quotRem, + -- These rules below don't actually have to be built in, but if we + -- put them in the Haskell source then we'd have to duplicate them + -- between all Integer implementations + rule_XToIntegerToX "smallIntegerToInt" integerToIntName smallIntegerName, + rule_XToIntegerToX "wordToIntegerToWord" integerToWordName wordToIntegerName, + rule_XToIntegerToX "int64ToIntegerToInt64" integerToInt64Name int64ToIntegerName, + rule_XToIntegerToX "word64ToIntegerToWord64" integerToWord64Name word64ToIntegerName, + rule_smallIntegerTo "smallIntegerToWord" integerToWordName Int2WordOp, + rule_smallIntegerTo "smallIntegerToFloat" floatFromIntegerName Int2FloatOp, + rule_smallIntegerTo "smallIntegerToDouble" doubleFromIntegerName Int2DoubleOp + ] + where rule_convert str name convert + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, + ru_try = match_Integer_convert convert } + rule_IntToInteger str name + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, + ru_try = match_IntToInteger } + rule_WordToInteger str name + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, + ru_try = match_WordToInteger } + rule_Int64ToInteger str name + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, + ru_try = match_Int64ToInteger } + rule_Word64ToInteger str name + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, + ru_try = match_Word64ToInteger } + rule_unop str name op + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, + ru_try = match_Integer_unop op } + rule_bitInteger str name + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, + ru_try = match_bitInteger } + rule_binop str name op + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, + ru_try = match_Integer_binop op } + rule_divop_both str name op + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, + ru_try = match_Integer_divop_both op } + rule_divop_one str name op + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, + ru_try = match_Integer_divop_one op } + rule_shift_op str name op + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, + ru_try = match_Integer_shift_op op } + rule_binop_Prim str name op + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, + ru_try = match_Integer_binop_Prim op } + rule_binop_Ordering str name op + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, + ru_try = match_Integer_binop_Ordering op } + rule_encodeFloat str name op + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, + ru_try = match_Integer_Int_encodeFloat op } + rule_decodeDouble str name + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, + ru_try = match_decodeDouble } + rule_XToIntegerToX str name toIntegerName + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, + ru_try = match_XToIntegerToX toIntegerName } + rule_smallIntegerTo str name primOp + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, + ru_try = match_smallIntegerTo primOp } + rule_rationalTo str name mkLit + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, + ru_try = match_rationalTo mkLit } + +builtinNaturalRules :: [CoreRule] +builtinNaturalRules = + [rule_binop "plusNatural" plusNaturalName (+) + ,rule_partial_binop "minusNatural" minusNaturalName (\a b -> if a >= b then Just (a - b) else Nothing) + ,rule_binop "timesNatural" timesNaturalName (*) + ,rule_NaturalFromInteger "naturalFromInteger" naturalFromIntegerName + ,rule_NaturalToInteger "naturalToInteger" naturalToIntegerName + ,rule_WordToNatural "wordToNatural" wordToNaturalName + ] + where rule_binop str name op + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, + ru_try = match_Natural_binop op } + rule_partial_binop str name op + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2, + ru_try = match_Natural_partial_binop op } + rule_NaturalToInteger str name + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, + ru_try = match_NaturalToInteger } + rule_NaturalFromInteger str name + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, + ru_try = match_NaturalFromInteger } + rule_WordToNatural str name + = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1, + ru_try = match_WordToNatural } + +--------------------------------------------------- +-- The rule is this: +-- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n) +-- = unpackFoldrCString# "foobaz" c n + +match_append_lit :: RuleFun +match_append_lit _ id_unf _ + [ Type ty1 + , lit1 + , c1 + , Var unpk `App` Type ty2 + `App` lit2 + `App` c2 + `App` n + ] + | unpk `hasKey` unpackCStringFoldrIdKey && + c1 `cheapEqExpr` c2 + , Just (LitString s1) <- exprIsLiteral_maybe id_unf lit1 + , Just (LitString s2) <- exprIsLiteral_maybe id_unf lit2 + = ASSERT( ty1 `eqType` ty2 ) + Just (Var unpk `App` Type ty1 + `App` Lit (LitString (s1 `BS.append` s2)) + `App` c1 + `App` n) + +match_append_lit _ _ _ _ = Nothing + +--------------------------------------------------- +-- The rule is this: +-- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2)) = s1==s2 + +match_eq_string :: RuleFun +match_eq_string _ id_unf _ + [Var unpk1 `App` lit1, Var unpk2 `App` lit2] + | unpk1 `hasKey` unpackCStringIdKey + , unpk2 `hasKey` unpackCStringIdKey + , Just (LitString s1) <- exprIsLiteral_maybe id_unf lit1 + , Just (LitString s2) <- exprIsLiteral_maybe id_unf lit2 + = Just (if s1 == s2 then trueValBool else falseValBool) + +match_eq_string _ _ _ _ = Nothing + + +--------------------------------------------------- +-- The rule is this: +-- inline f_ty (f a b c) = a b c +-- (if f has an unfolding, EVEN if it's a loop breaker) +-- +-- It's important to allow the argument to 'inline' to have args itself +-- (a) because its more forgiving to allow the programmer to write +-- inline f a b c +-- or inline (f a b c) +-- (b) because a polymorphic f wll get a type argument that the +-- programmer can't avoid +-- +-- Also, don't forget about 'inline's type argument! +match_inline :: [Expr CoreBndr] -> Maybe (Expr CoreBndr) +match_inline (Type _ : e : _) + | (Var f, args1) <- collectArgs e, + Just unf <- maybeUnfoldingTemplate (realIdUnfolding f) + -- Ignore the IdUnfoldingFun here! + = Just (mkApps unf args1) + +match_inline _ = Nothing + + +-- See Note [magicDictId magic] in `basicTypes/MkId.hs` +-- for a description of what is going on here. +match_magicDict :: [Expr CoreBndr] -> Maybe (Expr CoreBndr) +match_magicDict [Type _, Var wrap `App` Type a `App` Type _ `App` f, x, y ] + | Just (fieldTy, _) <- splitFunTy_maybe $ dropForAlls $ idType wrap + , Just (dictTy, _) <- splitFunTy_maybe fieldTy + , Just dictTc <- tyConAppTyCon_maybe dictTy + , Just (_,_,co) <- unwrapNewTyCon_maybe dictTc + = Just + $ f `App` Cast x (mkSymCo (mkUnbranchedAxInstCo Representational co [a] [])) + `App` y + +match_magicDict _ = Nothing + +------------------------------------------------- +-- Integer rules +-- smallInteger (79::Int#) = 79::Integer +-- wordToInteger (79::Word#) = 79::Integer +-- Similarly Int64, Word64 + +match_IntToInteger :: RuleFun +match_IntToInteger = match_IntToInteger_unop id + +match_WordToInteger :: RuleFun +match_WordToInteger _ id_unf id [xl] + | Just (LitNumber LitNumWord x _) <- exprIsLiteral_maybe id_unf xl + = case splitFunTy_maybe (idType id) of + Just (_, integerTy) -> + Just (Lit (mkLitInteger x integerTy)) + _ -> + panic "match_WordToInteger: Id has the wrong type" +match_WordToInteger _ _ _ _ = Nothing + +match_Int64ToInteger :: RuleFun +match_Int64ToInteger _ id_unf id [xl] + | Just (LitNumber LitNumInt64 x _) <- exprIsLiteral_maybe id_unf xl + = case splitFunTy_maybe (idType id) of + Just (_, integerTy) -> + Just (Lit (mkLitInteger x integerTy)) + _ -> + panic "match_Int64ToInteger: Id has the wrong type" +match_Int64ToInteger _ _ _ _ = Nothing + +match_Word64ToInteger :: RuleFun +match_Word64ToInteger _ id_unf id [xl] + | Just (LitNumber LitNumWord64 x _) <- exprIsLiteral_maybe id_unf xl + = case splitFunTy_maybe (idType id) of + Just (_, integerTy) -> + Just (Lit (mkLitInteger x integerTy)) + _ -> + panic "match_Word64ToInteger: Id has the wrong type" +match_Word64ToInteger _ _ _ _ = Nothing + +match_NaturalToInteger :: RuleFun +match_NaturalToInteger _ id_unf id [xl] + | Just (LitNumber LitNumNatural x _) <- exprIsLiteral_maybe id_unf xl + = case splitFunTy_maybe (idType id) of + Just (_, naturalTy) -> + Just (Lit (LitNumber LitNumInteger x naturalTy)) + _ -> + panic "match_NaturalToInteger: Id has the wrong type" +match_NaturalToInteger _ _ _ _ = Nothing + +match_NaturalFromInteger :: RuleFun +match_NaturalFromInteger _ id_unf id [xl] + | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl + , x >= 0 + = case splitFunTy_maybe (idType id) of + Just (_, naturalTy) -> + Just (Lit (LitNumber LitNumNatural x naturalTy)) + _ -> + panic "match_NaturalFromInteger: Id has the wrong type" +match_NaturalFromInteger _ _ _ _ = Nothing + +match_WordToNatural :: RuleFun +match_WordToNatural _ id_unf id [xl] + | Just (LitNumber LitNumWord x _) <- exprIsLiteral_maybe id_unf xl + = case splitFunTy_maybe (idType id) of + Just (_, naturalTy) -> + Just (Lit (LitNumber LitNumNatural x naturalTy)) + _ -> + panic "match_WordToNatural: Id has the wrong type" +match_WordToNatural _ _ _ _ = Nothing + +------------------------------------------------- +{- Note [Rewriting bitInteger] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For most types the bitInteger operation can be implemented in terms of shifts. +The integer-gmp package, however, can do substantially better than this if +allowed to provide its own implementation. However, in so doing it previously lost +constant-folding (see #8832). The bitInteger rule above provides constant folding +specifically for this function. + +There is, however, a bit of trickiness here when it comes to ranges. While the +AST encodes all integers as Integers, `bit` expects the bit +index to be given as an Int. Hence we coerce to an Int in the rule definition. +This will behave a bit funny for constants larger than the word size, but the user +should expect some funniness given that they will have at very least ignored a +warning in this case. +-} + +match_bitInteger :: RuleFun +-- Just for GHC.Integer.Type.bitInteger :: Int# -> Integer +match_bitInteger dflags id_unf fn [arg] + | Just (LitNumber LitNumInt x _) <- exprIsLiteral_maybe id_unf arg + , x >= 0 + , x <= (wordSizeInBits dflags - 1) + -- Make sure x is small enough to yield a decently small iteger + -- Attempting to construct the Integer for + -- (bitInteger 9223372036854775807#) + -- would be a bad idea (#14959) + , let x_int = fromIntegral x :: Int + = case splitFunTy_maybe (idType fn) of + Just (_, integerTy) + -> Just (Lit (LitNumber LitNumInteger (bit x_int) integerTy)) + _ -> panic "match_IntToInteger_unop: Id has the wrong type" + +match_bitInteger _ _ _ _ = Nothing + + +------------------------------------------------- +match_Integer_convert :: Num a + => (DynFlags -> a -> Expr CoreBndr) + -> RuleFun +match_Integer_convert convert dflags id_unf _ [xl] + | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl + = Just (convert dflags (fromInteger x)) +match_Integer_convert _ _ _ _ _ = Nothing + +match_Integer_unop :: (Integer -> Integer) -> RuleFun +match_Integer_unop unop _ id_unf _ [xl] + | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl + = Just (Lit (LitNumber LitNumInteger (unop x) i)) +match_Integer_unop _ _ _ _ _ = Nothing + +match_IntToInteger_unop :: (Integer -> Integer) -> RuleFun +match_IntToInteger_unop unop _ id_unf fn [xl] + | Just (LitNumber LitNumInt x _) <- exprIsLiteral_maybe id_unf xl + = case splitFunTy_maybe (idType fn) of + Just (_, integerTy) -> + Just (Lit (LitNumber LitNumInteger (unop x) integerTy)) + _ -> + panic "match_IntToInteger_unop: Id has the wrong type" +match_IntToInteger_unop _ _ _ _ _ = Nothing + +match_Integer_binop :: (Integer -> Integer -> Integer) -> RuleFun +match_Integer_binop binop _ id_unf _ [xl,yl] + | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl + , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl + = Just (Lit (mkLitInteger (x `binop` y) i)) +match_Integer_binop _ _ _ _ _ = Nothing + +match_Natural_binop :: (Integer -> Integer -> Integer) -> RuleFun +match_Natural_binop binop _ id_unf _ [xl,yl] + | Just (LitNumber LitNumNatural x i) <- exprIsLiteral_maybe id_unf xl + , Just (LitNumber LitNumNatural y _) <- exprIsLiteral_maybe id_unf yl + = Just (Lit (mkLitNatural (x `binop` y) i)) +match_Natural_binop _ _ _ _ _ = Nothing + +match_Natural_partial_binop :: (Integer -> Integer -> Maybe Integer) -> RuleFun +match_Natural_partial_binop binop _ id_unf _ [xl,yl] + | Just (LitNumber LitNumNatural x i) <- exprIsLiteral_maybe id_unf xl + , Just (LitNumber LitNumNatural y _) <- exprIsLiteral_maybe id_unf yl + , Just z <- x `binop` y + = Just (Lit (mkLitNatural z i)) +match_Natural_partial_binop _ _ _ _ _ = Nothing + +-- This helper is used for the quotRem and divMod functions +match_Integer_divop_both + :: (Integer -> Integer -> (Integer, Integer)) -> RuleFun +match_Integer_divop_both divop _ id_unf _ [xl,yl] + | Just (LitNumber LitNumInteger x t) <- exprIsLiteral_maybe id_unf xl + , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl + , y /= 0 + , (r,s) <- x `divop` y + = Just $ mkCoreUbxTup [t,t] [Lit (mkLitInteger r t), Lit (mkLitInteger s t)] +match_Integer_divop_both _ _ _ _ _ = Nothing + +-- This helper is used for the quot and rem functions +match_Integer_divop_one :: (Integer -> Integer -> Integer) -> RuleFun +match_Integer_divop_one divop _ id_unf _ [xl,yl] + | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl + , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl + , y /= 0 + = Just (Lit (mkLitInteger (x `divop` y) i)) +match_Integer_divop_one _ _ _ _ _ = Nothing + +match_Integer_shift_op :: (Integer -> Int -> Integer) -> RuleFun +-- Used for shiftLInteger, shiftRInteger :: Integer -> Int# -> Integer +-- See Note [Guarding against silly shifts] +match_Integer_shift_op binop _ id_unf _ [xl,yl] + | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl + , Just (LitNumber LitNumInt y _) <- exprIsLiteral_maybe id_unf yl + , y >= 0 + , y <= 4 -- Restrict constant-folding of shifts on Integers, somewhat + -- arbitrary. We can get huge shifts in inaccessible code + -- (#15673) + = Just (Lit (mkLitInteger (x `binop` fromIntegral y) i)) +match_Integer_shift_op _ _ _ _ _ = Nothing + +match_Integer_binop_Prim :: (Integer -> Integer -> Bool) -> RuleFun +match_Integer_binop_Prim binop dflags id_unf _ [xl, yl] + | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl + , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl + = Just (if x `binop` y then trueValInt dflags else falseValInt dflags) +match_Integer_binop_Prim _ _ _ _ _ = Nothing + +match_Integer_binop_Ordering :: (Integer -> Integer -> Ordering) -> RuleFun +match_Integer_binop_Ordering binop _ id_unf _ [xl, yl] + | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl + , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl + = Just $ case x `binop` y of + LT -> ltVal + EQ -> eqVal + GT -> gtVal +match_Integer_binop_Ordering _ _ _ _ _ = Nothing + +match_Integer_Int_encodeFloat :: RealFloat a + => (a -> Expr CoreBndr) + -> RuleFun +match_Integer_Int_encodeFloat mkLit _ id_unf _ [xl,yl] + | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl + , Just (LitNumber LitNumInt y _) <- exprIsLiteral_maybe id_unf yl + = Just (mkLit $ encodeFloat x (fromInteger y)) +match_Integer_Int_encodeFloat _ _ _ _ _ = Nothing + +--------------------------------------------------- +-- constant folding for Float/Double +-- +-- This turns +-- rationalToFloat n d +-- into a literal Float, and similarly for Doubles. +-- +-- it's important to not match d == 0, because that may represent a +-- literal "0/0" or similar, and we can't produce a literal value for +-- NaN or +-Inf +match_rationalTo :: RealFloat a + => (a -> Expr CoreBndr) + -> RuleFun +match_rationalTo mkLit _ id_unf _ [xl, yl] + | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl + , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl + , y /= 0 + = Just (mkLit (fromRational (x % y))) +match_rationalTo _ _ _ _ _ = Nothing + +match_decodeDouble :: RuleFun +match_decodeDouble dflags id_unf fn [xl] + | Just (LitDouble x) <- exprIsLiteral_maybe id_unf xl + = case splitFunTy_maybe (idType fn) of + Just (_, res) + | Just [_lev1, _lev2, integerTy, intHashTy] <- tyConAppArgs_maybe res + -> case decodeFloat (fromRational x :: Double) of + (y, z) -> + Just $ mkCoreUbxTup [integerTy, intHashTy] + [Lit (mkLitInteger y integerTy), + Lit (mkLitInt dflags (toInteger z))] + _ -> + pprPanic "match_decodeDouble: Id has the wrong type" + (ppr fn <+> dcolon <+> ppr (idType fn)) +match_decodeDouble _ _ _ _ = Nothing + +match_XToIntegerToX :: Name -> RuleFun +match_XToIntegerToX n _ _ _ [App (Var x) y] + | idName x == n + = Just y +match_XToIntegerToX _ _ _ _ _ = Nothing + +match_smallIntegerTo :: PrimOp -> RuleFun +match_smallIntegerTo primOp _ _ _ [App (Var x) y] + | idName x == smallIntegerName + = Just $ App (Var (mkPrimOpId primOp)) y +match_smallIntegerTo _ _ _ _ _ = Nothing + + + +-------------------------------------------------------- +-- Note [Constant folding through nested expressions] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- We use rewrites rules to perform constant folding. It means that we don't +-- have a global view of the expression we are trying to optimise. As a +-- consequence we only perform local (small-step) transformations that either: +-- 1) reduce the number of operations +-- 2) rearrange the expression to increase the odds that other rules will +-- match +-- +-- We don't try to handle more complex expression optimisation cases that would +-- require a global view. For example, rewriting expressions to increase +-- sharing (e.g., Horner's method); optimisations that require local +-- transformations increasing the number of operations; rearrangements to +-- cancel/factorize terms (e.g., (a+b-a-b) isn't rearranged to reduce to 0). +-- +-- We already have rules to perform constant folding on expressions with the +-- following shape (where a and/or b are literals): +-- +-- D) op +-- /\ +-- / \ +-- / \ +-- a b +-- +-- To support nested expressions, we match three other shapes of expression +-- trees: +-- +-- A) op1 B) op1 C) op1 +-- /\ /\ /\ +-- / \ / \ / \ +-- / \ / \ / \ +-- a op2 op2 c op2 op3 +-- /\ /\ /\ /\ +-- / \ / \ / \ / \ +-- b c a b a b c d +-- +-- +-- R1) +/- simplification: +-- ops = + or -, two literals (not siblings) +-- +-- Examples: +-- A: 5 + (10-x) ==> 15-x +-- B: (10+x) + 5 ==> 15+x +-- C: (5+a)-(5-b) ==> 0+(a+b) +-- +-- R2) * simplification +-- ops = *, two literals (not siblings) +-- +-- Examples: +-- A: 5 * (10*x) ==> 50*x +-- B: (10*x) * 5 ==> 50*x +-- C: (5*a)*(5*b) ==> 25*(a*b) +-- +-- R3) * distribution over +/- +-- op1 = *, op2 = + or -, two literals (not siblings) +-- +-- This transformation doesn't reduce the number of operations but switches +-- the outer and the inner operations so that the outer is (+) or (-) instead +-- of (*). It increases the odds that other rules will match after this one. +-- +-- Examples: +-- A: 5 * (10-x) ==> 50 - (5*x) +-- B: (10+x) * 5 ==> 50 + (5*x) +-- C: Not supported as it would increase the number of operations: +-- (5+a)*(5-b) ==> 25 - 5*b + 5*a - a*b +-- +-- R4) Simple factorization +-- +-- op1 = + or -, op2/op3 = *, +-- one literal for each innermost * operation (except in the D case), +-- the two other terms are equals +-- +-- Examples: +-- A: x - (10*x) ==> (-9)*x +-- B: (10*x) + x ==> 11*x +-- C: (5*x)-(x*3) ==> 2*x +-- D: x+x ==> 2*x +-- +-- R5) +/- propagation +-- +-- ops = + or -, one literal +-- +-- This transformation doesn't reduce the number of operations but propagates +-- the constant to the outer level. It increases the odds that other rules +-- will match after this one. +-- +-- Examples: +-- A: x - (10-y) ==> (x+y) - 10 +-- B: (10+x) - y ==> 10 + (x-y) +-- C: N/A (caught by the A and B cases) +-- +-------------------------------------------------------- + +-- | Rules to perform constant folding into nested expressions +-- +--See Note [Constant folding through nested expressions] +numFoldingRules :: PrimOp -> (DynFlags -> PrimOps) -> RuleM CoreExpr +numFoldingRules op dict = do + [e1,e2] <- getArgs + dflags <- getDynFlags + let PrimOps{..} = dict dflags + if not (gopt Opt_NumConstantFolding dflags) + then mzero + else case BinOpApp e1 op e2 of + -- R1) +/- simplification + x :++: (y :++: v) -> return $ mkL (x+y) `add` v + x :++: (L y :-: v) -> return $ mkL (x+y) `sub` v + x :++: (v :-: L y) -> return $ mkL (x-y) `add` v + L x :-: (y :++: v) -> return $ mkL (x-y) `sub` v + L x :-: (L y :-: v) -> return $ mkL (x-y) `add` v + L x :-: (v :-: L y) -> return $ mkL (x+y) `sub` v + + (y :++: v) :-: L x -> return $ mkL (y-x) `add` v + (L y :-: v) :-: L x -> return $ mkL (y-x) `sub` v + (v :-: L y) :-: L x -> return $ mkL (0-y-x) `add` v + + (x :++: w) :+: (y :++: v) -> return $ mkL (x+y) `add` (w `add` v) + (w :-: L x) :+: (L y :-: v) -> return $ mkL (y-x) `add` (w `sub` v) + (w :-: L x) :+: (v :-: L y) -> return $ mkL (0-x-y) `add` (w `add` v) + (L x :-: w) :+: (L y :-: v) -> return $ mkL (x+y) `sub` (w `add` v) + (L x :-: w) :+: (v :-: L y) -> return $ mkL (x-y) `add` (v `sub` w) + (w :-: L x) :+: (y :++: v) -> return $ mkL (y-x) `add` (w `add` v) + (L x :-: w) :+: (y :++: v) -> return $ mkL (x+y) `add` (v `sub` w) + (y :++: v) :+: (w :-: L x) -> return $ mkL (y-x) `add` (w `add` v) + (y :++: v) :+: (L x :-: w) -> return $ mkL (x+y) `add` (v `sub` w) + + (v :-: L y) :-: (w :-: L x) -> return $ mkL (x-y) `add` (v `sub` w) + (v :-: L y) :-: (L x :-: w) -> return $ mkL (0-x-y) `add` (v `add` w) + (L y :-: v) :-: (w :-: L x) -> return $ mkL (x+y) `sub` (v `add` w) + (L y :-: v) :-: (L x :-: w) -> return $ mkL (y-x) `add` (w `sub` v) + (x :++: w) :-: (y :++: v) -> return $ mkL (x-y) `add` (w `sub` v) + (w :-: L x) :-: (y :++: v) -> return $ mkL (0-y-x) `add` (w `sub` v) + (L x :-: w) :-: (y :++: v) -> return $ mkL (x-y) `sub` (v `add` w) + (y :++: v) :-: (w :-: L x) -> return $ mkL (y+x) `add` (v `sub` w) + (y :++: v) :-: (L x :-: w) -> return $ mkL (y-x) `add` (v `add` w) + + -- R2) * simplification + x :**: (y :**: v) -> return $ mkL (x*y) `mul` v + (x :**: w) :*: (y :**: v) -> return $ mkL (x*y) `mul` (w `mul` v) + + -- R3) * distribution over +/- + x :**: (y :++: v) -> return $ mkL (x*y) `add` (mkL x `mul` v) + x :**: (L y :-: v) -> return $ mkL (x*y) `sub` (mkL x `mul` v) + x :**: (v :-: L y) -> return $ (mkL x `mul` v) `sub` mkL (x*y) + + -- R4) Simple factorization + v :+: w + | w `cheapEqExpr` v -> return $ mkL 2 `mul` v + w :+: (y :**: v) + | w `cheapEqExpr` v -> return $ mkL (1+y) `mul` v + w :-: (y :**: v) + | w `cheapEqExpr` v -> return $ mkL (1-y) `mul` v + (y :**: v) :+: w + | w `cheapEqExpr` v -> return $ mkL (y+1) `mul` v + (y :**: v) :-: w + | w `cheapEqExpr` v -> return $ mkL (y-1) `mul` v + (x :**: w) :+: (y :**: v) + | w `cheapEqExpr` v -> return $ mkL (x+y) `mul` v + (x :**: w) :-: (y :**: v) + | w `cheapEqExpr` v -> return $ mkL (x-y) `mul` v + + -- R5) +/- propagation + w :+: (y :++: v) -> return $ mkL y `add` (w `add` v) + (y :++: v) :+: w -> return $ mkL y `add` (w `add` v) + w :-: (y :++: v) -> return $ (w `sub` v) `sub` mkL y + (y :++: v) :-: w -> return $ mkL y `add` (v `sub` w) + w :-: (L y :-: v) -> return $ (w `add` v) `sub` mkL y + (L y :-: v) :-: w -> return $ mkL y `sub` (w `add` v) + w :+: (L y :-: v) -> return $ mkL y `add` (w `sub` v) + w :+: (v :-: L y) -> return $ (w `add` v) `sub` mkL y + (L y :-: v) :+: w -> return $ mkL y `add` (w `sub` v) + (v :-: L y) :+: w -> return $ (w `add` v) `sub` mkL y + + _ -> mzero + + + +-- | Match the application of a binary primop +pattern BinOpApp :: Arg CoreBndr -> PrimOp -> Arg CoreBndr -> CoreExpr +pattern BinOpApp x op y = OpVal op `App` x `App` y + +-- | Match a primop +pattern OpVal :: PrimOp -> Arg CoreBndr +pattern OpVal op <- Var (isPrimOpId_maybe -> Just op) where + OpVal op = Var (mkPrimOpId op) + + + +-- | Match a literal +pattern L :: Integer -> Arg CoreBndr +pattern L l <- Lit (isLitValue_maybe -> Just l) + +-- | Match an addition +pattern (:+:) :: Arg CoreBndr -> Arg CoreBndr -> CoreExpr +pattern x :+: y <- BinOpApp x (isAddOp -> True) y + +-- | Match an addition with a literal (handle commutativity) +pattern (:++:) :: Integer -> Arg CoreBndr -> CoreExpr +pattern l :++: x <- (isAdd -> Just (l,x)) + +isAdd :: CoreExpr -> Maybe (Integer,CoreExpr) +isAdd e = case e of + L l :+: x -> Just (l,x) + x :+: L l -> Just (l,x) + _ -> Nothing + +-- | Match a multiplication +pattern (:*:) :: Arg CoreBndr -> Arg CoreBndr -> CoreExpr +pattern x :*: y <- BinOpApp x (isMulOp -> True) y + +-- | Match a multiplication with a literal (handle commutativity) +pattern (:**:) :: Integer -> Arg CoreBndr -> CoreExpr +pattern l :**: x <- (isMul -> Just (l,x)) + +isMul :: CoreExpr -> Maybe (Integer,CoreExpr) +isMul e = case e of + L l :*: x -> Just (l,x) + x :*: L l -> Just (l,x) + _ -> Nothing + + +-- | Match a subtraction +pattern (:-:) :: Arg CoreBndr -> Arg CoreBndr -> CoreExpr +pattern x :-: y <- BinOpApp x (isSubOp -> True) y + +isSubOp :: PrimOp -> Bool +isSubOp IntSubOp = True +isSubOp WordSubOp = True +isSubOp _ = False + +isAddOp :: PrimOp -> Bool +isAddOp IntAddOp = True +isAddOp WordAddOp = True +isAddOp _ = False + +isMulOp :: PrimOp -> Bool +isMulOp IntMulOp = True +isMulOp WordMulOp = True +isMulOp _ = False + +-- | Explicit "type-class"-like dictionary for numeric primops +-- +-- Depends on DynFlags because creating a literal value depends on DynFlags +data PrimOps = PrimOps + { add :: CoreExpr -> CoreExpr -> CoreExpr -- ^ Add two numbers + , sub :: CoreExpr -> CoreExpr -> CoreExpr -- ^ Sub two numbers + , mul :: CoreExpr -> CoreExpr -> CoreExpr -- ^ Multiply two numbers + , mkL :: Integer -> CoreExpr -- ^ Create a literal value + } + +intPrimOps :: DynFlags -> PrimOps +intPrimOps dflags = PrimOps + { add = \x y -> BinOpApp x IntAddOp y + , sub = \x y -> BinOpApp x IntSubOp y + , mul = \x y -> BinOpApp x IntMulOp y + , mkL = intResult' dflags + } + +wordPrimOps :: DynFlags -> PrimOps +wordPrimOps dflags = PrimOps + { add = \x y -> BinOpApp x WordAddOp y + , sub = \x y -> BinOpApp x WordSubOp y + , mul = \x y -> BinOpApp x WordMulOp y + , mkL = wordResult' dflags + } + + +-------------------------------------------------------- +-- Constant folding through case-expressions +-- +-- cf Scrutinee Constant Folding in simplCore/SimplUtils +-------------------------------------------------------- + +-- | Match the scrutinee of a case and potentially return a new scrutinee and a +-- function to apply to each literal alternative. +caseRules :: DynFlags + -> CoreExpr -- Scrutinee + -> Maybe ( CoreExpr -- New scrutinee + , AltCon -> Maybe AltCon -- How to fix up the alt pattern + -- Nothing <=> Unreachable + -- See Note [Unreachable caseRules alternatives] + , Id -> CoreExpr) -- How to reconstruct the original scrutinee + -- from the new case-binder +-- e.g case e of b { +-- ...; +-- con bs -> rhs; +-- ... } +-- ==> +-- case e' of b' { +-- ...; +-- fixup_altcon[con] bs -> let b = mk_orig[b] in rhs; +-- ... } + +caseRules dflags (App (App (Var f) v) (Lit l)) -- v `op` x# + | Just op <- isPrimOpId_maybe f + , Just x <- isLitValue_maybe l + , Just adjust_lit <- adjustDyadicRight op x + = Just (v, tx_lit_con dflags adjust_lit + , \v -> (App (App (Var f) (Var v)) (Lit l))) + +caseRules dflags (App (App (Var f) (Lit l)) v) -- x# `op` v + | Just op <- isPrimOpId_maybe f + , Just x <- isLitValue_maybe l + , Just adjust_lit <- adjustDyadicLeft x op + = Just (v, tx_lit_con dflags adjust_lit + , \v -> (App (App (Var f) (Lit l)) (Var v))) + + +caseRules dflags (App (Var f) v ) -- op v + | Just op <- isPrimOpId_maybe f + , Just adjust_lit <- adjustUnary op + = Just (v, tx_lit_con dflags adjust_lit + , \v -> App (Var f) (Var v)) + +-- See Note [caseRules for tagToEnum] +caseRules dflags (App (App (Var f) type_arg) v) + | Just TagToEnumOp <- isPrimOpId_maybe f + = Just (v, tx_con_tte dflags + , \v -> (App (App (Var f) type_arg) (Var v))) + +-- See Note [caseRules for dataToTag] +caseRules _ (App (App (Var f) (Type ty)) v) -- dataToTag x + | Just DataToTagOp <- isPrimOpId_maybe f + , Just (tc, _) <- tcSplitTyConApp_maybe ty + , isAlgTyCon tc + = Just (v, tx_con_dtt ty + , \v -> App (App (Var f) (Type ty)) (Var v)) + +caseRules _ _ = Nothing + + +tx_lit_con :: DynFlags -> (Integer -> Integer) -> AltCon -> Maybe AltCon +tx_lit_con _ _ DEFAULT = Just DEFAULT +tx_lit_con dflags adjust (LitAlt l) = Just $ LitAlt (mapLitValue dflags adjust l) +tx_lit_con _ _ alt = pprPanic "caseRules" (ppr alt) + -- NB: mapLitValue uses mkLitIntWrap etc, to ensure that the + -- literal alternatives remain in Word/Int target ranges + -- (See Note [Word/Int underflow/overflow] in Literal and #13172). + +adjustDyadicRight :: PrimOp -> Integer -> Maybe (Integer -> Integer) +-- Given (x `op` lit) return a function 'f' s.t. f (x `op` lit) = x +adjustDyadicRight op lit + = case op of + WordAddOp -> Just (\y -> y-lit ) + IntAddOp -> Just (\y -> y-lit ) + WordSubOp -> Just (\y -> y+lit ) + IntSubOp -> Just (\y -> y+lit ) + XorOp -> Just (\y -> y `xor` lit) + XorIOp -> Just (\y -> y `xor` lit) + _ -> Nothing + +adjustDyadicLeft :: Integer -> PrimOp -> Maybe (Integer -> Integer) +-- Given (lit `op` x) return a function 'f' s.t. f (lit `op` x) = x +adjustDyadicLeft lit op + = case op of + WordAddOp -> Just (\y -> y-lit ) + IntAddOp -> Just (\y -> y-lit ) + WordSubOp -> Just (\y -> lit-y ) + IntSubOp -> Just (\y -> lit-y ) + XorOp -> Just (\y -> y `xor` lit) + XorIOp -> Just (\y -> y `xor` lit) + _ -> Nothing + + +adjustUnary :: PrimOp -> Maybe (Integer -> Integer) +-- Given (op x) return a function 'f' s.t. f (op x) = x +adjustUnary op + = case op of + NotOp -> Just (\y -> complement y) + NotIOp -> Just (\y -> complement y) + IntNegOp -> Just (\y -> negate y ) + _ -> Nothing + +tx_con_tte :: DynFlags -> AltCon -> Maybe AltCon +tx_con_tte _ DEFAULT = Just DEFAULT +tx_con_tte _ alt@(LitAlt {}) = pprPanic "caseRules" (ppr alt) +tx_con_tte dflags (DataAlt dc) -- See Note [caseRules for tagToEnum] + = Just $ LitAlt $ mkLitInt dflags $ toInteger $ dataConTagZ dc + +tx_con_dtt :: Type -> AltCon -> Maybe AltCon +tx_con_dtt _ DEFAULT = Just DEFAULT +tx_con_dtt ty (LitAlt (LitNumber LitNumInt i _)) + | tag >= 0 + , tag < n_data_cons + = Just (DataAlt (data_cons !! tag)) -- tag is zero-indexed, as is (!!) + | otherwise + = Nothing + where + tag = fromInteger i :: ConTagZ + tc = tyConAppTyCon ty + n_data_cons = tyConFamilySize tc + data_cons = tyConDataCons tc + +tx_con_dtt _ alt = pprPanic "caseRules" (ppr alt) + + +{- Note [caseRules for tagToEnum] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to transform + case tagToEnum x of + False -> e1 + True -> e2 +into + case x of + 0# -> e1 + 1# -> e2 + +This rule eliminates a lot of boilerplate. For + if (x>y) then e2 else e1 +we generate + case tagToEnum (x ># y) of + False -> e1 + True -> e2 +and it is nice to then get rid of the tagToEnum. + +Beware (#14768): avoid the temptation to map constructor 0 to +DEFAULT, in the hope of getting this + case (x ># y) of + DEFAULT -> e1 + 1# -> e2 +That fails utterly in the case of + data Colour = Red | Green | Blue + case tagToEnum x of + DEFAULT -> e1 + Red -> e2 + +We don't want to get this! + case x of + DEFAULT -> e1 + DEFAULT -> e2 + +Instead, we deal with turning one branch into DEFAULT in SimplUtils +(add_default in mkCase3). + +Note [caseRules for dataToTag] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See also Note [dataToTag#] in primpops.txt.pp + +We want to transform + case dataToTag x of + DEFAULT -> e1 + 1# -> e2 +into + case x of + DEFAULT -> e1 + (:) _ _ -> e2 + +Note the need for some wildcard binders in +the 'cons' case. + +For the time, we only apply this transformation when the type of `x` is a type +headed by a normal tycon. In particular, we do not apply this in the case of a +data family tycon, since that would require carefully applying coercion(s) +between the data family and the data family instance's representation type, +which caseRules isn't currently engineered to handle (#14680). + +Note [Unreachable caseRules alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Take care if we see something like + case dataToTag x of + DEFAULT -> e1 + -1# -> e2 + 100 -> e3 +because there isn't a data constructor with tag -1 or 100. In this case the +out-of-range alterantive is dead code -- we know the range of tags for x. + +Hence caseRules returns (AltCon -> Maybe AltCon), with Nothing indicating +an alternative that is unreachable. + +You may wonder how this can happen: check out #15436. +-} diff --git a/compiler/prelude/PrimOp.hs b/compiler/prelude/PrimOp.hs new file mode 100644 --- /dev/null +++ b/compiler/prelude/PrimOp.hs @@ -0,0 +1,633 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[PrimOp]{Primitive operations (machine-level)} +-} + +{-# LANGUAGE CPP #-} + +-- The default is a bit too low for the quite large primOpInfo definition +{-# OPTIONS_GHC -fmax-pmcheck-iterations=10000000 #-} + +module PrimOp ( + PrimOp(..), PrimOpVecCat(..), allThePrimOps, + primOpType, primOpSig, + primOpTag, maxPrimOpTag, primOpOcc, + + tagToEnumKey, + + primOpOutOfLine, primOpCodeSize, + primOpOkForSpeculation, primOpOkForSideEffects, + primOpIsCheap, primOpFixity, + + getPrimOpResultInfo, isComparisonPrimOp, PrimOpResultInfo(..), + + PrimCall(..) + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import TysPrim +import TysWiredIn + +import CmmType +import Demand +import OccName ( OccName, pprOccName, mkVarOccFS ) +import TyCon ( TyCon, isPrimTyCon, PrimRep(..) ) +import Type +import RepType ( typePrimRep1, tyConPrimRep1 ) +import BasicTypes ( Arity, Fixity(..), FixityDirection(..), Boxity(..), + SourceText(..) ) +import ForeignCall ( CLabelString ) +import Unique ( Unique, mkPrimOpIdUnique ) +import Outputable +import FastString +import Module ( UnitId ) + +{- +************************************************************************ +* * +\subsection[PrimOp-datatype]{Datatype for @PrimOp@ (an enumeration)} +* * +************************************************************************ + +These are in \tr{state-interface.verb} order. +-} + +-- supplies: +-- data PrimOp = ... +#include "primop-data-decl.hs-incl" + +-- supplies +-- primOpTag :: PrimOp -> Int +#include "primop-tag.hs-incl" +primOpTag _ = error "primOpTag: unknown primop" + + +instance Eq PrimOp where + op1 == op2 = primOpTag op1 == primOpTag op2 + +instance Ord PrimOp where + op1 < op2 = primOpTag op1 < primOpTag op2 + op1 <= op2 = primOpTag op1 <= primOpTag op2 + op1 >= op2 = primOpTag op1 >= primOpTag op2 + op1 > op2 = primOpTag op1 > primOpTag op2 + op1 `compare` op2 | op1 < op2 = LT + | op1 == op2 = EQ + | otherwise = GT + +instance Outputable PrimOp where + ppr op = pprPrimOp op + +data PrimOpVecCat = IntVec + | WordVec + | FloatVec + +-- An @Enum@-derived list would be better; meanwhile... (ToDo) + +allThePrimOps :: [PrimOp] +allThePrimOps = +#include "primop-list.hs-incl" + +tagToEnumKey :: Unique +tagToEnumKey = mkPrimOpIdUnique (primOpTag TagToEnumOp) + +{- +************************************************************************ +* * +\subsection[PrimOp-info]{The essential info about each @PrimOp@} +* * +************************************************************************ + +The @String@ in the @PrimOpInfos@ is the ``base name'' by which the user may +refer to the primitive operation. The conventional \tr{#}-for- +unboxed ops is added on later. + +The reason for the funny characters in the names is so we do not +interfere with the programmer's Haskell name spaces. + +We use @PrimKinds@ for the ``type'' information, because they're +(slightly) more convenient to use than @TyCons@. +-} + +data PrimOpInfo + = Dyadic OccName -- string :: T -> T -> T + Type + | Monadic OccName -- string :: T -> T + Type + | Compare OccName -- string :: T -> T -> Int# + Type + | GenPrimOp OccName -- string :: \/a1..an . T1 -> .. -> Tk -> T + [TyVar] + [Type] + Type + +mkDyadic, mkMonadic, mkCompare :: FastString -> Type -> PrimOpInfo +mkDyadic str ty = Dyadic (mkVarOccFS str) ty +mkMonadic str ty = Monadic (mkVarOccFS str) ty +mkCompare str ty = Compare (mkVarOccFS str) ty + +mkGenPrimOp :: FastString -> [TyVar] -> [Type] -> Type -> PrimOpInfo +mkGenPrimOp str tvs tys ty = GenPrimOp (mkVarOccFS str) tvs tys ty + +{- +************************************************************************ +* * +\subsubsection{Strictness} +* * +************************************************************************ + +Not all primops are strict! +-} + +primOpStrictness :: PrimOp -> Arity -> StrictSig + -- See Demand.StrictnessInfo for discussion of what the results + -- The arity should be the arity of the primop; that's why + -- this function isn't exported. +#include "primop-strictness.hs-incl" + +{- +************************************************************************ +* * +\subsubsection{Fixity} +* * +************************************************************************ +-} + +primOpFixity :: PrimOp -> Maybe Fixity +#include "primop-fixity.hs-incl" + +{- +************************************************************************ +* * +\subsubsection[PrimOp-comparison]{PrimOpInfo basic comparison ops} +* * +************************************************************************ + +@primOpInfo@ gives all essential information (from which everything +else, notably a type, can be constructed) for each @PrimOp@. +-} + +primOpInfo :: PrimOp -> PrimOpInfo +#include "primop-primop-info.hs-incl" +primOpInfo _ = error "primOpInfo: unknown primop" + +{- +Here are a load of comments from the old primOp info: + +A @Word#@ is an unsigned @Int#@. + +@decodeFloat#@ is given w/ Integer-stuff (it's similar). + +@decodeDouble#@ is given w/ Integer-stuff (it's similar). + +Decoding of floating-point numbers is sorta Integer-related. Encoding +is done with plain ccalls now (see PrelNumExtra.hs). + +A @Weak@ Pointer is created by the @mkWeak#@ primitive: + + mkWeak# :: k -> v -> f -> State# RealWorld + -> (# State# RealWorld, Weak# v #) + +In practice, you'll use the higher-level + + data Weak v = Weak# v + mkWeak :: k -> v -> IO () -> IO (Weak v) + +The following operation dereferences a weak pointer. The weak pointer +may have been finalized, so the operation returns a result code which +must be inspected before looking at the dereferenced value. + + deRefWeak# :: Weak# v -> State# RealWorld -> + (# State# RealWorld, v, Int# #) + +Only look at v if the Int# returned is /= 0 !! + +The higher-level op is + + deRefWeak :: Weak v -> IO (Maybe v) + +Weak pointers can be finalized early by using the finalize# operation: + + finalizeWeak# :: Weak# v -> State# RealWorld -> + (# State# RealWorld, Int#, IO () #) + +The Int# returned is either + + 0 if the weak pointer has already been finalized, or it has no + finalizer (the third component is then invalid). + + 1 if the weak pointer is still alive, with the finalizer returned + as the third component. + +A {\em stable name/pointer} is an index into a table of stable name +entries. Since the garbage collector is told about stable pointers, +it is safe to pass a stable pointer to external systems such as C +routines. + +\begin{verbatim} +makeStablePtr# :: a -> State# RealWorld -> (# State# RealWorld, StablePtr# a #) +freeStablePtr :: StablePtr# a -> State# RealWorld -> State# RealWorld +deRefStablePtr# :: StablePtr# a -> State# RealWorld -> (# State# RealWorld, a #) +eqStablePtr# :: StablePtr# a -> StablePtr# a -> Int# +\end{verbatim} + +It may seem a bit surprising that @makeStablePtr#@ is a @IO@ +operation since it doesn't (directly) involve IO operations. The +reason is that if some optimisation pass decided to duplicate calls to +@makeStablePtr#@ and we only pass one of the stable pointers over, a +massive space leak can result. Putting it into the IO monad +prevents this. (Another reason for putting them in a monad is to +ensure correct sequencing wrt the side-effecting @freeStablePtr@ +operation.) + +An important property of stable pointers is that if you call +makeStablePtr# twice on the same object you get the same stable +pointer back. + +Note that we can implement @freeStablePtr#@ using @_ccall_@ (and, +besides, it's not likely to be used from Haskell) so it's not a +primop. + +Question: Why @RealWorld@ - won't any instance of @_ST@ do the job? [ADR] + +Stable Names +~~~~~~~~~~~~ + +A stable name is like a stable pointer, but with three important differences: + + (a) You can't deRef one to get back to the original object. + (b) You can convert one to an Int. + (c) You don't need to 'freeStableName' + +The existence of a stable name doesn't guarantee to keep the object it +points to alive (unlike a stable pointer), hence (a). + +Invariants: + + (a) makeStableName always returns the same value for a given + object (same as stable pointers). + + (b) if two stable names are equal, it implies that the objects + from which they were created were the same. + + (c) stableNameToInt always returns the same Int for a given + stable name. + + +These primops are pretty weird. + + tagToEnum# :: Int -> a (result type must be an enumerated type) + +The constraints aren't currently checked by the front end, but the +code generator will fall over if they aren't satisfied. + +************************************************************************ +* * + Which PrimOps are out-of-line +* * +************************************************************************ + +Some PrimOps need to be called out-of-line because they either need to +perform a heap check or they block. +-} + +primOpOutOfLine :: PrimOp -> Bool +#include "primop-out-of-line.hs-incl" + +{- +************************************************************************ +* * + Failure and side effects +* * +************************************************************************ + +Note [PrimOp can_fail and has_side_effects] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Both can_fail and has_side_effects mean that the primop has +some effect that is not captured entirely by its result value. + +---------- has_side_effects --------------------- +A primop "has_side_effects" if it has some *write* effect, visible +elsewhere + - writing to the world (I/O) + - writing to a mutable data structure (writeIORef) + - throwing a synchronous Haskell exception + +Often such primops have a type like + State -> input -> (State, output) +so the state token guarantees ordering. In general we rely *only* on +data dependencies of the state token to enforce write-effect ordering + + * NB1: if you inline unsafePerformIO, you may end up with + side-effecting ops whose 'state' output is discarded. + And programmers may do that by hand; see #9390. + That is why we (conservatively) do not discard write-effecting + primops even if both their state and result is discarded. + + * NB2: We consider primops, such as raiseIO#, that can raise a + (Haskell) synchronous exception to "have_side_effects" but not + "can_fail". We must be careful about not discarding such things; + see the paper "A semantics for imprecise exceptions". + + * NB3: *Read* effects (like reading an IORef) don't count here, + because it doesn't matter if we don't do them, or do them more than + once. *Sequencing* is maintained by the data dependency of the state + token. + +---------- can_fail ---------------------------- +A primop "can_fail" if it can fail with an *unchecked* exception on +some elements of its input domain. Main examples: + division (fails on zero demoninator) + array indexing (fails if the index is out of bounds) + +An "unchecked exception" is one that is an outright error, (not +turned into a Haskell exception,) such as seg-fault or +divide-by-zero error. Such can_fail primops are ALWAYS surrounded +with a test that checks for the bad cases, but we need to be +very careful about code motion that might move it out of +the scope of the test. + +Note [Transformations affected by can_fail and has_side_effects] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The can_fail and has_side_effects properties have the following effect +on program transformations. Summary table is followed by details. + + can_fail has_side_effects +Discard YES NO +Float in YES YES +Float out NO NO +Duplicate YES NO + +* Discarding. case (a `op` b) of _ -> rhs ===> rhs + You should not discard a has_side_effects primop; e.g. + case (writeIntArray# a i v s of (# _, _ #) -> True + Arguably you should be able to discard this, since the + returned stat token is not used, but that relies on NEVER + inlining unsafePerformIO, and programmers sometimes write + this kind of stuff by hand (#9390). So we (conservatively) + never discard a has_side_effects primop. + + However, it's fine to discard a can_fail primop. For example + case (indexIntArray# a i) of _ -> True + We can discard indexIntArray#; it has can_fail, but not + has_side_effects; see #5658 which was all about this. + Notice that indexIntArray# is (in a more general handling of + effects) read effect, but we don't care about that here, and + treat read effects as *not* has_side_effects. + + Similarly (a `/#` b) can be discarded. It can seg-fault or + cause a hardware exception, but not a synchronous Haskell + exception. + + + + Synchronous Haskell exceptions, e.g. from raiseIO#, are treated + as has_side_effects and hence are not discarded. + +* Float in. You can float a can_fail or has_side_effects primop + *inwards*, but not inside a lambda (see Duplication below). + +* Float out. You must not float a can_fail primop *outwards* lest + you escape the dynamic scope of the test. Example: + case d ># 0# of + True -> case x /# d of r -> r +# 1 + False -> 0 + Here we must not float the case outwards to give + case x/# d of r -> + case d ># 0# of + True -> r +# 1 + False -> 0 + + Nor can you float out a has_side_effects primop. For example: + if blah then case writeMutVar# v True s0 of (# s1 #) -> s1 + else s0 + Notice that s0 is mentioned in both branches of the 'if', but + only one of these two will actually be consumed. But if we + float out to + case writeMutVar# v True s0 of (# s1 #) -> + if blah then s1 else s0 + the writeMutVar will be performed in both branches, which is + utterly wrong. + +* Duplication. You cannot duplicate a has_side_effect primop. You + might wonder how this can occur given the state token threading, but + just look at Control.Monad.ST.Lazy.Imp.strictToLazy! We get + something like this + p = case readMutVar# s v of + (# s', r #) -> (S# s', r) + s' = case p of (s', r) -> s' + r = case p of (s', r) -> r + + (All these bindings are boxed.) If we inline p at its two call + sites, we get a catastrophe: because the read is performed once when + s' is demanded, and once when 'r' is demanded, which may be much + later. Utterly wrong. #3207 is real example of this happening. + + However, it's fine to duplicate a can_fail primop. That is really + the only difference between can_fail and has_side_effects. + +Note [Implementation: how can_fail/has_side_effects affect transformations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +How do we ensure that that floating/duplication/discarding are done right +in the simplifier? + +Two main predicates on primpops test these flags: + primOpOkForSideEffects <=> not has_side_effects + primOpOkForSpeculation <=> not (has_side_effects || can_fail) + + * The "no-float-out" thing is achieved by ensuring that we never + let-bind a can_fail or has_side_effects primop. The RHS of a + let-binding (which can float in and out freely) satisfies + exprOkForSpeculation; this is the let/app invariant. And + exprOkForSpeculation is false of can_fail and has_side_effects. + + * So can_fail and has_side_effects primops will appear only as the + scrutinees of cases, and that's why the FloatIn pass is capable + of floating case bindings inwards. + + * The no-duplicate thing is done via primOpIsCheap, by making + has_side_effects things (very very very) not-cheap! +-} + +primOpHasSideEffects :: PrimOp -> Bool +#include "primop-has-side-effects.hs-incl" + +primOpCanFail :: PrimOp -> Bool +#include "primop-can-fail.hs-incl" + +primOpOkForSpeculation :: PrimOp -> Bool + -- See Note [PrimOp can_fail and has_side_effects] + -- See comments with CoreUtils.exprOkForSpeculation + -- primOpOkForSpeculation => primOpOkForSideEffects +primOpOkForSpeculation op + = primOpOkForSideEffects op + && not (primOpOutOfLine op || primOpCanFail op) + -- I think the "out of line" test is because out of line things can + -- be expensive (eg sine, cosine), and so we may not want to speculate them + +primOpOkForSideEffects :: PrimOp -> Bool +primOpOkForSideEffects op + = not (primOpHasSideEffects op) + +{- +Note [primOpIsCheap] +~~~~~~~~~~~~~~~~~~~~ +@primOpIsCheap@, as used in \tr{SimplUtils.hs}. For now (HACK +WARNING), we just borrow some other predicates for a +what-should-be-good-enough test. "Cheap" means willing to call it more +than once, and/or push it inside a lambda. The latter could change the +behaviour of 'seq' for primops that can fail, so we don't treat them as cheap. +-} + +primOpIsCheap :: PrimOp -> Bool +-- See Note [PrimOp can_fail and has_side_effects] +primOpIsCheap op = primOpOkForSpeculation op +-- In March 2001, we changed this to +-- primOpIsCheap op = False +-- thereby making *no* primops seem cheap. But this killed eta +-- expansion on case (x ==# y) of True -> \s -> ... +-- which is bad. In particular a loop like +-- doLoop n = loop 0 +-- where +-- loop i | i == n = return () +-- | otherwise = bar i >> loop (i+1) +-- allocated a closure every time round because it doesn't eta expand. +-- +-- The problem that originally gave rise to the change was +-- let x = a +# b *# c in x +# x +-- were we don't want to inline x. But primopIsCheap doesn't control +-- that (it's exprIsDupable that does) so the problem doesn't occur +-- even if primOpIsCheap sometimes says 'True'. + +{- +************************************************************************ +* * + PrimOp code size +* * +************************************************************************ + +primOpCodeSize +~~~~~~~~~~~~~~ +Gives an indication of the code size of a primop, for the purposes of +calculating unfolding sizes; see CoreUnfold.sizeExpr. +-} + +primOpCodeSize :: PrimOp -> Int +#include "primop-code-size.hs-incl" + +primOpCodeSizeDefault :: Int +primOpCodeSizeDefault = 1 + -- CoreUnfold.primOpSize already takes into account primOpOutOfLine + -- and adds some further costs for the args in that case. + +primOpCodeSizeForeignCall :: Int +primOpCodeSizeForeignCall = 4 + +{- +************************************************************************ +* * + PrimOp types +* * +************************************************************************ +-} + +primOpType :: PrimOp -> Type -- you may want to use primOpSig instead +primOpType op + = case primOpInfo op of + Dyadic _occ ty -> dyadic_fun_ty ty + Monadic _occ ty -> monadic_fun_ty ty + Compare _occ ty -> compare_fun_ty ty + + GenPrimOp _occ tyvars arg_tys res_ty -> + mkSpecForAllTys tyvars (mkVisFunTys arg_tys res_ty) + +primOpOcc :: PrimOp -> OccName +primOpOcc op = case primOpInfo op of + Dyadic occ _ -> occ + Monadic occ _ -> occ + Compare occ _ -> occ + GenPrimOp occ _ _ _ -> occ + +isComparisonPrimOp :: PrimOp -> Bool +isComparisonPrimOp op = case primOpInfo op of + Compare {} -> True + _ -> False + +-- primOpSig is like primOpType but gives the result split apart: +-- (type variables, argument types, result type) +-- It also gives arity, strictness info + +primOpSig :: PrimOp -> ([TyVar], [Type], Type, Arity, StrictSig) +primOpSig op + = (tyvars, arg_tys, res_ty, arity, primOpStrictness op arity) + where + arity = length arg_tys + (tyvars, arg_tys, res_ty) + = case (primOpInfo op) of + Monadic _occ ty -> ([], [ty], ty ) + Dyadic _occ ty -> ([], [ty,ty], ty ) + Compare _occ ty -> ([], [ty,ty], intPrimTy) + GenPrimOp _occ tyvars arg_tys res_ty -> (tyvars, arg_tys, res_ty ) + +data PrimOpResultInfo + = ReturnsPrim PrimRep + | ReturnsAlg TyCon + +-- Some PrimOps need not return a manifest primitive or algebraic value +-- (i.e. they might return a polymorphic value). These PrimOps *must* +-- be out of line, or the code generator won't work. + +getPrimOpResultInfo :: PrimOp -> PrimOpResultInfo +getPrimOpResultInfo op + = case (primOpInfo op) of + Dyadic _ ty -> ReturnsPrim (typePrimRep1 ty) + Monadic _ ty -> ReturnsPrim (typePrimRep1 ty) + Compare _ _ -> ReturnsPrim (tyConPrimRep1 intPrimTyCon) + GenPrimOp _ _ _ ty | isPrimTyCon tc -> ReturnsPrim (tyConPrimRep1 tc) + | otherwise -> ReturnsAlg tc + where + tc = tyConAppTyCon ty + -- All primops return a tycon-app result + -- The tycon can be an unboxed tuple or sum, though, + -- which gives rise to a ReturnAlg + +{- +We do not currently make use of whether primops are commutable. + +We used to try to move constants to the right hand side for strength +reduction. +-} + +{- +commutableOp :: PrimOp -> Bool +#include "primop-commutable.hs-incl" +-} + +-- Utils: + +dyadic_fun_ty, monadic_fun_ty, compare_fun_ty :: Type -> Type +dyadic_fun_ty ty = mkVisFunTys [ty, ty] ty +monadic_fun_ty ty = mkVisFunTy ty ty +compare_fun_ty ty = mkVisFunTys [ty, ty] intPrimTy + +-- Output stuff: + +pprPrimOp :: PrimOp -> SDoc +pprPrimOp other_op = pprOccName (primOpOcc other_op) + +{- +************************************************************************ +* * +\subsubsection[PrimCall]{User-imported primitive calls} +* * +************************************************************************ +-} + +data PrimCall = PrimCall CLabelString UnitId + +instance Outputable PrimCall where + ppr (PrimCall lbl pkgId) + = text "__primcall" <+> ppr pkgId <+> ppr lbl diff --git a/compiler/prelude/PrimOp.hs-boot b/compiler/prelude/PrimOp.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/prelude/PrimOp.hs-boot @@ -0,0 +1,5 @@ +module PrimOp where + +import GhcPrelude () + +data PrimOp diff --git a/compiler/prelude/TysPrim.hs b/compiler/prelude/TysPrim.hs new file mode 100644 --- /dev/null +++ b/compiler/prelude/TysPrim.hs @@ -0,0 +1,1077 @@ +{- +(c) The AQUA Project, Glasgow University, 1994-1998 + + +\section[TysPrim]{Wired-in knowledge about primitive types} +-} + +{-# LANGUAGE CPP #-} + +-- | This module defines TyCons that can't be expressed in Haskell. +-- They are all, therefore, wired-in TyCons. C.f module TysWiredIn +module TysPrim( + mkPrimTyConName, -- For implicit parameters in TysWiredIn only + + mkTemplateKindVars, mkTemplateTyVars, mkTemplateTyVarsFrom, + mkTemplateKiTyVars, + + mkTemplateTyConBinders, mkTemplateKindTyConBinders, + mkTemplateAnonTyConBinders, + + alphaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar, + alphaTys, alphaTy, betaTy, gammaTy, deltaTy, + alphaTyVarsUnliftedRep, alphaTyVarUnliftedRep, + alphaTysUnliftedRep, alphaTyUnliftedRep, + runtimeRep1TyVar, runtimeRep2TyVar, runtimeRep1Ty, runtimeRep2Ty, + openAlphaTy, openBetaTy, openAlphaTyVar, openBetaTyVar, + + -- Kind constructors... + tYPETyCon, tYPETyConName, + + -- Kinds + tYPE, primRepToRuntimeRep, + + funTyCon, funTyConName, + unexposedPrimTyCons, exposedPrimTyCons, primTyCons, + + charPrimTyCon, charPrimTy, charPrimTyConName, + intPrimTyCon, intPrimTy, intPrimTyConName, + wordPrimTyCon, wordPrimTy, wordPrimTyConName, + addrPrimTyCon, addrPrimTy, addrPrimTyConName, + floatPrimTyCon, floatPrimTy, floatPrimTyConName, + doublePrimTyCon, doublePrimTy, doublePrimTyConName, + + voidPrimTyCon, voidPrimTy, + statePrimTyCon, mkStatePrimTy, + realWorldTyCon, realWorldTy, realWorldStatePrimTy, + + proxyPrimTyCon, mkProxyPrimTy, + + arrayPrimTyCon, mkArrayPrimTy, + byteArrayPrimTyCon, byteArrayPrimTy, + arrayArrayPrimTyCon, mkArrayArrayPrimTy, + smallArrayPrimTyCon, mkSmallArrayPrimTy, + mutableArrayPrimTyCon, mkMutableArrayPrimTy, + mutableByteArrayPrimTyCon, mkMutableByteArrayPrimTy, + mutableArrayArrayPrimTyCon, mkMutableArrayArrayPrimTy, + smallMutableArrayPrimTyCon, mkSmallMutableArrayPrimTy, + mutVarPrimTyCon, mkMutVarPrimTy, + + mVarPrimTyCon, mkMVarPrimTy, + tVarPrimTyCon, mkTVarPrimTy, + stablePtrPrimTyCon, mkStablePtrPrimTy, + stableNamePrimTyCon, mkStableNamePrimTy, + compactPrimTyCon, compactPrimTy, + bcoPrimTyCon, bcoPrimTy, + weakPrimTyCon, mkWeakPrimTy, + threadIdPrimTyCon, threadIdPrimTy, + + int8PrimTyCon, int8PrimTy, int8PrimTyConName, + word8PrimTyCon, word8PrimTy, word8PrimTyConName, + + int16PrimTyCon, int16PrimTy, int16PrimTyConName, + word16PrimTyCon, word16PrimTy, word16PrimTyConName, + + int32PrimTyCon, int32PrimTy, int32PrimTyConName, + word32PrimTyCon, word32PrimTy, word32PrimTyConName, + + int64PrimTyCon, int64PrimTy, int64PrimTyConName, + word64PrimTyCon, word64PrimTy, word64PrimTyConName, + + eqPrimTyCon, -- ty1 ~# ty2 + eqReprPrimTyCon, -- ty1 ~R# ty2 (at role Representational) + eqPhantPrimTyCon, -- ty1 ~P# ty2 (at role Phantom) + + -- * SIMD +#include "primop-vector-tys-exports.hs-incl" + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import {-# SOURCE #-} TysWiredIn + ( runtimeRepTy, unboxedTupleKind, liftedTypeKind + , vecRepDataConTyCon, tupleRepDataConTyCon + , liftedRepDataConTy, unliftedRepDataConTy, intRepDataConTy, int8RepDataConTy + , int16RepDataConTy, word16RepDataConTy + , wordRepDataConTy, int64RepDataConTy, word8RepDataConTy, word64RepDataConTy + , addrRepDataConTy + , floatRepDataConTy, doubleRepDataConTy + , vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy + , vec64DataConTy + , int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy + , int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy + , word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy + , doubleElemRepDataConTy + , mkPromotedListTy ) + +import Var ( TyVar, mkTyVar ) +import Name +import TyCon +import SrcLoc +import Unique +import PrelNames +import FastString +import Outputable +import TyCoRep -- Doesn't need special access, but this is easier to avoid + -- import loops which show up if you import Type instead + +import Data.Char + +{- +************************************************************************ +* * +\subsection{Primitive type constructors} +* * +************************************************************************ +-} + +primTyCons :: [TyCon] +primTyCons = unexposedPrimTyCons ++ exposedPrimTyCons + +-- | Primitive 'TyCon's that are defined in "GHC.Prim" but not exposed. +-- It's important to keep these separate as we don't want users to be able to +-- write them (see #15209) or see them in GHCi's @:browse@ output +-- (see #12023). +unexposedPrimTyCons :: [TyCon] +unexposedPrimTyCons + = [ eqPrimTyCon + , eqReprPrimTyCon + , eqPhantPrimTyCon + ] + +-- | Primitive 'TyCon's that are defined in, and exported from, "GHC.Prim". +exposedPrimTyCons :: [TyCon] +exposedPrimTyCons + = [ addrPrimTyCon + , arrayPrimTyCon + , byteArrayPrimTyCon + , arrayArrayPrimTyCon + , smallArrayPrimTyCon + , charPrimTyCon + , doublePrimTyCon + , floatPrimTyCon + , intPrimTyCon + , int8PrimTyCon + , int16PrimTyCon + , int32PrimTyCon + , int64PrimTyCon + , bcoPrimTyCon + , weakPrimTyCon + , mutableArrayPrimTyCon + , mutableByteArrayPrimTyCon + , mutableArrayArrayPrimTyCon + , smallMutableArrayPrimTyCon + , mVarPrimTyCon + , tVarPrimTyCon + , mutVarPrimTyCon + , realWorldTyCon + , stablePtrPrimTyCon + , stableNamePrimTyCon + , compactPrimTyCon + , statePrimTyCon + , voidPrimTyCon + , proxyPrimTyCon + , threadIdPrimTyCon + , wordPrimTyCon + , word8PrimTyCon + , word16PrimTyCon + , word32PrimTyCon + , word64PrimTyCon + + , tYPETyCon + +#include "primop-vector-tycons.hs-incl" + ] + +mkPrimTc :: FastString -> Unique -> TyCon -> Name +mkPrimTc fs unique tycon + = mkWiredInName gHC_PRIM (mkTcOccFS fs) + unique + (ATyCon tycon) -- Relevant TyCon + UserSyntax + +mkBuiltInPrimTc :: FastString -> Unique -> TyCon -> Name +mkBuiltInPrimTc fs unique tycon + = mkWiredInName gHC_PRIM (mkTcOccFS fs) + unique + (ATyCon tycon) -- Relevant TyCon + BuiltInSyntax + + +charPrimTyConName, intPrimTyConName, int8PrimTyConName, int16PrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word8PrimTyConName, word16PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, proxyPrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, smallArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, smallMutableArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, compactPrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, eqPhantPrimTyConName, voidPrimTyConName :: Name +charPrimTyConName = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon +intPrimTyConName = mkPrimTc (fsLit "Int#") intPrimTyConKey intPrimTyCon +int8PrimTyConName = mkPrimTc (fsLit "Int8#") int8PrimTyConKey int8PrimTyCon +int16PrimTyConName = mkPrimTc (fsLit "Int16#") int16PrimTyConKey int16PrimTyCon +int32PrimTyConName = mkPrimTc (fsLit "Int32#") int32PrimTyConKey int32PrimTyCon +int64PrimTyConName = mkPrimTc (fsLit "Int64#") int64PrimTyConKey int64PrimTyCon +wordPrimTyConName = mkPrimTc (fsLit "Word#") wordPrimTyConKey wordPrimTyCon +word8PrimTyConName = mkPrimTc (fsLit "Word8#") word8PrimTyConKey word8PrimTyCon +word16PrimTyConName = mkPrimTc (fsLit "Word16#") word16PrimTyConKey word16PrimTyCon +word32PrimTyConName = mkPrimTc (fsLit "Word32#") word32PrimTyConKey word32PrimTyCon +word64PrimTyConName = mkPrimTc (fsLit "Word64#") word64PrimTyConKey word64PrimTyCon +addrPrimTyConName = mkPrimTc (fsLit "Addr#") addrPrimTyConKey addrPrimTyCon +floatPrimTyConName = mkPrimTc (fsLit "Float#") floatPrimTyConKey floatPrimTyCon +doublePrimTyConName = mkPrimTc (fsLit "Double#") doublePrimTyConKey doublePrimTyCon +statePrimTyConName = mkPrimTc (fsLit "State#") statePrimTyConKey statePrimTyCon +voidPrimTyConName = mkPrimTc (fsLit "Void#") voidPrimTyConKey voidPrimTyCon +proxyPrimTyConName = mkPrimTc (fsLit "Proxy#") proxyPrimTyConKey proxyPrimTyCon +eqPrimTyConName = mkPrimTc (fsLit "~#") eqPrimTyConKey eqPrimTyCon +eqReprPrimTyConName = mkBuiltInPrimTc (fsLit "~R#") eqReprPrimTyConKey eqReprPrimTyCon +eqPhantPrimTyConName = mkBuiltInPrimTc (fsLit "~P#") eqPhantPrimTyConKey eqPhantPrimTyCon +realWorldTyConName = mkPrimTc (fsLit "RealWorld") realWorldTyConKey realWorldTyCon +arrayPrimTyConName = mkPrimTc (fsLit "Array#") arrayPrimTyConKey arrayPrimTyCon +byteArrayPrimTyConName = mkPrimTc (fsLit "ByteArray#") byteArrayPrimTyConKey byteArrayPrimTyCon +arrayArrayPrimTyConName = mkPrimTc (fsLit "ArrayArray#") arrayArrayPrimTyConKey arrayArrayPrimTyCon +smallArrayPrimTyConName = mkPrimTc (fsLit "SmallArray#") smallArrayPrimTyConKey smallArrayPrimTyCon +mutableArrayPrimTyConName = mkPrimTc (fsLit "MutableArray#") mutableArrayPrimTyConKey mutableArrayPrimTyCon +mutableByteArrayPrimTyConName = mkPrimTc (fsLit "MutableByteArray#") mutableByteArrayPrimTyConKey mutableByteArrayPrimTyCon +mutableArrayArrayPrimTyConName= mkPrimTc (fsLit "MutableArrayArray#") mutableArrayArrayPrimTyConKey mutableArrayArrayPrimTyCon +smallMutableArrayPrimTyConName= mkPrimTc (fsLit "SmallMutableArray#") smallMutableArrayPrimTyConKey smallMutableArrayPrimTyCon +mutVarPrimTyConName = mkPrimTc (fsLit "MutVar#") mutVarPrimTyConKey mutVarPrimTyCon +mVarPrimTyConName = mkPrimTc (fsLit "MVar#") mVarPrimTyConKey mVarPrimTyCon +tVarPrimTyConName = mkPrimTc (fsLit "TVar#") tVarPrimTyConKey tVarPrimTyCon +stablePtrPrimTyConName = mkPrimTc (fsLit "StablePtr#") stablePtrPrimTyConKey stablePtrPrimTyCon +stableNamePrimTyConName = mkPrimTc (fsLit "StableName#") stableNamePrimTyConKey stableNamePrimTyCon +compactPrimTyConName = mkPrimTc (fsLit "Compact#") compactPrimTyConKey compactPrimTyCon +bcoPrimTyConName = mkPrimTc (fsLit "BCO#") bcoPrimTyConKey bcoPrimTyCon +weakPrimTyConName = mkPrimTc (fsLit "Weak#") weakPrimTyConKey weakPrimTyCon +threadIdPrimTyConName = mkPrimTc (fsLit "ThreadId#") threadIdPrimTyConKey threadIdPrimTyCon + +{- +************************************************************************ +* * +\subsection{Support code} +* * +************************************************************************ + +alphaTyVars is a list of type variables for use in templates: + ["a", "b", ..., "z", "t1", "t2", ... ] +-} + +mkTemplateKindVars :: [Kind] -> [TyVar] +-- k0 with unique (mkAlphaTyVarUnique 0) +-- k1 with unique (mkAlphaTyVarUnique 1) +-- ... etc +mkTemplateKindVars [kind] + = [mkTyVar (mk_tv_name 0 "k") kind] + -- Special case for one kind: just "k" + +mkTemplateKindVars kinds + = [ mkTyVar (mk_tv_name u ('k' : show u)) kind + | (kind, u) <- kinds `zip` [0..] ] +mk_tv_name :: Int -> String -> Name +mk_tv_name u s = mkInternalName (mkAlphaTyVarUnique u) + (mkTyVarOccFS (mkFastString s)) + noSrcSpan + +mkTemplateTyVarsFrom :: Int -> [Kind] -> [TyVar] +-- a with unique (mkAlphaTyVarUnique n) +-- b with unique (mkAlphaTyVarUnique n+1) +-- ... etc +-- Typically called as +-- mkTemplateTyVarsFrom (length kv_bndrs) kinds +-- where kv_bndrs are the kind-level binders of a TyCon +mkTemplateTyVarsFrom n kinds + = [ mkTyVar name kind + | (kind, index) <- zip kinds [0..], + let ch_ord = index + ord 'a' + name_str | ch_ord <= ord 'z' = [chr ch_ord] + | otherwise = 't':show index + name = mk_tv_name (index + n) name_str + ] + +mkTemplateTyVars :: [Kind] -> [TyVar] +mkTemplateTyVars = mkTemplateTyVarsFrom 1 + +mkTemplateTyConBinders + :: [Kind] -- [k1, .., kn] Kinds of kind-forall'd vars + -> ([Kind] -> [Kind]) -- Arg is [kv1:k1, ..., kvn:kn] + -- same length as first arg + -- Result is anon arg kinds + -> [TyConBinder] +mkTemplateTyConBinders kind_var_kinds mk_anon_arg_kinds + = kv_bndrs ++ tv_bndrs + where + kv_bndrs = mkTemplateKindTyConBinders kind_var_kinds + anon_kinds = mk_anon_arg_kinds (mkTyVarTys (binderVars kv_bndrs)) + tv_bndrs = mkTemplateAnonTyConBindersFrom (length kv_bndrs) anon_kinds + +mkTemplateKiTyVars + :: [Kind] -- [k1, .., kn] Kinds of kind-forall'd vars + -> ([Kind] -> [Kind]) -- Arg is [kv1:k1, ..., kvn:kn] + -- same length as first arg + -- Result is anon arg kinds [ak1, .., akm] + -> [TyVar] -- [kv1:k1, ..., kvn:kn, av1:ak1, ..., avm:akm] +-- Example: if you want the tyvars for +-- forall (r:RuntimeRep) (a:TYPE r) (b:*). blah +-- call mkTemplateKiTyVars [RuntimeRep] (\[r]. [TYPE r, *) +mkTemplateKiTyVars kind_var_kinds mk_arg_kinds + = kv_bndrs ++ tv_bndrs + where + kv_bndrs = mkTemplateKindVars kind_var_kinds + anon_kinds = mk_arg_kinds (mkTyVarTys kv_bndrs) + tv_bndrs = mkTemplateTyVarsFrom (length kv_bndrs) anon_kinds + +mkTemplateKindTyConBinders :: [Kind] -> [TyConBinder] +-- Makes named, Specified binders +mkTemplateKindTyConBinders kinds = [mkNamedTyConBinder Specified tv | tv <- mkTemplateKindVars kinds] + +mkTemplateAnonTyConBinders :: [Kind] -> [TyConBinder] +mkTemplateAnonTyConBinders kinds = mkAnonTyConBinders VisArg (mkTemplateTyVars kinds) + +mkTemplateAnonTyConBindersFrom :: Int -> [Kind] -> [TyConBinder] +mkTemplateAnonTyConBindersFrom n kinds = mkAnonTyConBinders VisArg (mkTemplateTyVarsFrom n kinds) + +alphaTyVars :: [TyVar] +alphaTyVars = mkTemplateTyVars $ repeat liftedTypeKind + +alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar :: TyVar +(alphaTyVar:betaTyVar:gammaTyVar:deltaTyVar:_) = alphaTyVars + +alphaTys :: [Type] +alphaTys = mkTyVarTys alphaTyVars +alphaTy, betaTy, gammaTy, deltaTy :: Type +(alphaTy:betaTy:gammaTy:deltaTy:_) = alphaTys + +alphaTyVarsUnliftedRep :: [TyVar] +alphaTyVarsUnliftedRep = mkTemplateTyVars $ repeat (tYPE unliftedRepDataConTy) + +alphaTyVarUnliftedRep :: TyVar +(alphaTyVarUnliftedRep:_) = alphaTyVarsUnliftedRep + +alphaTysUnliftedRep :: [Type] +alphaTysUnliftedRep = mkTyVarTys alphaTyVarsUnliftedRep +alphaTyUnliftedRep :: Type +(alphaTyUnliftedRep:_) = alphaTysUnliftedRep + +runtimeRep1TyVar, runtimeRep2TyVar :: TyVar +(runtimeRep1TyVar : runtimeRep2TyVar : _) + = drop 16 (mkTemplateTyVars (repeat runtimeRepTy)) -- selects 'q','r' + +runtimeRep1Ty, runtimeRep2Ty :: Type +runtimeRep1Ty = mkTyVarTy runtimeRep1TyVar +runtimeRep2Ty = mkTyVarTy runtimeRep2TyVar + +openAlphaTyVar, openBetaTyVar :: TyVar +[openAlphaTyVar,openBetaTyVar] + = mkTemplateTyVars [tYPE runtimeRep1Ty, tYPE runtimeRep2Ty] + +openAlphaTy, openBetaTy :: Type +openAlphaTy = mkTyVarTy openAlphaTyVar +openBetaTy = mkTyVarTy openBetaTyVar + +{- +************************************************************************ +* * + FunTyCon +* * +************************************************************************ +-} + +funTyConName :: Name +funTyConName = mkPrimTyConName (fsLit "->") funTyConKey funTyCon + +-- | The @(->)@ type constructor. +-- +-- @ +-- (->) :: forall (rep1 :: RuntimeRep) (rep2 :: RuntimeRep). +-- TYPE rep1 -> TYPE rep2 -> * +-- @ +funTyCon :: TyCon +funTyCon = mkFunTyCon funTyConName tc_bndrs tc_rep_nm + where + tc_bndrs = [ mkNamedTyConBinder Inferred runtimeRep1TyVar + , mkNamedTyConBinder Inferred runtimeRep2TyVar ] + ++ mkTemplateAnonTyConBinders [ tYPE runtimeRep1Ty + , tYPE runtimeRep2Ty + ] + tc_rep_nm = mkPrelTyConRepName funTyConName + +{- +************************************************************************ +* * + Kinds +* * +************************************************************************ + +Note [TYPE and RuntimeRep] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +All types that classify values have a kind of the form (TYPE rr), where + + data RuntimeRep -- Defined in ghc-prim:GHC.Types + = LiftedRep + | UnliftedRep + | IntRep + | FloatRep + .. etc .. + + rr :: RuntimeRep + + TYPE :: RuntimeRep -> TYPE 'LiftedRep -- Built in + +So for example: + Int :: TYPE 'LiftedRep + Array# Int :: TYPE 'UnliftedRep + Int# :: TYPE 'IntRep + Float# :: TYPE 'FloatRep + Maybe :: TYPE 'LiftedRep -> TYPE 'LiftedRep + (# , #) :: TYPE r1 -> TYPE r2 -> TYPE (TupleRep [r1, r2]) + +We abbreviate '*' specially: + type * = TYPE 'LiftedRep + +The 'rr' parameter tells us how the value is represented at runime. + +Generally speaking, you can't be polymorphic in 'rr'. E.g + f :: forall (rr:RuntimeRep) (a:TYPE rr). a -> [a] + f = /\(rr:RuntimeRep) (a:rr) \(a:rr). ... +This is no good: we could not generate code code for 'f', because the +calling convention for 'f' varies depending on whether the argument is +a a Int, Int#, or Float#. (You could imagine generating specialised +code, one for each instantiation of 'rr', but we don't do that.) + +Certain functions CAN be runtime-rep-polymorphic, because the code +generator never has to manipulate a value of type 'a :: TYPE rr'. + +* error :: forall (rr:RuntimeRep) (a:TYPE rr). String -> a + Code generator never has to manipulate the return value. + +* unsafeCoerce#, defined in MkId.unsafeCoerceId: + Always inlined to be a no-op + unsafeCoerce# :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) + (a :: TYPE r1) (b :: TYPE r2). + a -> b + +* Unboxed tuples, and unboxed sums, defined in TysWiredIn + Always inlined, and hence specialised to the call site + (#,#) :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) + (a :: TYPE r1) (b :: TYPE r2). + a -> b -> TYPE ('TupleRep '[r1, r2]) + +Note [PrimRep and kindPrimRep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As part of its source code, in TyCon, GHC has + data PrimRep = LiftedRep | UnliftedRep | IntRep | FloatRep | ...etc... + +Notice that + * RuntimeRep is part of the syntax tree of the program being compiled + (defined in a library: ghc-prim:GHC.Types) + * PrimRep is part of GHC's source code. + (defined in TyCon) + +We need to get from one to the other; that is what kindPrimRep does. +Suppose we have a value + (v :: t) where (t :: k) +Given this kind + k = TyConApp "TYPE" [rep] +GHC needs to be able to figure out how 'v' is represented at runtime. +It expects 'rep' to be form + TyConApp rr_dc args +where 'rr_dc' is a promoteed data constructor from RuntimeRep. So +now we need to go from 'dc' to the corresponding PrimRep. We store this +PrimRep in the promoted data constructor itself: see TyCon.promDcRepInfo. + +-} + +tYPETyCon :: TyCon +tYPETyConName :: Name + +tYPETyCon = mkKindTyCon tYPETyConName + (mkTemplateAnonTyConBinders [runtimeRepTy]) + liftedTypeKind + [Nominal] + (mkPrelTyConRepName tYPETyConName) + +-------------------------- +-- ... and now their names + +-- If you edit these, you may need to update the GHC formalism +-- See Note [GHC Formalism] in coreSyn/CoreLint.hs +tYPETyConName = mkPrimTyConName (fsLit "TYPE") tYPETyConKey tYPETyCon + +mkPrimTyConName :: FastString -> Unique -> TyCon -> Name +mkPrimTyConName = mkPrimTcName BuiltInSyntax + -- All of the super kinds and kinds are defined in Prim, + -- and use BuiltInSyntax, because they are never in scope in the source + +mkPrimTcName :: BuiltInSyntax -> FastString -> Unique -> TyCon -> Name +mkPrimTcName built_in_syntax occ key tycon + = mkWiredInName gHC_PRIM (mkTcOccFS occ) key (ATyCon tycon) built_in_syntax + +----------------------------- +-- | Given a RuntimeRep, applies TYPE to it. +-- see Note [TYPE and RuntimeRep] +tYPE :: Type -> Type +tYPE rr = TyConApp tYPETyCon [rr] + +{- +************************************************************************ +* * +\subsection[TysPrim-basic]{Basic primitive types (@Char#@, @Int#@, etc.)} +* * +************************************************************************ +-} + +-- only used herein +pcPrimTyCon :: Name -> [Role] -> PrimRep -> TyCon +pcPrimTyCon name roles rep + = mkPrimTyCon name binders result_kind roles + where + binders = mkTemplateAnonTyConBinders (map (const liftedTypeKind) roles) + result_kind = tYPE (primRepToRuntimeRep rep) + +-- | Convert a 'PrimRep' to a 'Type' of kind RuntimeRep +-- Defined here to avoid (more) module loops +primRepToRuntimeRep :: PrimRep -> Type +primRepToRuntimeRep rep = case rep of + VoidRep -> TyConApp tupleRepDataConTyCon [mkPromotedListTy runtimeRepTy []] + LiftedRep -> liftedRepDataConTy + UnliftedRep -> unliftedRepDataConTy + IntRep -> intRepDataConTy + Int8Rep -> int8RepDataConTy + Int16Rep -> int16RepDataConTy + WordRep -> wordRepDataConTy + Int64Rep -> int64RepDataConTy + Word8Rep -> word8RepDataConTy + Word16Rep -> word16RepDataConTy + Word64Rep -> word64RepDataConTy + AddrRep -> addrRepDataConTy + FloatRep -> floatRepDataConTy + DoubleRep -> doubleRepDataConTy + VecRep n elem -> TyConApp vecRepDataConTyCon [n', elem'] + where + n' = case n of + 2 -> vec2DataConTy + 4 -> vec4DataConTy + 8 -> vec8DataConTy + 16 -> vec16DataConTy + 32 -> vec32DataConTy + 64 -> vec64DataConTy + _ -> pprPanic "Disallowed VecCount" (ppr n) + + elem' = case elem of + Int8ElemRep -> int8ElemRepDataConTy + Int16ElemRep -> int16ElemRepDataConTy + Int32ElemRep -> int32ElemRepDataConTy + Int64ElemRep -> int64ElemRepDataConTy + Word8ElemRep -> word8ElemRepDataConTy + Word16ElemRep -> word16ElemRepDataConTy + Word32ElemRep -> word32ElemRepDataConTy + Word64ElemRep -> word64ElemRepDataConTy + FloatElemRep -> floatElemRepDataConTy + DoubleElemRep -> doubleElemRepDataConTy + +pcPrimTyCon0 :: Name -> PrimRep -> TyCon +pcPrimTyCon0 name rep + = pcPrimTyCon name [] rep + +charPrimTy :: Type +charPrimTy = mkTyConTy charPrimTyCon +charPrimTyCon :: TyCon +charPrimTyCon = pcPrimTyCon0 charPrimTyConName WordRep + +intPrimTy :: Type +intPrimTy = mkTyConTy intPrimTyCon +intPrimTyCon :: TyCon +intPrimTyCon = pcPrimTyCon0 intPrimTyConName IntRep + +int8PrimTy :: Type +int8PrimTy = mkTyConTy int8PrimTyCon +int8PrimTyCon :: TyCon +int8PrimTyCon = pcPrimTyCon0 int8PrimTyConName Int8Rep + +int16PrimTy :: Type +int16PrimTy = mkTyConTy int16PrimTyCon +int16PrimTyCon :: TyCon +int16PrimTyCon = pcPrimTyCon0 int16PrimTyConName Int16Rep + +int32PrimTy :: Type +int32PrimTy = mkTyConTy int32PrimTyCon +int32PrimTyCon :: TyCon +int32PrimTyCon = pcPrimTyCon0 int32PrimTyConName IntRep + +int64PrimTy :: Type +int64PrimTy = mkTyConTy int64PrimTyCon +int64PrimTyCon :: TyCon +int64PrimTyCon = pcPrimTyCon0 int64PrimTyConName Int64Rep + +wordPrimTy :: Type +wordPrimTy = mkTyConTy wordPrimTyCon +wordPrimTyCon :: TyCon +wordPrimTyCon = pcPrimTyCon0 wordPrimTyConName WordRep + +word8PrimTy :: Type +word8PrimTy = mkTyConTy word8PrimTyCon +word8PrimTyCon :: TyCon +word8PrimTyCon = pcPrimTyCon0 word8PrimTyConName Word8Rep + +word16PrimTy :: Type +word16PrimTy = mkTyConTy word16PrimTyCon +word16PrimTyCon :: TyCon +word16PrimTyCon = pcPrimTyCon0 word16PrimTyConName Word16Rep + +word32PrimTy :: Type +word32PrimTy = mkTyConTy word32PrimTyCon +word32PrimTyCon :: TyCon +word32PrimTyCon = pcPrimTyCon0 word32PrimTyConName WordRep + +word64PrimTy :: Type +word64PrimTy = mkTyConTy word64PrimTyCon +word64PrimTyCon :: TyCon +word64PrimTyCon = pcPrimTyCon0 word64PrimTyConName Word64Rep + +addrPrimTy :: Type +addrPrimTy = mkTyConTy addrPrimTyCon +addrPrimTyCon :: TyCon +addrPrimTyCon = pcPrimTyCon0 addrPrimTyConName AddrRep + +floatPrimTy :: Type +floatPrimTy = mkTyConTy floatPrimTyCon +floatPrimTyCon :: TyCon +floatPrimTyCon = pcPrimTyCon0 floatPrimTyConName FloatRep + +doublePrimTy :: Type +doublePrimTy = mkTyConTy doublePrimTyCon +doublePrimTyCon :: TyCon +doublePrimTyCon = pcPrimTyCon0 doublePrimTyConName DoubleRep + +{- +************************************************************************ +* * +\subsection[TysPrim-state]{The @State#@ type (and @_RealWorld@ types)} +* * +************************************************************************ + +Note [The equality types story] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC sports a veritable menagerie of equality types: + + Type or Lifted? Hetero? Role Built in Defining module + class? L/U TyCon +----------------------------------------------------------------------------------------- +~# T U hetero nominal eqPrimTyCon GHC.Prim +~~ C L hetero nominal heqTyCon GHC.Types +~ C L homo nominal eqTyCon GHC.Types +:~: T L homo nominal (not built-in) Data.Type.Equality +:~~: T L hetero nominal (not built-in) Data.Type.Equality + +~R# T U hetero repr eqReprPrimTy GHC.Prim +Coercible C L homo repr coercibleTyCon GHC.Types +Coercion T L homo repr (not built-in) Data.Type.Coercion +~P# T U hetero phantom eqPhantPrimTyCon GHC.Prim + +Recall that "hetero" means the equality can related types of different +kinds. Knowing that (t1 ~# t2) or (t1 ~R# t2) or even that (t1 ~P# t2) +also means that (k1 ~# k2), where (t1 :: k1) and (t2 :: k2). + +To produce less confusion for end users, when not dumping and without +-fprint-equality-relations, each of these groups is printed as the bottommost +listed equality. That is, (~#) and (~~) are both rendered as (~) in +error messages, and (~R#) is rendered as Coercible. + +Let's take these one at a time: + + -------------------------- + (~#) :: forall k1 k2. k1 -> k2 -> # + -------------------------- +This is The Type Of Equality in GHC. It classifies nominal coercions. +This type is used in the solver for recording equality constraints. +It responds "yes" to Type.isEqPrimPred and classifies as an EqPred in +Type.classifyPredType. + +All wanted constraints of this type are built with coercion holes. +(See Note [Coercion holes] in TyCoRep.) But see also +Note [Deferred errors for coercion holes] in TcErrors to see how +equality constraints are deferred. + +Within GHC, ~# is called eqPrimTyCon, and it is defined in TysPrim. + + + -------------------------- + (~~) :: forall k1 k2. k1 -> k2 -> Constraint + -------------------------- +This is (almost) an ordinary class, defined as if by + class a ~# b => a ~~ b + instance a ~# b => a ~~ b +Here's what's unusual about it: + + * We can't actually declare it that way because we don't have syntax for ~#. + And ~# isn't a constraint, so even if we could write it, it wouldn't kind + check. + + * Users cannot write instances of it. + + * It is "naturally coherent". This means that the solver won't hesitate to + solve a goal of type (a ~~ b) even if there is, say (Int ~~ c) in the + context. (Normally, it waits to learn more, just in case the given + influences what happens next.) See Note [Naturally coherent classes] + in TcInteract. + + * It always terminates. That is, in the UndecidableInstances checks, we + don't worry if a (~~) constraint is too big, as we know that solving + equality terminates. + +On the other hand, this behaves just like any class w.r.t. eager superclass +unpacking in the solver. So a lifted equality given quickly becomes an unlifted +equality given. This is good, because the solver knows all about unlifted +equalities. There is some special-casing in TcInteract.matchClassInst to +pretend that there is an instance of this class, as we can't write the instance +in Haskell. + +Within GHC, ~~ is called heqTyCon, and it is defined in TysWiredIn. + + + -------------------------- + (~) :: forall k. k -> k -> Constraint + -------------------------- +This is /exactly/ like (~~), except with a homogeneous kind. +It is an almost-ordinary class defined as if by + class a ~# b => (a :: k) ~ (b :: k) + instance a ~# b => a ~ b + + * All the bullets for (~~) apply + + * In addition (~) is magical syntax, as ~ is a reserved symbol. + It cannot be exported or imported. + +Within GHC, ~ is called eqTyCon, and it is defined in TysWiredIn. + +Historical note: prior to July 18 (~) was defined as a + more-ordinary class with (~~) as a superclass. But that made it + special in different ways; and the extra superclass selections to + get from (~) to (~#) via (~~) were tiresome. Now it's defined + uniformly with (~~) and Coercible; much nicer.) + + + -------------------------- + (:~:) :: forall k. k -> k -> * + (:~~:) :: forall k1 k2. k1 -> k2 -> * + -------------------------- +These are perfectly ordinary GADTs, wrapping (~) and (~~) resp. +They are not defined within GHC at all. + + + -------------------------- + (~R#) :: forall k1 k2. k1 -> k2 -> # + -------------------------- +The is the representational analogue of ~#. This is the type of representational +equalities that the solver works on. All wanted constraints of this type are +built with coercion holes. + +Within GHC, ~R# is called eqReprPrimTyCon, and it is defined in TysPrim. + + + -------------------------- + Coercible :: forall k. k -> k -> Constraint + -------------------------- +This is quite like (~~) in the way it's defined and treated within GHC, but +it's homogeneous. Homogeneity helps with type inference (as GHC can solve one +kind from the other) and, in my (Richard's) estimation, will be more intuitive +for users. + +An alternative design included HCoercible (like (~~)) and Coercible (like (~)). +One annoyance was that we want `coerce :: Coercible a b => a -> b`, and +we need the type of coerce to be fully wired-in. So the HCoercible/Coercible +split required that both types be fully wired-in. Instead of doing this, +I just got rid of HCoercible, as I'm not sure who would use it, anyway. + +Within GHC, Coercible is called coercibleTyCon, and it is defined in +TysWiredIn. + + + -------------------------- + Coercion :: forall k. k -> k -> * + -------------------------- +This is a perfectly ordinary GADT, wrapping Coercible. It is not defined +within GHC at all. + + + -------------------------- + (~P#) :: forall k1 k2. k1 -> k2 -> # + -------------------------- +This is the phantom analogue of ~# and it is barely used at all. +(The solver has no idea about this one.) Here is the motivation: + + data Phant a = MkPhant + type role Phant phantom + + Phant _P :: Phant Int ~P# Phant Bool + +We just need to have something to put on that last line. You probably +don't need to worry about it. + + + +Note [The State# TyCon] +~~~~~~~~~~~~~~~~~~~~~~~ +State# is the primitive, unlifted type of states. It has one type parameter, +thus + State# RealWorld +or + State# s + +where s is a type variable. The only purpose of the type parameter is to +keep different state threads separate. It is represented by nothing at all. + +The type parameter to State# is intended to keep separate threads separate. +Even though this parameter is not used in the definition of State#, it is +given role Nominal to enforce its intended use. +-} + +mkStatePrimTy :: Type -> Type +mkStatePrimTy ty = TyConApp statePrimTyCon [ty] + +statePrimTyCon :: TyCon -- See Note [The State# TyCon] +statePrimTyCon = pcPrimTyCon statePrimTyConName [Nominal] VoidRep + +{- +RealWorld is deeply magical. It is *primitive*, but it is not +*unlifted* (hence ptrArg). We never manipulate values of type +RealWorld; it's only used in the type system, to parameterise State#. +-} + +realWorldTyCon :: TyCon +realWorldTyCon = mkLiftedPrimTyCon realWorldTyConName [] liftedTypeKind [] +realWorldTy :: Type +realWorldTy = mkTyConTy realWorldTyCon +realWorldStatePrimTy :: Type +realWorldStatePrimTy = mkStatePrimTy realWorldTy -- State# RealWorld + +-- Note: the ``state-pairing'' types are not truly primitive, +-- so they are defined in \tr{TysWiredIn.hs}, not here. + + +voidPrimTy :: Type +voidPrimTy = TyConApp voidPrimTyCon [] + +voidPrimTyCon :: TyCon +voidPrimTyCon = pcPrimTyCon voidPrimTyConName [] VoidRep + +mkProxyPrimTy :: Type -> Type -> Type +mkProxyPrimTy k ty = TyConApp proxyPrimTyCon [k, ty] + +proxyPrimTyCon :: TyCon +proxyPrimTyCon = mkPrimTyCon proxyPrimTyConName binders res_kind [Nominal,Phantom] + where + -- Kind: forall k. k -> TYPE (Tuple '[]) + binders = mkTemplateTyConBinders [liftedTypeKind] id + res_kind = unboxedTupleKind [] + + +{- ********************************************************************* +* * + Primitive equality constraints + See Note [The equality types story] +* * +********************************************************************* -} + +eqPrimTyCon :: TyCon -- The representation type for equality predicates + -- See Note [The equality types story] +eqPrimTyCon = mkPrimTyCon eqPrimTyConName binders res_kind roles + where + -- Kind :: forall k1 k2. k1 -> k2 -> TYPE (Tuple '[]) + binders = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id + res_kind = unboxedTupleKind [] + roles = [Nominal, Nominal, Nominal, Nominal] + +-- like eqPrimTyCon, but the type for *Representational* coercions +-- this should only ever appear as the type of a covar. Its role is +-- interpreted in coercionRole +eqReprPrimTyCon :: TyCon -- See Note [The equality types story] +eqReprPrimTyCon = mkPrimTyCon eqReprPrimTyConName binders res_kind roles + where + -- Kind :: forall k1 k2. k1 -> k2 -> TYPE (Tuple '[]) + binders = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id + res_kind = unboxedTupleKind [] + roles = [Nominal, Nominal, Representational, Representational] + +-- like eqPrimTyCon, but the type for *Phantom* coercions. +-- This is only used to make higher-order equalities. Nothing +-- should ever actually have this type! +eqPhantPrimTyCon :: TyCon +eqPhantPrimTyCon = mkPrimTyCon eqPhantPrimTyConName binders res_kind roles + where + -- Kind :: forall k1 k2. k1 -> k2 -> TYPE (Tuple '[]) + binders = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id + res_kind = unboxedTupleKind [] + roles = [Nominal, Nominal, Phantom, Phantom] + +{- ********************************************************************* +* * + The primitive array types +* * +********************************************************************* -} + +arrayPrimTyCon, mutableArrayPrimTyCon, mutableByteArrayPrimTyCon, + byteArrayPrimTyCon, arrayArrayPrimTyCon, mutableArrayArrayPrimTyCon, + smallArrayPrimTyCon, smallMutableArrayPrimTyCon :: TyCon +arrayPrimTyCon = pcPrimTyCon arrayPrimTyConName [Representational] UnliftedRep +mutableArrayPrimTyCon = pcPrimTyCon mutableArrayPrimTyConName [Nominal, Representational] UnliftedRep +mutableByteArrayPrimTyCon = pcPrimTyCon mutableByteArrayPrimTyConName [Nominal] UnliftedRep +byteArrayPrimTyCon = pcPrimTyCon0 byteArrayPrimTyConName UnliftedRep +arrayArrayPrimTyCon = pcPrimTyCon0 arrayArrayPrimTyConName UnliftedRep +mutableArrayArrayPrimTyCon = pcPrimTyCon mutableArrayArrayPrimTyConName [Nominal] UnliftedRep +smallArrayPrimTyCon = pcPrimTyCon smallArrayPrimTyConName [Representational] UnliftedRep +smallMutableArrayPrimTyCon = pcPrimTyCon smallMutableArrayPrimTyConName [Nominal, Representational] UnliftedRep + +mkArrayPrimTy :: Type -> Type +mkArrayPrimTy elt = TyConApp arrayPrimTyCon [elt] +byteArrayPrimTy :: Type +byteArrayPrimTy = mkTyConTy byteArrayPrimTyCon +mkArrayArrayPrimTy :: Type +mkArrayArrayPrimTy = mkTyConTy arrayArrayPrimTyCon +mkSmallArrayPrimTy :: Type -> Type +mkSmallArrayPrimTy elt = TyConApp smallArrayPrimTyCon [elt] +mkMutableArrayPrimTy :: Type -> Type -> Type +mkMutableArrayPrimTy s elt = TyConApp mutableArrayPrimTyCon [s, elt] +mkMutableByteArrayPrimTy :: Type -> Type +mkMutableByteArrayPrimTy s = TyConApp mutableByteArrayPrimTyCon [s] +mkMutableArrayArrayPrimTy :: Type -> Type +mkMutableArrayArrayPrimTy s = TyConApp mutableArrayArrayPrimTyCon [s] +mkSmallMutableArrayPrimTy :: Type -> Type -> Type +mkSmallMutableArrayPrimTy s elt = TyConApp smallMutableArrayPrimTyCon [s, elt] + + +{- ********************************************************************* +* * + The mutable variable type +* * +********************************************************************* -} + +mutVarPrimTyCon :: TyCon +mutVarPrimTyCon = pcPrimTyCon mutVarPrimTyConName [Nominal, Representational] UnliftedRep + +mkMutVarPrimTy :: Type -> Type -> Type +mkMutVarPrimTy s elt = TyConApp mutVarPrimTyCon [s, elt] + +{- +************************************************************************ +* * +\subsection[TysPrim-synch-var]{The synchronizing variable type} +* * +************************************************************************ +-} + +mVarPrimTyCon :: TyCon +mVarPrimTyCon = pcPrimTyCon mVarPrimTyConName [Nominal, Representational] UnliftedRep + +mkMVarPrimTy :: Type -> Type -> Type +mkMVarPrimTy s elt = TyConApp mVarPrimTyCon [s, elt] + +{- +************************************************************************ +* * +\subsection[TysPrim-stm-var]{The transactional variable type} +* * +************************************************************************ +-} + +tVarPrimTyCon :: TyCon +tVarPrimTyCon = pcPrimTyCon tVarPrimTyConName [Nominal, Representational] UnliftedRep + +mkTVarPrimTy :: Type -> Type -> Type +mkTVarPrimTy s elt = TyConApp tVarPrimTyCon [s, elt] + +{- +************************************************************************ +* * +\subsection[TysPrim-stable-ptrs]{The stable-pointer type} +* * +************************************************************************ +-} + +stablePtrPrimTyCon :: TyCon +stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConName [Representational] AddrRep + +mkStablePtrPrimTy :: Type -> Type +mkStablePtrPrimTy ty = TyConApp stablePtrPrimTyCon [ty] + +{- +************************************************************************ +* * +\subsection[TysPrim-stable-names]{The stable-name type} +* * +************************************************************************ +-} + +stableNamePrimTyCon :: TyCon +stableNamePrimTyCon = pcPrimTyCon stableNamePrimTyConName [Phantom] UnliftedRep + +mkStableNamePrimTy :: Type -> Type +mkStableNamePrimTy ty = TyConApp stableNamePrimTyCon [ty] + +{- +************************************************************************ +* * +\subsection[TysPrim-compact-nfdata]{The Compact NFData (CNF) type} +* * +************************************************************************ +-} + +compactPrimTyCon :: TyCon +compactPrimTyCon = pcPrimTyCon0 compactPrimTyConName UnliftedRep + +compactPrimTy :: Type +compactPrimTy = mkTyConTy compactPrimTyCon + +{- +************************************************************************ +* * +\subsection[TysPrim-BCOs]{The ``bytecode object'' type} +* * +************************************************************************ +-} + +bcoPrimTy :: Type +bcoPrimTy = mkTyConTy bcoPrimTyCon +bcoPrimTyCon :: TyCon +bcoPrimTyCon = pcPrimTyCon0 bcoPrimTyConName UnliftedRep + +{- +************************************************************************ +* * +\subsection[TysPrim-Weak]{The ``weak pointer'' type} +* * +************************************************************************ +-} + +weakPrimTyCon :: TyCon +weakPrimTyCon = pcPrimTyCon weakPrimTyConName [Representational] UnliftedRep + +mkWeakPrimTy :: Type -> Type +mkWeakPrimTy v = TyConApp weakPrimTyCon [v] + +{- +************************************************************************ +* * +\subsection[TysPrim-thread-ids]{The ``thread id'' type} +* * +************************************************************************ + +A thread id is represented by a pointer to the TSO itself, to ensure +that they are always unique and we can always find the TSO for a given +thread id. However, this has the unfortunate consequence that a +ThreadId# for a given thread is treated as a root by the garbage +collector and can keep TSOs around for too long. + +Hence the programmer API for thread manipulation uses a weak pointer +to the thread id internally. +-} + +threadIdPrimTy :: Type +threadIdPrimTy = mkTyConTy threadIdPrimTyCon +threadIdPrimTyCon :: TyCon +threadIdPrimTyCon = pcPrimTyCon0 threadIdPrimTyConName UnliftedRep + +{- +************************************************************************ +* * +\subsection{SIMD vector types} +* * +************************************************************************ +-} + +#include "primop-vector-tys.hs-incl" diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs new file mode 100644 --- /dev/null +++ b/compiler/prelude/TysWiredIn.hs @@ -0,0 +1,1627 @@ +{- +(c) The GRASP Project, Glasgow University, 1994-1998 + +\section[TysWiredIn]{Wired-in knowledge about {\em non-primitive} types} +-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | This module is about types that can be defined in Haskell, but which +-- must be wired into the compiler nonetheless. C.f module TysPrim +module TysWiredIn ( + -- * Helper functions defined here + mkWiredInTyConName, -- This is used in TcTypeNats to define the + -- built-in functions for evaluation. + + mkWiredInIdName, -- used in MkId + + -- * All wired in things + wiredInTyCons, isBuiltInOcc_maybe, + + -- * Bool + boolTy, boolTyCon, boolTyCon_RDR, boolTyConName, + trueDataCon, trueDataConId, true_RDR, + falseDataCon, falseDataConId, false_RDR, + promotedFalseDataCon, promotedTrueDataCon, + + -- * Ordering + orderingTyCon, + ordLTDataCon, ordLTDataConId, + ordEQDataCon, ordEQDataConId, + ordGTDataCon, ordGTDataConId, + promotedLTDataCon, promotedEQDataCon, promotedGTDataCon, + + -- * Boxing primitive types + boxingDataCon_maybe, + + -- * Char + charTyCon, charDataCon, charTyCon_RDR, + charTy, stringTy, charTyConName, + + -- * Double + doubleTyCon, doubleDataCon, doubleTy, doubleTyConName, + + -- * Float + floatTyCon, floatDataCon, floatTy, floatTyConName, + + -- * Int + intTyCon, intDataCon, intTyCon_RDR, intDataCon_RDR, intTyConName, + intTy, + + -- * Word + wordTyCon, wordDataCon, wordTyConName, wordTy, + + -- * Word8 + word8TyCon, word8DataCon, word8TyConName, word8Ty, + + -- * List + listTyCon, listTyCon_RDR, listTyConName, listTyConKey, + nilDataCon, nilDataConName, nilDataConKey, + consDataCon_RDR, consDataCon, consDataConName, + promotedNilDataCon, promotedConsDataCon, + mkListTy, mkPromotedListTy, + + -- * Maybe + maybeTyCon, maybeTyConName, + nothingDataCon, nothingDataConName, promotedNothingDataCon, + justDataCon, justDataConName, promotedJustDataCon, + + -- * Tuples + mkTupleTy, mkBoxedTupleTy, + tupleTyCon, tupleDataCon, tupleTyConName, + promotedTupleDataCon, + unitTyCon, unitDataCon, unitDataConId, unitTy, unitTyConKey, + pairTyCon, + unboxedUnitTyCon, unboxedUnitDataCon, + unboxedTupleKind, unboxedSumKind, + + -- ** Constraint tuples + cTupleTyConName, cTupleTyConNames, isCTupleTyConName, + cTupleTyConNameArity_maybe, + cTupleDataConName, cTupleDataConNames, + + -- * Any + anyTyCon, anyTy, anyTypeOfKind, + + -- * Recovery TyCon + makeRecoveryTyCon, + + -- * Sums + mkSumTy, sumTyCon, sumDataCon, + + -- * Kinds + typeNatKindCon, typeNatKind, typeSymbolKindCon, typeSymbolKind, + isLiftedTypeKindTyConName, liftedTypeKind, constraintKind, + liftedTypeKindTyCon, constraintKindTyCon, + liftedTypeKindTyConName, + + -- * Equality predicates + heqTyCon, heqTyConName, heqClass, heqDataCon, + eqTyCon, eqTyConName, eqClass, eqDataCon, eqTyCon_RDR, + coercibleTyCon, coercibleTyConName, coercibleDataCon, coercibleClass, + + -- * RuntimeRep and friends + runtimeRepTyCon, vecCountTyCon, vecElemTyCon, + + runtimeRepTy, liftedRepTy, liftedRepDataCon, liftedRepDataConTyCon, + + vecRepDataConTyCon, tupleRepDataConTyCon, sumRepDataConTyCon, + + liftedRepDataConTy, unliftedRepDataConTy, intRepDataConTy, int8RepDataConTy, + int16RepDataConTy, word16RepDataConTy, + wordRepDataConTy, int64RepDataConTy, word8RepDataConTy, word64RepDataConTy, + addrRepDataConTy, + floatRepDataConTy, doubleRepDataConTy, + + vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy, + vec64DataConTy, + + int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy, + int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy, + word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy, + doubleElemRepDataConTy + + ) where + +#include "HsVersions.h" +#include "MachDeps.h" + +import GhcPrelude + +import {-# SOURCE #-} MkId( mkDataConWorkId, mkDictSelId ) + +-- friends: +import PrelNames +import TysPrim +import {-# SOURCE #-} KnownUniques + +-- others: +import CoAxiom +import Id +import Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE, mAX_SUM_SIZE ) +import Module ( Module ) +import Type +import RepType +import DataCon +import {-# SOURCE #-} ConLike +import TyCon +import Class ( Class, mkClass ) +import RdrName +import Name +import NameEnv ( NameEnv, mkNameEnv, lookupNameEnv, lookupNameEnv_NF ) +import NameSet ( NameSet, mkNameSet, elemNameSet ) +import BasicTypes ( Arity, Boxity(..), TupleSort(..), ConTagZ, + SourceText(..) ) +import ForeignCall +import SrcLoc ( noSrcSpan ) +import Unique +import Data.Array +import FastString +import Outputable +import Util +import BooleanFormula ( mkAnd ) + +import qualified Data.ByteString.Char8 as BS + +import Data.List ( elemIndex ) + +alpha_tyvar :: [TyVar] +alpha_tyvar = [alphaTyVar] + +alpha_ty :: [Type] +alpha_ty = [alphaTy] + +{- +Note [Wiring in RuntimeRep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The RuntimeRep type (and friends) in GHC.Types has a bunch of constructors, +making it a pain to wire in. To ease the pain somewhat, we use lists of +the different bits, like Uniques, Names, DataCons. These lists must be +kept in sync with each other. The rule is this: use the order as declared +in GHC.Types. All places where such lists exist should contain a reference +to this Note, so a search for this Note's name should find all the lists. + +************************************************************************ +* * +\subsection{Wired in type constructors} +* * +************************************************************************ + +If you change which things are wired in, make sure you change their +names in PrelNames, so they use wTcQual, wDataQual, etc +-} + +-- This list is used only to define PrelInfo.wiredInThings. That in turn +-- is used to initialise the name environment carried around by the renamer. +-- This means that if we look up the name of a TyCon (or its implicit binders) +-- that occurs in this list that name will be assigned the wired-in key we +-- define here. +-- +-- Because of their infinite nature, this list excludes tuples, Any and implicit +-- parameter TyCons (see Note [Built-in syntax and the OrigNameCache]). +-- +-- See also Note [Known-key names] +wiredInTyCons :: [TyCon] + +wiredInTyCons = [ -- Units are not treated like other tuples, because then + -- are defined in GHC.Base, and there's only a few of them. We + -- put them in wiredInTyCons so that they will pre-populate + -- the name cache, so the parser in isBuiltInOcc_maybe doesn't + -- need to look out for them. + unitTyCon + , unboxedUnitTyCon + , anyTyCon + , boolTyCon + , charTyCon + , doubleTyCon + , floatTyCon + , intTyCon + , wordTyCon + , word8TyCon + , listTyCon + , maybeTyCon + , heqTyCon + , eqTyCon + , coercibleTyCon + , typeNatKindCon + , typeSymbolKindCon + , runtimeRepTyCon + , vecCountTyCon + , vecElemTyCon + , constraintKindTyCon + , liftedTypeKindTyCon + ] + +mkWiredInTyConName :: BuiltInSyntax -> Module -> FastString -> Unique -> TyCon -> Name +mkWiredInTyConName built_in modu fs unique tycon + = mkWiredInName modu (mkTcOccFS fs) unique + (ATyCon tycon) -- Relevant TyCon + built_in + +mkWiredInDataConName :: BuiltInSyntax -> Module -> FastString -> Unique -> DataCon -> Name +mkWiredInDataConName built_in modu fs unique datacon + = mkWiredInName modu (mkDataOccFS fs) unique + (AConLike (RealDataCon datacon)) -- Relevant DataCon + built_in + +mkWiredInIdName :: Module -> FastString -> Unique -> Id -> Name +mkWiredInIdName mod fs uniq id + = mkWiredInName mod (mkOccNameFS Name.varName fs) uniq (AnId id) UserSyntax + +-- See Note [Kind-changing of (~) and Coercible] +-- in libraries/ghc-prim/GHC/Types.hs +eqTyConName, eqDataConName, eqSCSelIdName :: Name +eqTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "~") eqTyConKey eqTyCon +eqDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Eq#") eqDataConKey eqDataCon +eqSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "eq_sel") eqSCSelIdKey eqSCSelId + +eqTyCon_RDR :: RdrName +eqTyCon_RDR = nameRdrName eqTyConName + +-- See Note [Kind-changing of (~) and Coercible] +-- in libraries/ghc-prim/GHC/Types.hs +heqTyConName, heqDataConName, heqSCSelIdName :: Name +heqTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "~~") heqTyConKey heqTyCon +heqDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "HEq#") heqDataConKey heqDataCon +heqSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "heq_sel") heqSCSelIdKey heqSCSelId + +-- See Note [Kind-changing of (~) and Coercible] in libraries/ghc-prim/GHC/Types.hs +coercibleTyConName, coercibleDataConName, coercibleSCSelIdName :: Name +coercibleTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Coercible") coercibleTyConKey coercibleTyCon +coercibleDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "MkCoercible") coercibleDataConKey coercibleDataCon +coercibleSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "coercible_sel") coercibleSCSelIdKey coercibleSCSelId + +charTyConName, charDataConName, intTyConName, intDataConName :: Name +charTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Char") charTyConKey charTyCon +charDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "C#") charDataConKey charDataCon +intTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Int") intTyConKey intTyCon +intDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "I#") intDataConKey intDataCon + +boolTyConName, falseDataConName, trueDataConName :: Name +boolTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Bool") boolTyConKey boolTyCon +falseDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "False") falseDataConKey falseDataCon +trueDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "True") trueDataConKey trueDataCon + +listTyConName, nilDataConName, consDataConName :: Name +listTyConName = mkWiredInTyConName BuiltInSyntax gHC_TYPES (fsLit "[]") listTyConKey listTyCon +nilDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit "[]") nilDataConKey nilDataCon +consDataConName = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon + +maybeTyConName, nothingDataConName, justDataConName :: Name +maybeTyConName = mkWiredInTyConName UserSyntax gHC_MAYBE (fsLit "Maybe") + maybeTyConKey maybeTyCon +nothingDataConName = mkWiredInDataConName UserSyntax gHC_MAYBE (fsLit "Nothing") + nothingDataConKey nothingDataCon +justDataConName = mkWiredInDataConName UserSyntax gHC_MAYBE (fsLit "Just") + justDataConKey justDataCon + +wordTyConName, wordDataConName, word8TyConName, word8DataConName :: Name +wordTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Word") wordTyConKey wordTyCon +wordDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "W#") wordDataConKey wordDataCon +word8TyConName = mkWiredInTyConName UserSyntax gHC_WORD (fsLit "Word8") word8TyConKey word8TyCon +word8DataConName = mkWiredInDataConName UserSyntax gHC_WORD (fsLit "W8#") word8DataConKey word8DataCon + +floatTyConName, floatDataConName, doubleTyConName, doubleDataConName :: Name +floatTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Float") floatTyConKey floatTyCon +floatDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "F#") floatDataConKey floatDataCon +doubleTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Double") doubleTyConKey doubleTyCon +doubleDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "D#") doubleDataConKey doubleDataCon + +-- Any + +{- +Note [Any types] +~~~~~~~~~~~~~~~~ +The type constructor Any, + + type family Any :: k where { } + +It has these properties: + + * Note that 'Any' is kind polymorphic since in some program we may + need to use Any to fill in a type variable of some kind other than * + (see #959 for examples). Its kind is thus `forall k. k``. + + * It is defined in module GHC.Types, and exported so that it is + available to users. For this reason it's treated like any other + wired-in type: + - has a fixed unique, anyTyConKey, + - lives in the global name cache + + * It is a *closed* type family, with no instances. This means that + if ty :: '(k1, k2) we add a given coercion + g :: ty ~ (Fst ty, Snd ty) + If Any was a *data* type, then we'd get inconsistency because 'ty' + could be (Any '(k1,k2)) and then we'd have an equality with Any on + one side and '(,) on the other. See also #9097 and #9636. + + * When instantiated at a lifted type it is inhabited by at least one value, + namely bottom + + * You can safely coerce any /lifted/ type to Any, and back with unsafeCoerce. + + * It does not claim to be a *data* type, and that's important for + the code generator, because the code gen may *enter* a data value + but never enters a function value. + + * It is wired-in so we can easily refer to it where we don't have a name + environment (e.g. see Rules.matchRule for one example) + + * If (Any k) is the type of a value, it must be a /lifted/ value. So + if we have (Any @(TYPE rr)) then rr must be 'LiftedRep. See + Note [TYPE and RuntimeRep] in TysPrim. This is a convenient + invariant, and makes isUnliftedTyCon well-defined; otherwise what + would (isUnliftedTyCon Any) be? + +It's used to instantiate un-constrained type variables after type checking. For +example, 'length' has type + + length :: forall a. [a] -> Int + +and the list datacon for the empty list has type + + [] :: forall a. [a] + +In order to compose these two terms as @length []@ a type +application is required, but there is no constraint on the +choice. In this situation GHC uses 'Any', + +> length (Any *) ([] (Any *)) + +Above, we print kinds explicitly, as if with --fprint-explicit-kinds. + +The Any tycon used to be quite magic, but we have since been able to +implement it merely with an empty kind polymorphic type family. See #10886 for a +bit of history. +-} + + +anyTyConName :: Name +anyTyConName = + mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Any") anyTyConKey anyTyCon + +anyTyCon :: TyCon +anyTyCon = mkFamilyTyCon anyTyConName binders res_kind Nothing + (ClosedSynFamilyTyCon Nothing) + Nothing + NotInjective + where + binders@[kv] = mkTemplateKindTyConBinders [liftedTypeKind] + res_kind = mkTyVarTy (binderVar kv) + +anyTy :: Type +anyTy = mkTyConTy anyTyCon + +anyTypeOfKind :: Kind -> Type +anyTypeOfKind kind = mkTyConApp anyTyCon [kind] + +-- | Make a fake, recovery 'TyCon' from an existing one. +-- Used when recovering from errors in type declarations +makeRecoveryTyCon :: TyCon -> TyCon +makeRecoveryTyCon tc + = mkTcTyCon (tyConName tc) + bndrs res_kind + [] -- No scoped vars + True -- Fully generalised + flavour -- Keep old flavour + where + flavour = tyConFlavour tc + [kv] = mkTemplateKindVars [liftedTypeKind] + (bndrs, res_kind) + = case flavour of + PromotedDataConFlavour -> ([mkNamedTyConBinder Inferred kv], mkTyVarTy kv) + _ -> (tyConBinders tc, tyConResKind tc) + -- For data types we have already validated their kind, so it + -- makes sense to keep it. For promoted data constructors we haven't, + -- so we recover with kind (forall k. k). Otherwise consider + -- data T a where { MkT :: Show a => T a } + -- If T is for some reason invalid, we don't want to fall over + -- at (promoted) use-sites of MkT. + +-- Kinds +typeNatKindConName, typeSymbolKindConName :: Name +typeNatKindConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Nat") typeNatKindConNameKey typeNatKindCon +typeSymbolKindConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Symbol") typeSymbolKindConNameKey typeSymbolKindCon + +constraintKindTyConName :: Name +constraintKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Constraint") constraintKindTyConKey constraintKindTyCon + +liftedTypeKindTyConName :: Name +liftedTypeKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Type") liftedTypeKindTyConKey liftedTypeKindTyCon + +runtimeRepTyConName, vecRepDataConName, tupleRepDataConName, sumRepDataConName :: Name +runtimeRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "RuntimeRep") runtimeRepTyConKey runtimeRepTyCon +vecRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "VecRep") vecRepDataConKey vecRepDataCon +tupleRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "TupleRep") tupleRepDataConKey tupleRepDataCon +sumRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "SumRep") sumRepDataConKey sumRepDataCon + +-- See Note [Wiring in RuntimeRep] +runtimeRepSimpleDataConNames :: [Name] +runtimeRepSimpleDataConNames + = zipWith3Lazy mk_special_dc_name + [ fsLit "LiftedRep" + , fsLit "UnliftedRep" + , fsLit "IntRep" + , fsLit "WordRep" + , fsLit "Int8Rep" + , fsLit "Int16Rep" + , fsLit "Int64Rep" + , fsLit "Word8Rep" + , fsLit "Word16Rep" + , fsLit "Word64Rep" + , fsLit "AddrRep" + , fsLit "FloatRep" + , fsLit "DoubleRep" + ] + runtimeRepSimpleDataConKeys + runtimeRepSimpleDataCons + +vecCountTyConName :: Name +vecCountTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "VecCount") vecCountTyConKey vecCountTyCon + +-- See Note [Wiring in RuntimeRep] +vecCountDataConNames :: [Name] +vecCountDataConNames = zipWith3Lazy mk_special_dc_name + [ fsLit "Vec2", fsLit "Vec4", fsLit "Vec8" + , fsLit "Vec16", fsLit "Vec32", fsLit "Vec64" ] + vecCountDataConKeys + vecCountDataCons + +vecElemTyConName :: Name +vecElemTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "VecElem") vecElemTyConKey vecElemTyCon + +-- See Note [Wiring in RuntimeRep] +vecElemDataConNames :: [Name] +vecElemDataConNames = zipWith3Lazy mk_special_dc_name + [ fsLit "Int8ElemRep", fsLit "Int16ElemRep", fsLit "Int32ElemRep" + , fsLit "Int64ElemRep", fsLit "Word8ElemRep", fsLit "Word16ElemRep" + , fsLit "Word32ElemRep", fsLit "Word64ElemRep" + , fsLit "FloatElemRep", fsLit "DoubleElemRep" ] + vecElemDataConKeys + vecElemDataCons + +mk_special_dc_name :: FastString -> Unique -> DataCon -> Name +mk_special_dc_name fs u dc = mkWiredInDataConName UserSyntax gHC_TYPES fs u dc + +boolTyCon_RDR, false_RDR, true_RDR, intTyCon_RDR, charTyCon_RDR, + intDataCon_RDR, listTyCon_RDR, consDataCon_RDR :: RdrName +boolTyCon_RDR = nameRdrName boolTyConName +false_RDR = nameRdrName falseDataConName +true_RDR = nameRdrName trueDataConName +intTyCon_RDR = nameRdrName intTyConName +charTyCon_RDR = nameRdrName charTyConName +intDataCon_RDR = nameRdrName intDataConName +listTyCon_RDR = nameRdrName listTyConName +consDataCon_RDR = nameRdrName consDataConName + +{- +************************************************************************ +* * +\subsection{mkWiredInTyCon} +* * +************************************************************************ +-} + +-- This function assumes that the types it creates have all parameters at +-- Representational role, and that there is no kind polymorphism. +pcTyCon :: Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon +pcTyCon name cType tyvars cons + = mkAlgTyCon name + (mkAnonTyConBinders VisArg tyvars) + liftedTypeKind + (map (const Representational) tyvars) + cType + [] -- No stupid theta + (mkDataTyConRhs cons) + (VanillaAlgTyCon (mkPrelTyConRepName name)) + False -- Not in GADT syntax + +pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon +pcDataCon n univs = pcDataConWithFixity False n univs + [] -- no ex_tvs + univs -- the univs are precisely the user-written tyvars + +pcDataConWithFixity :: Bool -- ^ declared infix? + -> Name -- ^ datacon name + -> [TyVar] -- ^ univ tyvars + -> [TyCoVar] -- ^ ex tycovars + -> [TyCoVar] -- ^ user-written tycovars + -> [Type] -- ^ args + -> TyCon + -> DataCon +pcDataConWithFixity infx n = pcDataConWithFixity' infx n (dataConWorkerUnique (nameUnique n)) + NoRRI +-- The Name's unique is the first of two free uniques; +-- the first is used for the datacon itself, +-- the second is used for the "worker name" +-- +-- To support this the mkPreludeDataConUnique function "allocates" +-- one DataCon unique per pair of Ints. + +pcDataConWithFixity' :: Bool -> Name -> Unique -> RuntimeRepInfo + -> [TyVar] -> [TyCoVar] -> [TyCoVar] + -> [Type] -> TyCon -> DataCon +-- The Name should be in the DataName name space; it's the name +-- of the DataCon itself. + +pcDataConWithFixity' declared_infix dc_name wrk_key rri + tyvars ex_tyvars user_tyvars arg_tys tycon + = data_con + where + tag_map = mkTyConTagMap tycon + -- This constructs the constructor Name to ConTag map once per + -- constructor, which is quadratic. It's OK here, because it's + -- only called for wired in data types that don't have a lot of + -- constructors. It's also likely that GHC will lift tag_map, since + -- we call pcDataConWithFixity' with static TyCons in the same module. + -- See Note [Constructor tag allocation] and #14657 + data_con = mkDataCon dc_name declared_infix prom_info + (map (const no_bang) arg_tys) + [] -- No labelled fields + tyvars ex_tyvars + (mkTyCoVarBinders Specified user_tyvars) + [] -- No equality spec + [] -- No theta + arg_tys (mkTyConApp tycon (mkTyVarTys tyvars)) + rri + tycon + (lookupNameEnv_NF tag_map dc_name) + [] -- No stupid theta + (mkDataConWorkId wrk_name data_con) + NoDataConRep -- Wired-in types are too simple to need wrappers + + no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict + + wrk_name = mkDataConWorkerName data_con wrk_key + + prom_info = mkPrelTyConRepName dc_name + +mkDataConWorkerName :: DataCon -> Unique -> Name +mkDataConWorkerName data_con wrk_key = + mkWiredInName modu wrk_occ wrk_key + (AnId (dataConWorkId data_con)) UserSyntax + where + modu = ASSERT( isExternalName dc_name ) + nameModule dc_name + dc_name = dataConName data_con + dc_occ = nameOccName dc_name + wrk_occ = mkDataConWorkerOcc dc_occ + +-- used for RuntimeRep and friends +pcSpecialDataCon :: Name -> [Type] -> TyCon -> RuntimeRepInfo -> DataCon +pcSpecialDataCon dc_name arg_tys tycon rri + = pcDataConWithFixity' False dc_name (dataConWorkerUnique (nameUnique dc_name)) rri + [] [] [] arg_tys tycon + +{- +************************************************************************ +* * + Kinds +* * +************************************************************************ +-} + +typeNatKindCon, typeSymbolKindCon :: TyCon +-- data Nat +-- data Symbol +typeNatKindCon = pcTyCon typeNatKindConName Nothing [] [] +typeSymbolKindCon = pcTyCon typeSymbolKindConName Nothing [] [] + +typeNatKind, typeSymbolKind :: Kind +typeNatKind = mkTyConTy typeNatKindCon +typeSymbolKind = mkTyConTy typeSymbolKindCon + +constraintKindTyCon :: TyCon +constraintKindTyCon = pcTyCon constraintKindTyConName Nothing [] [] + +liftedTypeKind, constraintKind :: Kind +liftedTypeKind = tYPE liftedRepTy +constraintKind = mkTyConApp constraintKindTyCon [] + +{- +************************************************************************ +* * + Stuff for dealing with tuples +* * +************************************************************************ + +Note [How tuples work] See also Note [Known-key names] in PrelNames +~~~~~~~~~~~~~~~~~~~~~~ +* There are three families of tuple TyCons and corresponding + DataCons, expressed by the type BasicTypes.TupleSort: + data TupleSort = BoxedTuple | UnboxedTuple | ConstraintTuple + +* All three families are AlgTyCons, whose AlgTyConRhs is TupleTyCon + +* BoxedTuples + - A wired-in type + - Data type declarations in GHC.Tuple + - The data constructors really have an info table + +* UnboxedTuples + - A wired-in type + - Have a pretend DataCon, defined in GHC.Prim, + but no actual declaration and no info table + +* ConstraintTuples + - Are known-key rather than wired-in. Reason: it's awkward to + have all the superclass selectors wired-in. + - Declared as classes in GHC.Classes, e.g. + class (c1,c2) => (c1,c2) + - Given constraints: the superclasses automatically become available + - Wanted constraints: there is a built-in instance + instance (c1,c2) => (c1,c2) + See TcInteract.matchCTuple + - Currently just go up to 62; beyond that + you have to use manual nesting + - Their OccNames look like (%,,,%), so they can easily be + distinguished from term tuples. But (following Haskell) we + pretty-print saturated constraint tuples with round parens; + see BasicTypes.tupleParens. + +* In quite a lot of places things are restrcted just to + BoxedTuple/UnboxedTuple, and then we used BasicTypes.Boxity to distinguish + E.g. tupleTyCon has a Boxity argument + +* When looking up an OccName in the original-name cache + (IfaceEnv.lookupOrigNameCache), we spot the tuple OccName to make sure + we get the right wired-in name. This guy can't tell the difference + between BoxedTuple and ConstraintTuple (same OccName!), so tuples + are not serialised into interface files using OccNames at all. + +* Serialization to interface files works via the usual mechanism for known-key + things: instead of serializing the OccName we just serialize the key. During + deserialization we lookup the Name associated with the unique with the logic + in KnownUniques. See Note [Symbol table representation of names] for details. + +Note [One-tuples] +~~~~~~~~~~~~~~~~~ +GHC supports both boxed and unboxed one-tuples: + - Unboxed one-tuples are sometimes useful when returning a + single value after CPR analysis + - A boxed one-tuple is used by DsUtils.mkSelectorBinds, when + there is just one binder +Basically it keeps everythig uniform. + +However the /naming/ of the type/data constructors for one-tuples is a +bit odd: + 3-tuples: (,,) (,,)# + 2-tuples: (,) (,)# + 1-tuples: ?? + 0-tuples: () ()# + +Zero-tuples have used up the logical name. So we use 'Unit' and 'Unit#' +for one-tuples. So in ghc-prim:GHC.Tuple we see the declarations: + data () = () + data Unit a = Unit a + data (a,b) = (a,b) + +NB (Feb 16): for /constraint/ one-tuples I have 'Unit%' but no class +decl in GHC.Classes, so I think this part may not work properly. But +it's unused I think. +-} + +-- | Built-in syntax isn't "in scope" so these OccNames map to wired-in Names +-- with BuiltInSyntax. However, this should only be necessary while resolving +-- names produced by Template Haskell splices since we take care to encode +-- built-in syntax names specially in interface files. See +-- Note [Symbol table representation of names]. +-- +-- Moreover, there is no need to include names of things that the user can't +-- write (e.g. type representation bindings like $tc(,,,)). +isBuiltInOcc_maybe :: OccName -> Maybe Name +isBuiltInOcc_maybe occ = + case name of + "[]" -> Just $ choose_ns listTyConName nilDataConName + ":" -> Just consDataConName + + -- equality tycon + "~" -> Just eqTyConName + + -- function tycon + "->" -> Just funTyConName + + -- boxed tuple data/tycon + "()" -> Just $ tup_name Boxed 0 + _ | Just rest <- "(" `BS.stripPrefix` name + , (commas, rest') <- BS.span (==',') rest + , ")" <- rest' + -> Just $ tup_name Boxed (1+BS.length commas) + + -- unboxed tuple data/tycon + "(##)" -> Just $ tup_name Unboxed 0 + "Unit#" -> Just $ tup_name Unboxed 1 + _ | Just rest <- "(#" `BS.stripPrefix` name + , (commas, rest') <- BS.span (==',') rest + , "#)" <- rest' + -> Just $ tup_name Unboxed (1+BS.length commas) + + -- unboxed sum tycon + _ | Just rest <- "(#" `BS.stripPrefix` name + , (pipes, rest') <- BS.span (=='|') rest + , "#)" <- rest' + -> Just $ tyConName $ sumTyCon (1+BS.length pipes) + + -- unboxed sum datacon + _ | Just rest <- "(#" `BS.stripPrefix` name + , (pipes1, rest') <- BS.span (=='|') rest + , Just rest'' <- "_" `BS.stripPrefix` rest' + , (pipes2, rest''') <- BS.span (=='|') rest'' + , "#)" <- rest''' + -> let arity = BS.length pipes1 + BS.length pipes2 + 1 + alt = BS.length pipes1 + 1 + in Just $ dataConName $ sumDataCon alt arity + _ -> Nothing + where + name = bytesFS $ occNameFS occ + + choose_ns :: Name -> Name -> Name + choose_ns tc dc + | isTcClsNameSpace ns = tc + | isDataConNameSpace ns = dc + | otherwise = pprPanic "tup_name" (ppr occ) + where ns = occNameSpace occ + + tup_name boxity arity + = choose_ns (getName (tupleTyCon boxity arity)) + (getName (tupleDataCon boxity arity)) + +mkTupleOcc :: NameSpace -> Boxity -> Arity -> OccName +-- No need to cache these, the caching is done in mk_tuple +mkTupleOcc ns Boxed ar = mkOccName ns (mkBoxedTupleStr ar) +mkTupleOcc ns Unboxed ar = mkOccName ns (mkUnboxedTupleStr ar) + +mkCTupleOcc :: NameSpace -> Arity -> OccName +mkCTupleOcc ns ar = mkOccName ns (mkConstraintTupleStr ar) + +mkBoxedTupleStr :: Arity -> String +mkBoxedTupleStr 0 = "()" +mkBoxedTupleStr 1 = "Unit" -- See Note [One-tuples] +mkBoxedTupleStr ar = '(' : commas ar ++ ")" + +mkUnboxedTupleStr :: Arity -> String +mkUnboxedTupleStr 0 = "(##)" +mkUnboxedTupleStr 1 = "Unit#" -- See Note [One-tuples] +mkUnboxedTupleStr ar = "(#" ++ commas ar ++ "#)" + +mkConstraintTupleStr :: Arity -> String +mkConstraintTupleStr 0 = "(%%)" +mkConstraintTupleStr 1 = "Unit%" -- See Note [One-tuples] +mkConstraintTupleStr ar = "(%" ++ commas ar ++ "%)" + +commas :: Arity -> String +commas ar = take (ar-1) (repeat ',') + +cTupleTyConName :: Arity -> Name +cTupleTyConName arity + = mkExternalName (mkCTupleTyConUnique arity) gHC_CLASSES + (mkCTupleOcc tcName arity) noSrcSpan + +cTupleTyConNames :: [Name] +cTupleTyConNames = map cTupleTyConName (0 : [2..mAX_CTUPLE_SIZE]) + +cTupleTyConNameSet :: NameSet +cTupleTyConNameSet = mkNameSet cTupleTyConNames + +isCTupleTyConName :: Name -> Bool +-- Use Type.isCTupleClass where possible +isCTupleTyConName n + = ASSERT2( isExternalName n, ppr n ) + nameModule n == gHC_CLASSES + && n `elemNameSet` cTupleTyConNameSet + +-- | If the given name is that of a constraint tuple, return its arity. +-- Note that this is inefficient. +cTupleTyConNameArity_maybe :: Name -> Maybe Arity +cTupleTyConNameArity_maybe n + | not (isCTupleTyConName n) = Nothing + | otherwise = fmap adjustArity (n `elemIndex` cTupleTyConNames) + where + -- Since `cTupleTyConNames` jumps straight from the `0` to the `2` + -- case, we have to adjust accordingly our calculated arity. + adjustArity a = if a > 0 then a + 1 else a + +cTupleDataConName :: Arity -> Name +cTupleDataConName arity + = mkExternalName (mkCTupleDataConUnique arity) gHC_CLASSES + (mkCTupleOcc dataName arity) noSrcSpan + +cTupleDataConNames :: [Name] +cTupleDataConNames = map cTupleDataConName (0 : [2..mAX_CTUPLE_SIZE]) + +tupleTyCon :: Boxity -> Arity -> TyCon +tupleTyCon sort i | i > mAX_TUPLE_SIZE = fst (mk_tuple sort i) -- Build one specially +tupleTyCon Boxed i = fst (boxedTupleArr ! i) +tupleTyCon Unboxed i = fst (unboxedTupleArr ! i) + +tupleTyConName :: TupleSort -> Arity -> Name +tupleTyConName ConstraintTuple a = cTupleTyConName a +tupleTyConName BoxedTuple a = tyConName (tupleTyCon Boxed a) +tupleTyConName UnboxedTuple a = tyConName (tupleTyCon Unboxed a) + +promotedTupleDataCon :: Boxity -> Arity -> TyCon +promotedTupleDataCon boxity i = promoteDataCon (tupleDataCon boxity i) + +tupleDataCon :: Boxity -> Arity -> DataCon +tupleDataCon sort i | i > mAX_TUPLE_SIZE = snd (mk_tuple sort i) -- Build one specially +tupleDataCon Boxed i = snd (boxedTupleArr ! i) +tupleDataCon Unboxed i = snd (unboxedTupleArr ! i) + +boxedTupleArr, unboxedTupleArr :: Array Int (TyCon,DataCon) +boxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Boxed i | i <- [0..mAX_TUPLE_SIZE]] +unboxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Unboxed i | i <- [0..mAX_TUPLE_SIZE]] + +-- | Given the TupleRep/SumRep tycon and list of RuntimeReps of the unboxed +-- tuple/sum arguments, produces the return kind of an unboxed tuple/sum type +-- constructor. @unboxedTupleSumKind [IntRep, LiftedRep] --> TYPE (TupleRep/SumRep +-- [IntRep, LiftedRep])@ +unboxedTupleSumKind :: TyCon -> [Type] -> Kind +unboxedTupleSumKind tc rr_tys + = tYPE (mkTyConApp tc [mkPromotedListTy runtimeRepTy rr_tys]) + +-- | Specialization of 'unboxedTupleSumKind' for tuples +unboxedTupleKind :: [Type] -> Kind +unboxedTupleKind = unboxedTupleSumKind tupleRepDataConTyCon + +mk_tuple :: Boxity -> Int -> (TyCon,DataCon) +mk_tuple Boxed arity = (tycon, tuple_con) + where + tycon = mkTupleTyCon tc_name tc_binders tc_res_kind tc_arity tuple_con + BoxedTuple flavour + + tc_binders = mkTemplateAnonTyConBinders (replicate arity liftedTypeKind) + tc_res_kind = liftedTypeKind + tc_arity = arity + flavour = VanillaAlgTyCon (mkPrelTyConRepName tc_name) + + dc_tvs = binderVars tc_binders + dc_arg_tys = mkTyVarTys dc_tvs + tuple_con = pcDataCon dc_name dc_tvs dc_arg_tys tycon + + boxity = Boxed + modu = gHC_TUPLE + tc_name = mkWiredInName modu (mkTupleOcc tcName boxity arity) tc_uniq + (ATyCon tycon) BuiltInSyntax + dc_name = mkWiredInName modu (mkTupleOcc dataName boxity arity) dc_uniq + (AConLike (RealDataCon tuple_con)) BuiltInSyntax + tc_uniq = mkTupleTyConUnique boxity arity + dc_uniq = mkTupleDataConUnique boxity arity + +mk_tuple Unboxed arity = (tycon, tuple_con) + where + tycon = mkTupleTyCon tc_name tc_binders tc_res_kind tc_arity tuple_con + UnboxedTuple flavour + + -- See Note [Unboxed tuple RuntimeRep vars] in TyCon + -- Kind: forall (k1:RuntimeRep) (k2:RuntimeRep). TYPE k1 -> TYPE k2 -> # + tc_binders = mkTemplateTyConBinders (replicate arity runtimeRepTy) + (\ks -> map tYPE ks) + + tc_res_kind = unboxedTupleKind rr_tys + + tc_arity = arity * 2 + flavour = UnboxedAlgTyCon $ Just (mkPrelTyConRepName tc_name) + + dc_tvs = binderVars tc_binders + (rr_tys, dc_arg_tys) = splitAt arity (mkTyVarTys dc_tvs) + tuple_con = pcDataCon dc_name dc_tvs dc_arg_tys tycon + + boxity = Unboxed + modu = gHC_PRIM + tc_name = mkWiredInName modu (mkTupleOcc tcName boxity arity) tc_uniq + (ATyCon tycon) BuiltInSyntax + dc_name = mkWiredInName modu (mkTupleOcc dataName boxity arity) dc_uniq + (AConLike (RealDataCon tuple_con)) BuiltInSyntax + tc_uniq = mkTupleTyConUnique boxity arity + dc_uniq = mkTupleDataConUnique boxity arity + +unitTyCon :: TyCon +unitTyCon = tupleTyCon Boxed 0 + +unitTyConKey :: Unique +unitTyConKey = getUnique unitTyCon + +unitDataCon :: DataCon +unitDataCon = head (tyConDataCons unitTyCon) + +unitDataConId :: Id +unitDataConId = dataConWorkId unitDataCon + +pairTyCon :: TyCon +pairTyCon = tupleTyCon Boxed 2 + +unboxedUnitTyCon :: TyCon +unboxedUnitTyCon = tupleTyCon Unboxed 0 + +unboxedUnitDataCon :: DataCon +unboxedUnitDataCon = tupleDataCon Unboxed 0 + + +{- ********************************************************************* +* * + Unboxed sums +* * +********************************************************************* -} + +-- | OccName for n-ary unboxed sum type constructor. +mkSumTyConOcc :: Arity -> OccName +mkSumTyConOcc n = mkOccName tcName str + where + -- No need to cache these, the caching is done in mk_sum + str = '(' : '#' : bars ++ "#)" + bars = replicate (n-1) '|' + +-- | OccName for i-th alternative of n-ary unboxed sum data constructor. +mkSumDataConOcc :: ConTag -> Arity -> OccName +mkSumDataConOcc alt n = mkOccName dataName str + where + -- No need to cache these, the caching is done in mk_sum + str = '(' : '#' : bars alt ++ '_' : bars (n - alt - 1) ++ "#)" + bars i = replicate i '|' + +-- | Type constructor for n-ary unboxed sum. +sumTyCon :: Arity -> TyCon +sumTyCon arity + | arity > mAX_SUM_SIZE + = fst (mk_sum arity) -- Build one specially + + | arity < 2 + = panic ("sumTyCon: Arity starts from 2. (arity: " ++ show arity ++ ")") + + | otherwise + = fst (unboxedSumArr ! arity) + +-- | Data constructor for i-th alternative of a n-ary unboxed sum. +sumDataCon :: ConTag -- Alternative + -> Arity -- Arity + -> DataCon +sumDataCon alt arity + | alt > arity + = panic ("sumDataCon: index out of bounds: alt: " + ++ show alt ++ " > arity " ++ show arity) + + | alt <= 0 + = panic ("sumDataCon: Alts start from 1. (alt: " ++ show alt + ++ ", arity: " ++ show arity ++ ")") + + | arity < 2 + = panic ("sumDataCon: Arity starts from 2. (alt: " ++ show alt + ++ ", arity: " ++ show arity ++ ")") + + | arity > mAX_SUM_SIZE + = snd (mk_sum arity) ! (alt - 1) -- Build one specially + + | otherwise + = snd (unboxedSumArr ! arity) ! (alt - 1) + +-- | Cached type and data constructors for sums. The outer array is +-- indexed by the arity of the sum and the inner array is indexed by +-- the alternative. +unboxedSumArr :: Array Int (TyCon, Array Int DataCon) +unboxedSumArr = listArray (2,mAX_SUM_SIZE) [mk_sum i | i <- [2..mAX_SUM_SIZE]] + +-- | Specialization of 'unboxedTupleSumKind' for sums +unboxedSumKind :: [Type] -> Kind +unboxedSumKind = unboxedTupleSumKind sumRepDataConTyCon + +-- | Create type constructor and data constructors for n-ary unboxed sum. +mk_sum :: Arity -> (TyCon, Array ConTagZ DataCon) +mk_sum arity = (tycon, sum_cons) + where + tycon = mkSumTyCon tc_name tc_binders tc_res_kind (arity * 2) tyvars (elems sum_cons) + (UnboxedAlgTyCon rep_name) + + -- Unboxed sums are currently not Typeable due to efficiency concerns. See #13276. + rep_name = Nothing -- Just $ mkPrelTyConRepName tc_name + + tc_binders = mkTemplateTyConBinders (replicate arity runtimeRepTy) + (\ks -> map tYPE ks) + + tyvars = binderVars tc_binders + + tc_res_kind = unboxedSumKind rr_tys + + (rr_tys, tyvar_tys) = splitAt arity (mkTyVarTys tyvars) + + tc_name = mkWiredInName gHC_PRIM (mkSumTyConOcc arity) tc_uniq + (ATyCon tycon) BuiltInSyntax + + sum_cons = listArray (0,arity-1) [sum_con i | i <- [0..arity-1]] + sum_con i = let dc = pcDataCon dc_name + tyvars -- univ tyvars + [tyvar_tys !! i] -- arg types + tycon + + dc_name = mkWiredInName gHC_PRIM + (mkSumDataConOcc i arity) + (dc_uniq i) + (AConLike (RealDataCon dc)) + BuiltInSyntax + in dc + + tc_uniq = mkSumTyConUnique arity + dc_uniq i = mkSumDataConUnique i arity + +{- +************************************************************************ +* * + Equality types and classes +* * +********************************************************************* -} + +-- See Note [The equality types story] in TysPrim +-- ((~~) :: forall k1 k2 (a :: k1) (b :: k2). a -> b -> Constraint) +-- +-- It's tempting to put functional dependencies on (~~), but it's not +-- necessary because the functional-dependency coverage check looks +-- through superclasses, and (~#) is handled in that check. + +eqTyCon, heqTyCon, coercibleTyCon :: TyCon +eqClass, heqClass, coercibleClass :: Class +eqDataCon, heqDataCon, coercibleDataCon :: DataCon +eqSCSelId, heqSCSelId, coercibleSCSelId :: Id + +(eqTyCon, eqClass, eqDataCon, eqSCSelId) + = (tycon, klass, datacon, sc_sel_id) + where + tycon = mkClassTyCon eqTyConName binders roles + rhs klass + (mkPrelTyConRepName eqTyConName) + klass = mk_class tycon sc_pred sc_sel_id + datacon = pcDataCon eqDataConName tvs [sc_pred] tycon + + -- Kind: forall k. k -> k -> Constraint + binders = mkTemplateTyConBinders [liftedTypeKind] (\[k] -> [k,k]) + roles = [Nominal, Nominal, Nominal] + rhs = mkDataTyConRhs [datacon] + + tvs@[k,a,b] = binderVars binders + sc_pred = mkTyConApp eqPrimTyCon (mkTyVarTys [k,k,a,b]) + sc_sel_id = mkDictSelId eqSCSelIdName klass + +(heqTyCon, heqClass, heqDataCon, heqSCSelId) + = (tycon, klass, datacon, sc_sel_id) + where + tycon = mkClassTyCon heqTyConName binders roles + rhs klass + (mkPrelTyConRepName heqTyConName) + klass = mk_class tycon sc_pred sc_sel_id + datacon = pcDataCon heqDataConName tvs [sc_pred] tycon + + -- Kind: forall k1 k2. k1 -> k2 -> Constraint + binders = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id + roles = [Nominal, Nominal, Nominal, Nominal] + rhs = mkDataTyConRhs [datacon] + + tvs = binderVars binders + sc_pred = mkTyConApp eqPrimTyCon (mkTyVarTys tvs) + sc_sel_id = mkDictSelId heqSCSelIdName klass + +(coercibleTyCon, coercibleClass, coercibleDataCon, coercibleSCSelId) + = (tycon, klass, datacon, sc_sel_id) + where + tycon = mkClassTyCon coercibleTyConName binders roles + rhs klass + (mkPrelTyConRepName coercibleTyConName) + klass = mk_class tycon sc_pred sc_sel_id + datacon = pcDataCon coercibleDataConName tvs [sc_pred] tycon + + -- Kind: forall k. k -> k -> Constraint + binders = mkTemplateTyConBinders [liftedTypeKind] (\[k] -> [k,k]) + roles = [Nominal, Representational, Representational] + rhs = mkDataTyConRhs [datacon] + + tvs@[k,a,b] = binderVars binders + sc_pred = mkTyConApp eqReprPrimTyCon (mkTyVarTys [k, k, a, b]) + sc_sel_id = mkDictSelId coercibleSCSelIdName klass + +mk_class :: TyCon -> PredType -> Id -> Class +mk_class tycon sc_pred sc_sel_id + = mkClass (tyConName tycon) (tyConTyVars tycon) [] [sc_pred] [sc_sel_id] + [] [] (mkAnd []) tycon + + + +{- ********************************************************************* +* * + Kinds and RuntimeRep +* * +********************************************************************* -} + +-- For information about the usage of the following type, +-- see Note [TYPE and RuntimeRep] in module TysPrim +runtimeRepTy :: Type +runtimeRepTy = mkTyConTy runtimeRepTyCon + +-- Type synonyms; see Note [TYPE and RuntimeRep] in TysPrim +-- type Type = tYPE 'LiftedRep +liftedTypeKindTyCon :: TyCon +liftedTypeKindTyCon = buildSynTyCon liftedTypeKindTyConName + [] liftedTypeKind [] + (tYPE liftedRepTy) + +runtimeRepTyCon :: TyCon +runtimeRepTyCon = pcTyCon runtimeRepTyConName Nothing [] + (vecRepDataCon : tupleRepDataCon : + sumRepDataCon : runtimeRepSimpleDataCons) + +vecRepDataCon :: DataCon +vecRepDataCon = pcSpecialDataCon vecRepDataConName [ mkTyConTy vecCountTyCon + , mkTyConTy vecElemTyCon ] + runtimeRepTyCon + (RuntimeRep prim_rep_fun) + where + prim_rep_fun [count, elem] + | VecCount n <- tyConRuntimeRepInfo (tyConAppTyCon count) + , VecElem e <- tyConRuntimeRepInfo (tyConAppTyCon elem) + = [VecRep n e] + prim_rep_fun args + = pprPanic "vecRepDataCon" (ppr args) + +vecRepDataConTyCon :: TyCon +vecRepDataConTyCon = promoteDataCon vecRepDataCon + +tupleRepDataCon :: DataCon +tupleRepDataCon = pcSpecialDataCon tupleRepDataConName [ mkListTy runtimeRepTy ] + runtimeRepTyCon (RuntimeRep prim_rep_fun) + where + prim_rep_fun [rr_ty_list] + = concatMap (runtimeRepPrimRep doc) rr_tys + where + rr_tys = extractPromotedList rr_ty_list + doc = text "tupleRepDataCon" <+> ppr rr_tys + prim_rep_fun args + = pprPanic "tupleRepDataCon" (ppr args) + +tupleRepDataConTyCon :: TyCon +tupleRepDataConTyCon = promoteDataCon tupleRepDataCon + +sumRepDataCon :: DataCon +sumRepDataCon = pcSpecialDataCon sumRepDataConName [ mkListTy runtimeRepTy ] + runtimeRepTyCon (RuntimeRep prim_rep_fun) + where + prim_rep_fun [rr_ty_list] + = map slotPrimRep (ubxSumRepType prim_repss) + where + rr_tys = extractPromotedList rr_ty_list + doc = text "sumRepDataCon" <+> ppr rr_tys + prim_repss = map (runtimeRepPrimRep doc) rr_tys + prim_rep_fun args + = pprPanic "sumRepDataCon" (ppr args) + +sumRepDataConTyCon :: TyCon +sumRepDataConTyCon = promoteDataCon sumRepDataCon + +-- See Note [Wiring in RuntimeRep] +runtimeRepSimpleDataCons :: [DataCon] +liftedRepDataCon :: DataCon +runtimeRepSimpleDataCons@(liftedRepDataCon : _) + = zipWithLazy mk_runtime_rep_dc + [ LiftedRep, UnliftedRep, IntRep, WordRep, Int8Rep, Int16Rep, Int64Rep + , Word8Rep, Word16Rep, Word64Rep, AddrRep, FloatRep, DoubleRep ] + runtimeRepSimpleDataConNames + where + mk_runtime_rep_dc primrep name + = pcSpecialDataCon name [] runtimeRepTyCon (RuntimeRep (\_ -> [primrep])) + +-- See Note [Wiring in RuntimeRep] +liftedRepDataConTy, unliftedRepDataConTy, + intRepDataConTy, int8RepDataConTy, int16RepDataConTy, wordRepDataConTy, int64RepDataConTy, + word8RepDataConTy, word16RepDataConTy, word64RepDataConTy, addrRepDataConTy, + floatRepDataConTy, doubleRepDataConTy :: Type +[liftedRepDataConTy, unliftedRepDataConTy, + intRepDataConTy, wordRepDataConTy, int8RepDataConTy, int16RepDataConTy, int64RepDataConTy, + word8RepDataConTy, word16RepDataConTy, word64RepDataConTy, + addrRepDataConTy, floatRepDataConTy, doubleRepDataConTy] + = map (mkTyConTy . promoteDataCon) runtimeRepSimpleDataCons + +vecCountTyCon :: TyCon +vecCountTyCon = pcTyCon vecCountTyConName Nothing [] vecCountDataCons + +-- See Note [Wiring in RuntimeRep] +vecCountDataCons :: [DataCon] +vecCountDataCons = zipWithLazy mk_vec_count_dc + [ 2, 4, 8, 16, 32, 64 ] + vecCountDataConNames + where + mk_vec_count_dc n name + = pcSpecialDataCon name [] vecCountTyCon (VecCount n) + +-- See Note [Wiring in RuntimeRep] +vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy, + vec64DataConTy :: Type +[vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy, + vec64DataConTy] = map (mkTyConTy . promoteDataCon) vecCountDataCons + +vecElemTyCon :: TyCon +vecElemTyCon = pcTyCon vecElemTyConName Nothing [] vecElemDataCons + +-- See Note [Wiring in RuntimeRep] +vecElemDataCons :: [DataCon] +vecElemDataCons = zipWithLazy mk_vec_elem_dc + [ Int8ElemRep, Int16ElemRep, Int32ElemRep, Int64ElemRep + , Word8ElemRep, Word16ElemRep, Word32ElemRep, Word64ElemRep + , FloatElemRep, DoubleElemRep ] + vecElemDataConNames + where + mk_vec_elem_dc elem name + = pcSpecialDataCon name [] vecElemTyCon (VecElem elem) + +-- See Note [Wiring in RuntimeRep] +int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy, + int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy, + word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy, + doubleElemRepDataConTy :: Type +[int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy, + int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy, + word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy, + doubleElemRepDataConTy] = map (mkTyConTy . promoteDataCon) + vecElemDataCons + +liftedRepDataConTyCon :: TyCon +liftedRepDataConTyCon = promoteDataCon liftedRepDataCon + +-- The type ('LiftedRep) +liftedRepTy :: Type +liftedRepTy = liftedRepDataConTy + +{- ********************************************************************* +* * + The boxed primitive types: Char, Int, etc +* * +********************************************************************* -} + +boxingDataCon_maybe :: TyCon -> Maybe DataCon +-- boxingDataCon_maybe Char# = C# +-- boxingDataCon_maybe Int# = I# +-- ... etc ... +-- See Note [Boxing primitive types] +boxingDataCon_maybe tc + = lookupNameEnv boxing_constr_env (tyConName tc) + +boxing_constr_env :: NameEnv DataCon +boxing_constr_env + = mkNameEnv [(charPrimTyConName , charDataCon ) + ,(intPrimTyConName , intDataCon ) + ,(wordPrimTyConName , wordDataCon ) + ,(floatPrimTyConName , floatDataCon ) + ,(doublePrimTyConName, doubleDataCon) ] + +{- Note [Boxing primitive types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For a handful of primitive types (Int, Char, Word, Flaot, Double), +we can readily box and an unboxed version (Int#, Char# etc) using +the corresponding data constructor. This is useful in a couple +of places, notably let-floating -} + + +charTy :: Type +charTy = mkTyConTy charTyCon + +charTyCon :: TyCon +charTyCon = pcTyCon charTyConName + (Just (CType NoSourceText Nothing + (NoSourceText,fsLit "HsChar"))) + [] [charDataCon] +charDataCon :: DataCon +charDataCon = pcDataCon charDataConName [] [charPrimTy] charTyCon + +stringTy :: Type +stringTy = mkListTy charTy -- convenience only + +intTy :: Type +intTy = mkTyConTy intTyCon + +intTyCon :: TyCon +intTyCon = pcTyCon intTyConName + (Just (CType NoSourceText Nothing (NoSourceText,fsLit "HsInt"))) + [] [intDataCon] +intDataCon :: DataCon +intDataCon = pcDataCon intDataConName [] [intPrimTy] intTyCon + +wordTy :: Type +wordTy = mkTyConTy wordTyCon + +wordTyCon :: TyCon +wordTyCon = pcTyCon wordTyConName + (Just (CType NoSourceText Nothing (NoSourceText, fsLit "HsWord"))) + [] [wordDataCon] +wordDataCon :: DataCon +wordDataCon = pcDataCon wordDataConName [] [wordPrimTy] wordTyCon + +word8Ty :: Type +word8Ty = mkTyConTy word8TyCon + +word8TyCon :: TyCon +word8TyCon = pcTyCon word8TyConName + (Just (CType NoSourceText Nothing + (NoSourceText, fsLit "HsWord8"))) [] + [word8DataCon] +word8DataCon :: DataCon +word8DataCon = pcDataCon word8DataConName [] [wordPrimTy] word8TyCon + +floatTy :: Type +floatTy = mkTyConTy floatTyCon + +floatTyCon :: TyCon +floatTyCon = pcTyCon floatTyConName + (Just (CType NoSourceText Nothing + (NoSourceText, fsLit "HsFloat"))) [] + [floatDataCon] +floatDataCon :: DataCon +floatDataCon = pcDataCon floatDataConName [] [floatPrimTy] floatTyCon + +doubleTy :: Type +doubleTy = mkTyConTy doubleTyCon + +doubleTyCon :: TyCon +doubleTyCon = pcTyCon doubleTyConName + (Just (CType NoSourceText Nothing + (NoSourceText,fsLit "HsDouble"))) [] + [doubleDataCon] + +doubleDataCon :: DataCon +doubleDataCon = pcDataCon doubleDataConName [] [doublePrimTy] doubleTyCon + +{- +************************************************************************ +* * + The Bool type +* * +************************************************************************ + +An ordinary enumeration type, but deeply wired in. There are no +magical operations on @Bool@ (just the regular Prelude code). + +{\em BEGIN IDLE SPECULATION BY SIMON} + +This is not the only way to encode @Bool@. A more obvious coding makes +@Bool@ just a boxed up version of @Bool#@, like this: +\begin{verbatim} +type Bool# = Int# +data Bool = MkBool Bool# +\end{verbatim} + +Unfortunately, this doesn't correspond to what the Report says @Bool@ +looks like! Furthermore, we get slightly less efficient code (I +think) with this coding. @gtInt@ would look like this: + +\begin{verbatim} +gtInt :: Int -> Int -> Bool +gtInt x y = case x of I# x# -> + case y of I# y# -> + case (gtIntPrim x# y#) of + b# -> MkBool b# +\end{verbatim} + +Notice that the result of the @gtIntPrim@ comparison has to be turned +into an integer (here called @b#@), and returned in a @MkBool@ box. + +The @if@ expression would compile to this: +\begin{verbatim} +case (gtInt x y) of + MkBool b# -> case b# of { 1# -> e1; 0# -> e2 } +\end{verbatim} + +I think this code is a little less efficient than the previous code, +but I'm not certain. At all events, corresponding with the Report is +important. The interesting thing is that the language is expressive +enough to describe more than one alternative; and that a type doesn't +necessarily need to be a straightforwardly boxed version of its +primitive counterpart. + +{\em END IDLE SPECULATION BY SIMON} +-} + +boolTy :: Type +boolTy = mkTyConTy boolTyCon + +boolTyCon :: TyCon +boolTyCon = pcTyCon boolTyConName + (Just (CType NoSourceText Nothing + (NoSourceText, fsLit "HsBool"))) + [] [falseDataCon, trueDataCon] + +falseDataCon, trueDataCon :: DataCon +falseDataCon = pcDataCon falseDataConName [] [] boolTyCon +trueDataCon = pcDataCon trueDataConName [] [] boolTyCon + +falseDataConId, trueDataConId :: Id +falseDataConId = dataConWorkId falseDataCon +trueDataConId = dataConWorkId trueDataCon + +orderingTyCon :: TyCon +orderingTyCon = pcTyCon orderingTyConName Nothing + [] [ordLTDataCon, ordEQDataCon, ordGTDataCon] + +ordLTDataCon, ordEQDataCon, ordGTDataCon :: DataCon +ordLTDataCon = pcDataCon ordLTDataConName [] [] orderingTyCon +ordEQDataCon = pcDataCon ordEQDataConName [] [] orderingTyCon +ordGTDataCon = pcDataCon ordGTDataConName [] [] orderingTyCon + +ordLTDataConId, ordEQDataConId, ordGTDataConId :: Id +ordLTDataConId = dataConWorkId ordLTDataCon +ordEQDataConId = dataConWorkId ordEQDataCon +ordGTDataConId = dataConWorkId ordGTDataCon + +{- +************************************************************************ +* * + The List type + Special syntax, deeply wired in, + but otherwise an ordinary algebraic data type +* * +************************************************************************ + + data [] a = [] | a : (List a) +-} + +mkListTy :: Type -> Type +mkListTy ty = mkTyConApp listTyCon [ty] + +listTyCon :: TyCon +listTyCon = + buildAlgTyCon listTyConName alpha_tyvar [Representational] + Nothing [] + (mkDataTyConRhs [nilDataCon, consDataCon]) + False + (VanillaAlgTyCon $ mkPrelTyConRepName listTyConName) + +nilDataCon :: DataCon +nilDataCon = pcDataCon nilDataConName alpha_tyvar [] listTyCon + +consDataCon :: DataCon +consDataCon = pcDataConWithFixity True {- Declared infix -} + consDataConName + alpha_tyvar [] alpha_tyvar + [alphaTy, mkTyConApp listTyCon alpha_ty] listTyCon +-- Interesting: polymorphic recursion would help here. +-- We can't use (mkListTy alphaTy) in the defn of consDataCon, else mkListTy +-- gets the over-specific type (Type -> Type) + +-- Wired-in type Maybe + +maybeTyCon :: TyCon +maybeTyCon = pcTyCon maybeTyConName Nothing alpha_tyvar + [nothingDataCon, justDataCon] + +nothingDataCon :: DataCon +nothingDataCon = pcDataCon nothingDataConName alpha_tyvar [] maybeTyCon + +justDataCon :: DataCon +justDataCon = pcDataCon justDataConName alpha_tyvar [alphaTy] maybeTyCon + +{- +** ********************************************************************* +* * + The tuple types +* * +************************************************************************ + +The tuple types are definitely magic, because they form an infinite +family. + +\begin{itemize} +\item +They have a special family of type constructors, of type @TyCon@ +These contain the tycon arity, but don't require a Unique. + +\item +They have a special family of constructors, of type +@Id@. Again these contain their arity but don't need a Unique. + +\item +There should be a magic way of generating the info tables and +entry code for all tuples. + +But at the moment we just compile a Haskell source +file\srcloc{lib/prelude/...} containing declarations like: +\begin{verbatim} +data Tuple0 = Tup0 +data Tuple2 a b = Tup2 a b +data Tuple3 a b c = Tup3 a b c +data Tuple4 a b c d = Tup4 a b c d +... +\end{verbatim} +The print-names associated with the magic @Id@s for tuple constructors +``just happen'' to be the same as those generated by these +declarations. + +\item +The instance environment should have a magic way to know +that each tuple type is an instances of classes @Eq@, @Ix@, @Ord@ and +so on. \ToDo{Not implemented yet.} + +\item +There should also be a way to generate the appropriate code for each +of these instances, but (like the info tables and entry code) it is +done by enumeration\srcloc{lib/prelude/InTup?.hs}. +\end{itemize} +-} + +-- | Make a tuple type. The list of types should /not/ include any +-- RuntimeRep specifications. +mkTupleTy :: Boxity -> [Type] -> Type +-- Special case for *boxed* 1-tuples, which are represented by the type itself +mkTupleTy Boxed [ty] = ty +mkTupleTy Boxed tys = mkTyConApp (tupleTyCon Boxed (length tys)) tys +mkTupleTy Unboxed tys = mkTyConApp (tupleTyCon Unboxed (length tys)) + (map getRuntimeRep tys ++ tys) + +-- | Build the type of a small tuple that holds the specified type of thing +mkBoxedTupleTy :: [Type] -> Type +mkBoxedTupleTy tys = mkTupleTy Boxed tys + +unitTy :: Type +unitTy = mkTupleTy Boxed [] + +{- ********************************************************************* +* * + The sum types +* * +************************************************************************ +-} + +mkSumTy :: [Type] -> Type +mkSumTy tys = mkTyConApp (sumTyCon (length tys)) + (map getRuntimeRep tys ++ tys) + +-- Promoted Booleans + +promotedFalseDataCon, promotedTrueDataCon :: TyCon +promotedTrueDataCon = promoteDataCon trueDataCon +promotedFalseDataCon = promoteDataCon falseDataCon + +-- Promoted Maybe +promotedNothingDataCon, promotedJustDataCon :: TyCon +promotedNothingDataCon = promoteDataCon nothingDataCon +promotedJustDataCon = promoteDataCon justDataCon + +-- Promoted Ordering + +promotedLTDataCon + , promotedEQDataCon + , promotedGTDataCon + :: TyCon +promotedLTDataCon = promoteDataCon ordLTDataCon +promotedEQDataCon = promoteDataCon ordEQDataCon +promotedGTDataCon = promoteDataCon ordGTDataCon + +-- Promoted List +promotedConsDataCon, promotedNilDataCon :: TyCon +promotedConsDataCon = promoteDataCon consDataCon +promotedNilDataCon = promoteDataCon nilDataCon + +-- | Make a *promoted* list. +mkPromotedListTy :: Kind -- ^ of the elements of the list + -> [Type] -- ^ elements + -> Type +mkPromotedListTy k tys + = foldr cons nil tys + where + cons :: Type -- element + -> Type -- list + -> Type + cons elt list = mkTyConApp promotedConsDataCon [k, elt, list] + + nil :: Type + nil = mkTyConApp promotedNilDataCon [k] + +-- | Extract the elements of a promoted list. Panics if the type is not a +-- promoted list +extractPromotedList :: Type -- ^ The promoted list + -> [Type] +extractPromotedList tys = go tys + where + go list_ty + | Just (tc, [_k, t, ts]) <- splitTyConApp_maybe list_ty + = ASSERT( tc `hasKey` consDataConKey ) + t : go ts + + | Just (tc, [_k]) <- splitTyConApp_maybe list_ty + = ASSERT( tc `hasKey` nilDataConKey ) + [] + + | otherwise + = pprPanic "extractPromotedList" (ppr tys) diff --git a/compiler/prelude/TysWiredIn.hs-boot b/compiler/prelude/TysWiredIn.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/prelude/TysWiredIn.hs-boot @@ -0,0 +1,37 @@ +module TysWiredIn where + +import {-# SOURCE #-} TyCon ( TyCon ) +import {-# SOURCE #-} TyCoRep (Type, Kind) + +listTyCon :: TyCon +typeNatKind, typeSymbolKind :: Type +mkBoxedTupleTy :: [Type] -> Type + +coercibleTyCon, heqTyCon :: TyCon + +unitTy :: Type + +liftedTypeKind :: Kind +constraintKind :: Kind + +runtimeRepTyCon, vecCountTyCon, vecElemTyCon :: TyCon +runtimeRepTy :: Type + +liftedRepDataConTyCon, vecRepDataConTyCon, tupleRepDataConTyCon :: TyCon + +liftedRepDataConTy, unliftedRepDataConTy, intRepDataConTy, int8RepDataConTy, + int16RepDataConTy, word16RepDataConTy, + wordRepDataConTy, int64RepDataConTy, word8RepDataConTy, word64RepDataConTy, + addrRepDataConTy, floatRepDataConTy, doubleRepDataConTy :: Type + +vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy, + vec64DataConTy :: Type + +int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy, + int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy, + word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy, + doubleElemRepDataConTy :: Type + +anyTypeOfKind :: Kind -> Type +unboxedTupleKind :: [Type] -> Type +mkPromotedListTy :: Type -> [Type] -> Type diff --git a/compiler/profiling/CostCentre.hs b/compiler/profiling/CostCentre.hs new file mode 100644 --- /dev/null +++ b/compiler/profiling/CostCentre.hs @@ -0,0 +1,359 @@ +{-# LANGUAGE DeriveDataTypeable #-} +module CostCentre ( + CostCentre(..), CcName, CCFlavour(..), + -- All abstract except to friend: ParseIface.y + + CostCentreStack, + CollectedCCs, emptyCollectedCCs, collectCC, + currentCCS, dontCareCCS, + isCurrentCCS, + maybeSingletonCCS, + + mkUserCC, mkAutoCC, mkAllCafsCC, + mkSingletonCCS, + isCafCCS, isCafCC, isSccCountCC, sccAbleCC, ccFromThisModule, + + pprCostCentreCore, + costCentreUserName, costCentreUserNameFS, + costCentreSrcSpan, + + cmpCostCentre -- used for removing dups in a list + ) where + +import GhcPrelude + +import Binary +import Var +import Name +import Module +import Unique +import Outputable +import SrcLoc +import FastString +import Util +import CostCentreState + +import Data.Data + +----------------------------------------------------------------------------- +-- Cost Centres + +-- | A Cost Centre is a single @{-# SCC #-}@ annotation. + +data CostCentre + = NormalCC { + cc_flavour :: CCFlavour, + -- ^ Two cost centres may have the same name and + -- module but different SrcSpans, so we need a way to + -- distinguish them easily and give them different + -- object-code labels. So every CostCentre has an + -- associated flavour that indicates how it was + -- generated, and flavours that allow multiple instances + -- of the same name and module have a deterministic 0-based + -- index. + cc_name :: CcName, -- ^ Name of the cost centre itself + cc_mod :: Module, -- ^ Name of module defining this CC. + cc_loc :: SrcSpan + } + + | AllCafsCC { + cc_mod :: Module, -- Name of module defining this CC. + cc_loc :: SrcSpan + } + deriving Data + +type CcName = FastString + +-- | The flavour of a cost centre. +-- +-- Index fields represent 0-based indices giving source-code ordering of +-- centres with the same module, name, and flavour. +data CCFlavour = CafCC -- ^ Auto-generated top-level thunk + | ExprCC !CostCentreIndex -- ^ Explicitly annotated expression + | DeclCC !CostCentreIndex -- ^ Explicitly annotated declaration + | HpcCC !CostCentreIndex -- ^ Generated by HPC for coverage + deriving (Eq, Ord, Data) + +-- | Extract the index from a flavour +flavourIndex :: CCFlavour -> Int +flavourIndex CafCC = 0 +flavourIndex (ExprCC x) = unCostCentreIndex x +flavourIndex (DeclCC x) = unCostCentreIndex x +flavourIndex (HpcCC x) = unCostCentreIndex x + +instance Eq CostCentre where + c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False } + +instance Ord CostCentre where + compare = cmpCostCentre + +cmpCostCentre :: CostCentre -> CostCentre -> Ordering + +cmpCostCentre (AllCafsCC {cc_mod = m1}) (AllCafsCC {cc_mod = m2}) + = m1 `compare` m2 + +cmpCostCentre NormalCC {cc_flavour = f1, cc_mod = m1, cc_name = n1} + NormalCC {cc_flavour = f2, cc_mod = m2, cc_name = n2} + -- first key is module name, then centre name, then flavour + = (m1 `compare` m2) `thenCmp` (n1 `compare` n2) `thenCmp` (f1 `compare` f2) + +cmpCostCentre other_1 other_2 + = let + tag1 = tag_CC other_1 + tag2 = tag_CC other_2 + in + if tag1 < tag2 then LT else GT + where + tag_CC :: CostCentre -> Int + tag_CC (NormalCC {}) = 0 + tag_CC (AllCafsCC {}) = 1 + + +----------------------------------------------------------------------------- +-- Predicates on CostCentre + +isCafCC :: CostCentre -> Bool +isCafCC (AllCafsCC {}) = True +isCafCC (NormalCC {cc_flavour = CafCC}) = True +isCafCC _ = False + +-- | Is this a cost-centre which records scc counts +isSccCountCC :: CostCentre -> Bool +isSccCountCC cc | isCafCC cc = False + | otherwise = True + +-- | Is this a cost-centre which can be sccd ? +sccAbleCC :: CostCentre -> Bool +sccAbleCC cc | isCafCC cc = False + | otherwise = True + +ccFromThisModule :: CostCentre -> Module -> Bool +ccFromThisModule cc m = cc_mod cc == m + + +----------------------------------------------------------------------------- +-- Building cost centres + +mkUserCC :: FastString -> Module -> SrcSpan -> CCFlavour -> CostCentre +mkUserCC cc_name mod loc flavour + = NormalCC { cc_name = cc_name, cc_mod = mod, cc_loc = loc, + cc_flavour = flavour + } + +mkAutoCC :: Id -> Module -> CostCentre +mkAutoCC id mod + = NormalCC { cc_name = str, cc_mod = mod, + cc_loc = nameSrcSpan (getName id), + cc_flavour = CafCC + } + where + name = getName id + -- beware: only external names are guaranteed to have unique + -- Occnames. If the name is not external, we must append its + -- Unique. + -- See bug #249, tests prof001, prof002, also #2411 + str | isExternalName name = occNameFS (getOccName id) + | otherwise = occNameFS (getOccName id) + `appendFS` + mkFastString ('_' : show (getUnique name)) +mkAllCafsCC :: Module -> SrcSpan -> CostCentre +mkAllCafsCC m loc = AllCafsCC { cc_mod = m, cc_loc = loc } + +----------------------------------------------------------------------------- +-- Cost Centre Stacks + +-- | A Cost Centre Stack is something that can be attached to a closure. +-- This is either: +-- +-- * the current cost centre stack (CCCS) +-- * a pre-defined cost centre stack (there are several +-- pre-defined CCSs, see below). + +data CostCentreStack + = CurrentCCS -- Pinned on a let(rec)-bound + -- thunk/function/constructor, this says that the + -- cost centre to be attached to the object, when it + -- is allocated, is whatever is in the + -- current-cost-centre-stack register. + + | DontCareCCS -- We need a CCS to stick in static closures + -- (for data), but we *don't* expect them to + -- accumulate any costs. But we still need + -- the placeholder. This CCS is it. + + | SingletonCCS CostCentre + + deriving (Eq, Ord) -- needed for Ord on CLabel + + +-- synonym for triple which describes the cost centre info in the generated +-- code for a module. +type CollectedCCs + = ( [CostCentre] -- local cost-centres that need to be decl'd + , [CostCentreStack] -- pre-defined "singleton" cost centre stacks + ) + +emptyCollectedCCs :: CollectedCCs +emptyCollectedCCs = ([], []) + +collectCC :: CostCentre -> CostCentreStack -> CollectedCCs -> CollectedCCs +collectCC cc ccs (c, cs) = (cc : c, ccs : cs) + +currentCCS, dontCareCCS :: CostCentreStack + +currentCCS = CurrentCCS +dontCareCCS = DontCareCCS + +----------------------------------------------------------------------------- +-- Predicates on Cost-Centre Stacks + +isCurrentCCS :: CostCentreStack -> Bool +isCurrentCCS CurrentCCS = True +isCurrentCCS _ = False + +isCafCCS :: CostCentreStack -> Bool +isCafCCS (SingletonCCS cc) = isCafCC cc +isCafCCS _ = False + +maybeSingletonCCS :: CostCentreStack -> Maybe CostCentre +maybeSingletonCCS (SingletonCCS cc) = Just cc +maybeSingletonCCS _ = Nothing + +mkSingletonCCS :: CostCentre -> CostCentreStack +mkSingletonCCS cc = SingletonCCS cc + + +----------------------------------------------------------------------------- +-- Printing Cost Centre Stacks. + +-- The outputable instance for CostCentreStack prints the CCS as a C +-- expression. + +instance Outputable CostCentreStack where + ppr CurrentCCS = text "CCCS" + ppr DontCareCCS = text "CCS_DONT_CARE" + ppr (SingletonCCS cc) = ppr cc <> text "_ccs" + + +----------------------------------------------------------------------------- +-- Printing Cost Centres +-- +-- There are several different ways in which we might want to print a +-- cost centre: +-- +-- - the name of the cost centre, for profiling output (a C string) +-- - the label, i.e. C label for cost centre in .hc file. +-- - the debugging name, for output in -ddump things +-- - the interface name, for printing in _scc_ exprs in iface files. +-- +-- The last 3 are derived from costCentreStr below. The first is given +-- by costCentreName. + +instance Outputable CostCentre where + ppr cc = getPprStyle $ \ sty -> + if codeStyle sty + then ppCostCentreLbl cc + else text (costCentreUserName cc) + +-- Printing in Core +pprCostCentreCore :: CostCentre -> SDoc +pprCostCentreCore (AllCafsCC {cc_mod = m}) + = text "__sccC" <+> braces (ppr m) +pprCostCentreCore (NormalCC {cc_flavour = flavour, cc_name = n, + cc_mod = m, cc_loc = loc}) + = text "__scc" <+> braces (hsep [ + ppr m <> char '.' <> ftext n, + pprFlavourCore flavour, + whenPprDebug (ppr loc) + ]) + +-- ^ Print a flavour in Core +pprFlavourCore :: CCFlavour -> SDoc +pprFlavourCore CafCC = text "__C" +pprFlavourCore f = pprIdxCore $ flavourIndex f + +-- ^ Print a flavour's index in Core +pprIdxCore :: Int -> SDoc +pprIdxCore 0 = empty +pprIdxCore idx = whenPprDebug $ ppr idx + +-- Printing as a C label +ppCostCentreLbl :: CostCentre -> SDoc +ppCostCentreLbl (AllCafsCC {cc_mod = m}) = ppr m <> text "_CAFs_cc" +ppCostCentreLbl (NormalCC {cc_flavour = f, cc_name = n, cc_mod = m}) + = ppr m <> char '_' <> ztext (zEncodeFS n) <> char '_' <> + ppFlavourLblComponent f <> text "_cc" + +-- ^ Print the flavour component of a C label +ppFlavourLblComponent :: CCFlavour -> SDoc +ppFlavourLblComponent CafCC = text "CAF" +ppFlavourLblComponent (ExprCC i) = text "EXPR" <> ppIdxLblComponent i +ppFlavourLblComponent (DeclCC i) = text "DECL" <> ppIdxLblComponent i +ppFlavourLblComponent (HpcCC i) = text "HPC" <> ppIdxLblComponent i + +-- ^ Print the flavour index component of a C label +ppIdxLblComponent :: CostCentreIndex -> SDoc +ppIdxLblComponent n = + case unCostCentreIndex n of + 0 -> empty + n -> ppr n + +-- This is the name to go in the user-displayed string, +-- recorded in the cost centre declaration +costCentreUserName :: CostCentre -> String +costCentreUserName = unpackFS . costCentreUserNameFS + +costCentreUserNameFS :: CostCentre -> FastString +costCentreUserNameFS (AllCafsCC {}) = mkFastString "CAF" +costCentreUserNameFS (NormalCC {cc_name = name, cc_flavour = is_caf}) + = case is_caf of + CafCC -> mkFastString "CAF:" `appendFS` name + _ -> name + +costCentreSrcSpan :: CostCentre -> SrcSpan +costCentreSrcSpan = cc_loc + +instance Binary CCFlavour where + put_ bh CafCC = do + putByte bh 0 + put_ bh (ExprCC i) = do + putByte bh 1 + put_ bh i + put_ bh (DeclCC i) = do + putByte bh 2 + put_ bh i + put_ bh (HpcCC i) = do + putByte bh 3 + put_ bh i + get bh = do + h <- getByte bh + case h of + 0 -> do return CafCC + 1 -> ExprCC <$> get bh + 2 -> DeclCC <$> get bh + _ -> HpcCC <$> get bh + +instance Binary CostCentre where + put_ bh (NormalCC aa ab ac _ad) = do + putByte bh 0 + put_ bh aa + put_ bh ab + put_ bh ac + put_ bh (AllCafsCC ae _af) = do + putByte bh 1 + put_ bh ae + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + ab <- get bh + ac <- get bh + return (NormalCC aa ab ac noSrcSpan) + _ -> do ae <- get bh + return (AllCafsCC ae noSrcSpan) + + -- We ignore the SrcSpans in CostCentres when we serialise them, + -- and set the SrcSpans to noSrcSpan when deserialising. This is + -- ok, because we only need the SrcSpan when declaring the + -- CostCentre in the original module, it is not used by importing + -- modules. diff --git a/compiler/profiling/CostCentreState.hs b/compiler/profiling/CostCentreState.hs new file mode 100644 --- /dev/null +++ b/compiler/profiling/CostCentreState.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module CostCentreState ( CostCentreState, newCostCentreState + , CostCentreIndex, unCostCentreIndex, getCCIndex + ) where + +import GhcPrelude +import FastString +import FastStringEnv + +import Data.Data +import Binary + +-- | Per-module state for tracking cost centre indices. +-- +-- See documentation of 'CostCentre.cc_flavour' for more details. +newtype CostCentreState = CostCentreState (FastStringEnv Int) + +-- | Initialize cost centre state. +newCostCentreState :: CostCentreState +newCostCentreState = CostCentreState emptyFsEnv + +-- | An index into a given cost centre module,name,flavour set +newtype CostCentreIndex = CostCentreIndex { unCostCentreIndex :: Int } + deriving (Eq, Ord, Data, Binary) + +-- | Get a new index for a given cost centre name. +getCCIndex :: FastString + -> CostCentreState + -> (CostCentreIndex, CostCentreState) +getCCIndex nm (CostCentreState m) = + (CostCentreIndex idx, CostCentreState m') + where + m_idx = lookupFsEnv m nm + idx = maybe 0 id m_idx + m' = extendFsEnv m nm (idx + 1) diff --git a/compiler/simplCore/CoreMonad.hs b/compiler/simplCore/CoreMonad.hs new file mode 100644 --- /dev/null +++ b/compiler/simplCore/CoreMonad.hs @@ -0,0 +1,837 @@ +{- +(c) The AQUA Project, Glasgow University, 1993-1998 + +\section[CoreMonad]{The core pipeline monad} +-} + +{-# LANGUAGE CPP #-} + +module CoreMonad ( + -- * Configuration of the core-to-core passes + CoreToDo(..), runWhen, runMaybe, + SimplMode(..), + FloatOutSwitches(..), + pprPassDetails, + + -- * Plugins + CorePluginPass, bindsOnlyPass, + + -- * Counting + SimplCount, doSimplTick, doFreeSimplTick, simplCountN, + pprSimplCount, plusSimplCount, zeroSimplCount, + isZeroSimplCount, hasDetailedCounts, Tick(..), + + -- * The monad + CoreM, runCoreM, + + -- ** Reading from the monad + getHscEnv, getRuleBase, getModule, + getDynFlags, getOrigNameCache, getPackageFamInstEnv, + getVisibleOrphanMods, + getPrintUnqualified, getSrcSpanM, + + -- ** Writing to the monad + addSimplCount, + + -- ** Lifting into the monad + liftIO, liftIOWithCount, + liftIO1, liftIO2, liftIO3, liftIO4, + + -- ** Dealing with annotations + getAnnotations, getFirstAnnotations, + + -- ** Screen output + putMsg, putMsgS, errorMsg, errorMsgS, warnMsg, + fatalErrorMsg, fatalErrorMsgS, + debugTraceMsg, debugTraceMsgS, + dumpIfSet_dyn + ) where + +import GhcPrelude hiding ( read ) + +import CoreSyn +import HscTypes +import Module +import DynFlags +import BasicTypes ( CompilerPhase(..) ) +import Annotations + +import IOEnv hiding ( liftIO, failM, failWithM ) +import qualified IOEnv ( liftIO ) +import Var +import Outputable +import FastString +import qualified ErrUtils as Err +import ErrUtils( Severity(..) ) +import UniqSupply +import UniqFM ( UniqFM, mapUFM, filterUFM ) +import MonadUtils +import NameCache +import SrcLoc +import Data.List +import Data.Ord +import Data.Dynamic +import Data.IORef +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Map.Strict as MapStrict +import Data.Word +import Control.Monad +import Control.Applicative ( Alternative(..) ) + +{- +************************************************************************ +* * + The CoreToDo type and related types + Abstraction of core-to-core passes to run. +* * +************************************************************************ +-} + +data CoreToDo -- These are diff core-to-core passes, + -- which may be invoked in any order, + -- as many times as you like. + + = CoreDoSimplify -- The core-to-core simplifier. + Int -- Max iterations + SimplMode + | CoreDoPluginPass String CorePluginPass + | CoreDoFloatInwards + | CoreDoFloatOutwards FloatOutSwitches + | CoreLiberateCase + | CoreDoPrintCore + | CoreDoStaticArgs + | CoreDoCallArity + | CoreDoExitify + | CoreDoStrictness + | CoreDoWorkerWrapper + | CoreDoSpecialising + | CoreDoSpecConstr + | CoreCSE + | CoreDoRuleCheck CompilerPhase String -- Check for non-application of rules + -- matching this string + | CoreDoNothing -- Useful when building up + | CoreDoPasses [CoreToDo] -- lists of these things + + | CoreDesugar -- Right after desugaring, no simple optimisation yet! + | CoreDesugarOpt -- CoreDesugarXXX: Not strictly a core-to-core pass, but produces + -- Core output, and hence useful to pass to endPass + + | CoreTidy + | CorePrep + | CoreOccurAnal + +instance Outputable CoreToDo where + ppr (CoreDoSimplify _ _) = text "Simplifier" + ppr (CoreDoPluginPass s _) = text "Core plugin: " <+> text s + ppr CoreDoFloatInwards = text "Float inwards" + ppr (CoreDoFloatOutwards f) = text "Float out" <> parens (ppr f) + ppr CoreLiberateCase = text "Liberate case" + ppr CoreDoStaticArgs = text "Static argument" + ppr CoreDoCallArity = text "Called arity analysis" + ppr CoreDoExitify = text "Exitification transformation" + ppr CoreDoStrictness = text "Demand analysis" + ppr CoreDoWorkerWrapper = text "Worker Wrapper binds" + ppr CoreDoSpecialising = text "Specialise" + ppr CoreDoSpecConstr = text "SpecConstr" + ppr CoreCSE = text "Common sub-expression" + ppr CoreDesugar = text "Desugar (before optimization)" + ppr CoreDesugarOpt = text "Desugar (after optimization)" + ppr CoreTidy = text "Tidy Core" + ppr CorePrep = text "CorePrep" + ppr CoreOccurAnal = text "Occurrence analysis" + ppr CoreDoPrintCore = text "Print core" + ppr (CoreDoRuleCheck {}) = text "Rule check" + ppr CoreDoNothing = text "CoreDoNothing" + ppr (CoreDoPasses passes) = text "CoreDoPasses" <+> ppr passes + +pprPassDetails :: CoreToDo -> SDoc +pprPassDetails (CoreDoSimplify n md) = vcat [ text "Max iterations =" <+> int n + , ppr md ] +pprPassDetails _ = Outputable.empty + +data SimplMode -- See comments in SimplMonad + = SimplMode + { sm_names :: [String] -- Name(s) of the phase + , sm_phase :: CompilerPhase + , sm_dflags :: DynFlags -- Just for convenient non-monadic + -- access; we don't override these + , sm_rules :: Bool -- Whether RULES are enabled + , sm_inline :: Bool -- Whether inlining is enabled + , sm_case_case :: Bool -- Whether case-of-case is enabled + , sm_eta_expand :: Bool -- Whether eta-expansion is enabled + } + +instance Outputable SimplMode where + ppr (SimplMode { sm_phase = p, sm_names = ss + , sm_rules = r, sm_inline = i + , sm_eta_expand = eta, sm_case_case = cc }) + = text "SimplMode" <+> braces ( + sep [ text "Phase =" <+> ppr p <+> + brackets (text (concat $ intersperse "," ss)) <> comma + , pp_flag i (sLit "inline") <> comma + , pp_flag r (sLit "rules") <> comma + , pp_flag eta (sLit "eta-expand") <> comma + , pp_flag cc (sLit "case-of-case") ]) + where + pp_flag f s = ppUnless f (text "no") <+> ptext s + +data FloatOutSwitches = FloatOutSwitches { + floatOutLambdas :: Maybe Int, -- ^ Just n <=> float lambdas to top level, if + -- doing so will abstract over n or fewer + -- value variables + -- Nothing <=> float all lambdas to top level, + -- regardless of how many free variables + -- Just 0 is the vanilla case: float a lambda + -- iff it has no free vars + + floatOutConstants :: Bool, -- ^ True <=> float constants to top level, + -- even if they do not escape a lambda + floatOutOverSatApps :: Bool, + -- ^ True <=> float out over-saturated applications + -- based on arity information. + -- See Note [Floating over-saturated applications] + -- in SetLevels + floatToTopLevelOnly :: Bool -- ^ Allow floating to the top level only. + } +instance Outputable FloatOutSwitches where + ppr = pprFloatOutSwitches + +pprFloatOutSwitches :: FloatOutSwitches -> SDoc +pprFloatOutSwitches sw + = text "FOS" <+> (braces $ + sep $ punctuate comma $ + [ text "Lam =" <+> ppr (floatOutLambdas sw) + , text "Consts =" <+> ppr (floatOutConstants sw) + , text "OverSatApps =" <+> ppr (floatOutOverSatApps sw) ]) + +-- The core-to-core pass ordering is derived from the DynFlags: +runWhen :: Bool -> CoreToDo -> CoreToDo +runWhen True do_this = do_this +runWhen False _ = CoreDoNothing + +runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo +runMaybe (Just x) f = f x +runMaybe Nothing _ = CoreDoNothing + +{- + +************************************************************************ +* * + Types for Plugins +* * +************************************************************************ +-} + +-- | A description of the plugin pass itself +type CorePluginPass = ModGuts -> CoreM ModGuts + +bindsOnlyPass :: (CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts +bindsOnlyPass pass guts + = do { binds' <- pass (mg_binds guts) + ; return (guts { mg_binds = binds' }) } + +{- +************************************************************************ +* * + Counting and logging +* * +************************************************************************ +-} + +getVerboseSimplStats :: (Bool -> SDoc) -> SDoc +getVerboseSimplStats = getPprDebug -- For now, anyway + +zeroSimplCount :: DynFlags -> SimplCount +isZeroSimplCount :: SimplCount -> Bool +hasDetailedCounts :: SimplCount -> Bool +pprSimplCount :: SimplCount -> SDoc +doSimplTick :: DynFlags -> Tick -> SimplCount -> SimplCount +doFreeSimplTick :: Tick -> SimplCount -> SimplCount +plusSimplCount :: SimplCount -> SimplCount -> SimplCount + +data SimplCount + = VerySimplCount !Int -- Used when don't want detailed stats + + | SimplCount { + ticks :: !Int, -- Total ticks + details :: !TickCounts, -- How many of each type + + n_log :: !Int, -- N + log1 :: [Tick], -- Last N events; <= opt_HistorySize, + -- most recent first + log2 :: [Tick] -- Last opt_HistorySize events before that + -- Having log1, log2 lets us accumulate the + -- recent history reasonably efficiently + } + +type TickCounts = Map Tick Int + +simplCountN :: SimplCount -> Int +simplCountN (VerySimplCount n) = n +simplCountN (SimplCount { ticks = n }) = n + +zeroSimplCount dflags + -- This is where we decide whether to do + -- the VerySimpl version or the full-stats version + | dopt Opt_D_dump_simpl_stats dflags + = SimplCount {ticks = 0, details = Map.empty, + n_log = 0, log1 = [], log2 = []} + | otherwise + = VerySimplCount 0 + +isZeroSimplCount (VerySimplCount n) = n==0 +isZeroSimplCount (SimplCount { ticks = n }) = n==0 + +hasDetailedCounts (VerySimplCount {}) = False +hasDetailedCounts (SimplCount {}) = True + +doFreeSimplTick tick sc@SimplCount { details = dts } + = sc { details = dts `addTick` tick } +doFreeSimplTick _ sc = sc + +doSimplTick dflags tick + sc@(SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 }) + | nl >= historySize dflags = sc1 { n_log = 1, log1 = [tick], log2 = l1 } + | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 } + where + sc1 = sc { ticks = tks+1, details = dts `addTick` tick } + +doSimplTick _ _ (VerySimplCount n) = VerySimplCount (n+1) + + +addTick :: TickCounts -> Tick -> TickCounts +addTick fm tick = MapStrict.insertWith (+) tick 1 fm + +plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 }) + sc2@(SimplCount { ticks = tks2, details = dts2 }) + = log_base { ticks = tks1 + tks2 + , details = MapStrict.unionWith (+) dts1 dts2 } + where + -- A hackish way of getting recent log info + log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2 + | null (log2 sc2) = sc2 { log2 = log1 sc1 } + | otherwise = sc2 + +plusSimplCount (VerySimplCount n) (VerySimplCount m) = VerySimplCount (n+m) +plusSimplCount _ _ = panic "plusSimplCount" + -- We use one or the other consistently + +pprSimplCount (VerySimplCount n) = text "Total ticks:" <+> int n +pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 }) + = vcat [text "Total ticks: " <+> int tks, + blankLine, + pprTickCounts dts, + getVerboseSimplStats $ \dbg -> if dbg + then + vcat [blankLine, + text "Log (most recent first)", + nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))] + else Outputable.empty + ] + +{- Note [Which transformations are innocuous] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +At one point (Jun 18) I wondered if some transformations (ticks) +might be "innocuous", in the sense that they do not unlock a later +transformation that does not occur in the same pass. If so, we could +refrain from bumping the overall tick-count for such innocuous +transformations, and perhaps terminate the simplifier one pass +earlier. + +BUt alas I found that virtually nothing was innocuous! This Note +just records what I learned, in case anyone wants to try again. + +These transformations are not innocuous: + +*** NB: I think these ones could be made innocuous + EtaExpansion + LetFloatFromLet + +LetFloatFromLet + x = K (let z = e2 in Just z) + prepareRhs transforms to + x2 = let z=e2 in Just z + x = K xs + And now more let-floating can happen in the + next pass, on x2 + +PreInlineUnconditionally + Example in spectral/cichelli/Auxil + hinsert = ...let lo = e in + let j = ...lo... in + case x of + False -> () + True -> case lo of I# lo' -> + ...j... + When we PreInlineUnconditionally j, lo's occ-info changes to once, + so it can be PreInlineUnconditionally in the next pass, and a + cascade of further things can happen. + +PostInlineUnconditionally + let x = e in + let y = ...x.. in + case .. of { A -> ...x...y... + B -> ...x...y... } + Current postinlineUnconditinaly will inline y, and then x; sigh. + + But PostInlineUnconditionally might also unlock subsequent + transformations for the same reason as PreInlineUnconditionally, + so it's probably not innocuous anyway. + +KnownBranch, BetaReduction: + May drop chunks of code, and thereby enable PreInlineUnconditionally + for some let-binding which now occurs once + +EtaExpansion: + Example in imaginary/digits-of-e1 + fail = \void. e where e :: IO () + --> etaExpandRhs + fail = \void. (\s. (e |> g) s) |> sym g where g :: IO () ~ S -> (S,()) + --> Next iteration of simplify + fail1 = \void. \s. (e |> g) s + fail = fail1 |> Void#->sym g + And now inline 'fail' + +CaseMerge: + case x of y { + DEFAULT -> case y of z { pi -> ei } + alts2 } + ---> CaseMerge + case x of { pi -> let z = y in ei + ; alts2 } + The "let z=y" case-binder-swap gets dealt with in the next pass +-} + +pprTickCounts :: Map Tick Int -> SDoc +pprTickCounts counts + = vcat (map pprTickGroup groups) + where + groups :: [[(Tick,Int)]] -- Each group shares a comon tag + -- toList returns common tags adjacent + groups = groupBy same_tag (Map.toList counts) + same_tag (tick1,_) (tick2,_) = tickToTag tick1 == tickToTag tick2 + +pprTickGroup :: [(Tick, Int)] -> SDoc +pprTickGroup group@((tick1,_):_) + = hang (int (sum [n | (_,n) <- group]) <+> text (tickString tick1)) + 2 (vcat [ int n <+> pprTickCts tick + -- flip as we want largest first + | (tick,n) <- sortBy (flip (comparing snd)) group]) +pprTickGroup [] = panic "pprTickGroup" + +data Tick -- See Note [Which transformations are innocuous] + = PreInlineUnconditionally Id + | PostInlineUnconditionally Id + + | UnfoldingDone Id + | RuleFired FastString -- Rule name + + | LetFloatFromLet + | EtaExpansion Id -- LHS binder + | EtaReduction Id -- Binder on outer lambda + | BetaReduction Id -- Lambda binder + + + | CaseOfCase Id -- Bndr on *inner* case + | KnownBranch Id -- Case binder + | CaseMerge Id -- Binder on outer case + | AltMerge Id -- Case binder + | CaseElim Id -- Case binder + | CaseIdentity Id -- Case binder + | FillInCaseDefault Id -- Case binder + + | SimplifierDone -- Ticked at each iteration of the simplifier + +instance Outputable Tick where + ppr tick = text (tickString tick) <+> pprTickCts tick + +instance Eq Tick where + a == b = case a `cmpTick` b of + EQ -> True + _ -> False + +instance Ord Tick where + compare = cmpTick + +tickToTag :: Tick -> Int +tickToTag (PreInlineUnconditionally _) = 0 +tickToTag (PostInlineUnconditionally _) = 1 +tickToTag (UnfoldingDone _) = 2 +tickToTag (RuleFired _) = 3 +tickToTag LetFloatFromLet = 4 +tickToTag (EtaExpansion _) = 5 +tickToTag (EtaReduction _) = 6 +tickToTag (BetaReduction _) = 7 +tickToTag (CaseOfCase _) = 8 +tickToTag (KnownBranch _) = 9 +tickToTag (CaseMerge _) = 10 +tickToTag (CaseElim _) = 11 +tickToTag (CaseIdentity _) = 12 +tickToTag (FillInCaseDefault _) = 13 +tickToTag SimplifierDone = 16 +tickToTag (AltMerge _) = 17 + +tickString :: Tick -> String +tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally" +tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally" +tickString (UnfoldingDone _) = "UnfoldingDone" +tickString (RuleFired _) = "RuleFired" +tickString LetFloatFromLet = "LetFloatFromLet" +tickString (EtaExpansion _) = "EtaExpansion" +tickString (EtaReduction _) = "EtaReduction" +tickString (BetaReduction _) = "BetaReduction" +tickString (CaseOfCase _) = "CaseOfCase" +tickString (KnownBranch _) = "KnownBranch" +tickString (CaseMerge _) = "CaseMerge" +tickString (AltMerge _) = "AltMerge" +tickString (CaseElim _) = "CaseElim" +tickString (CaseIdentity _) = "CaseIdentity" +tickString (FillInCaseDefault _) = "FillInCaseDefault" +tickString SimplifierDone = "SimplifierDone" + +pprTickCts :: Tick -> SDoc +pprTickCts (PreInlineUnconditionally v) = ppr v +pprTickCts (PostInlineUnconditionally v)= ppr v +pprTickCts (UnfoldingDone v) = ppr v +pprTickCts (RuleFired v) = ppr v +pprTickCts LetFloatFromLet = Outputable.empty +pprTickCts (EtaExpansion v) = ppr v +pprTickCts (EtaReduction v) = ppr v +pprTickCts (BetaReduction v) = ppr v +pprTickCts (CaseOfCase v) = ppr v +pprTickCts (KnownBranch v) = ppr v +pprTickCts (CaseMerge v) = ppr v +pprTickCts (AltMerge v) = ppr v +pprTickCts (CaseElim v) = ppr v +pprTickCts (CaseIdentity v) = ppr v +pprTickCts (FillInCaseDefault v) = ppr v +pprTickCts _ = Outputable.empty + +cmpTick :: Tick -> Tick -> Ordering +cmpTick a b = case (tickToTag a `compare` tickToTag b) of + GT -> GT + EQ -> cmpEqTick a b + LT -> LT + +cmpEqTick :: Tick -> Tick -> Ordering +cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b +cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b +cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b +cmpEqTick (RuleFired a) (RuleFired b) = a `compare` b +cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b +cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b +cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b +cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b +cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b +cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b +cmpEqTick (AltMerge a) (AltMerge b) = a `compare` b +cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b +cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b +cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b +cmpEqTick _ _ = EQ + +{- +************************************************************************ +* * + Monad and carried data structure definitions +* * +************************************************************************ +-} + +newtype CoreState = CoreState { + cs_uniq_supply :: UniqSupply +} + +data CoreReader = CoreReader { + cr_hsc_env :: HscEnv, + cr_rule_base :: RuleBase, + cr_module :: Module, + cr_print_unqual :: PrintUnqualified, + cr_loc :: SrcSpan, -- Use this for log/error messages so they + -- are at least tagged with the right source file + cr_visible_orphan_mods :: !ModuleSet +} + +-- Note: CoreWriter used to be defined with data, rather than newtype. If it +-- is defined that way again, the cw_simpl_count field, at least, must be +-- strict to avoid a space leak (#7702). +newtype CoreWriter = CoreWriter { + cw_simpl_count :: SimplCount +} + +emptyWriter :: DynFlags -> CoreWriter +emptyWriter dflags = CoreWriter { + cw_simpl_count = zeroSimplCount dflags + } + +plusWriter :: CoreWriter -> CoreWriter -> CoreWriter +plusWriter w1 w2 = CoreWriter { + cw_simpl_count = (cw_simpl_count w1) `plusSimplCount` (cw_simpl_count w2) + } + +type CoreIOEnv = IOEnv CoreReader + +-- | The monad used by Core-to-Core passes to access common state, register simplification +-- statistics and so on +newtype CoreM a = CoreM { unCoreM :: CoreState -> CoreIOEnv (a, CoreState, CoreWriter) } + +instance Functor CoreM where + fmap = liftM + +instance Monad CoreM where + mx >>= f = CoreM $ \s -> do + (x, s', w1) <- unCoreM mx s + (y, s'', w2) <- unCoreM (f x) s' + let w = w1 `plusWriter` w2 + return $ seq w (y, s'', w) + -- forcing w before building the tuple avoids a space leak + -- (#7702) + +instance Applicative CoreM where + pure x = CoreM $ \s -> nop s x + (<*>) = ap + m *> k = m >>= \_ -> k + +instance Alternative CoreM where + empty = CoreM (const Control.Applicative.empty) + m <|> n = CoreM (\rs -> unCoreM m rs <|> unCoreM n rs) + +instance MonadPlus CoreM + +instance MonadUnique CoreM where + getUniqueSupplyM = do + us <- getS cs_uniq_supply + let (us1, us2) = splitUniqSupply us + modifyS (\s -> s { cs_uniq_supply = us2 }) + return us1 + + getUniqueM = do + us <- getS cs_uniq_supply + let (u,us') = takeUniqFromSupply us + modifyS (\s -> s { cs_uniq_supply = us' }) + return u + +runCoreM :: HscEnv + -> RuleBase + -> UniqSupply + -> Module + -> ModuleSet + -> PrintUnqualified + -> SrcSpan + -> CoreM a + -> IO (a, SimplCount) +runCoreM hsc_env rule_base us mod orph_imps print_unqual loc m + = liftM extract $ runIOEnv reader $ unCoreM m state + where + reader = CoreReader { + cr_hsc_env = hsc_env, + cr_rule_base = rule_base, + cr_module = mod, + cr_visible_orphan_mods = orph_imps, + cr_print_unqual = print_unqual, + cr_loc = loc + } + state = CoreState { + cs_uniq_supply = us + } + + extract :: (a, CoreState, CoreWriter) -> (a, SimplCount) + extract (value, _, writer) = (value, cw_simpl_count writer) + +{- +************************************************************************ +* * + Core combinators, not exported +* * +************************************************************************ +-} + +nop :: CoreState -> a -> CoreIOEnv (a, CoreState, CoreWriter) +nop s x = do + r <- getEnv + return (x, s, emptyWriter $ (hsc_dflags . cr_hsc_env) r) + +read :: (CoreReader -> a) -> CoreM a +read f = CoreM (\s -> getEnv >>= (\r -> nop s (f r))) + +getS :: (CoreState -> a) -> CoreM a +getS f = CoreM (\s -> nop s (f s)) + +modifyS :: (CoreState -> CoreState) -> CoreM () +modifyS f = CoreM (\s -> nop (f s) ()) + +write :: CoreWriter -> CoreM () +write w = CoreM (\s -> return ((), s, w)) + +-- \subsection{Lifting IO into the monad} + +-- | Lift an 'IOEnv' operation into 'CoreM' +liftIOEnv :: CoreIOEnv a -> CoreM a +liftIOEnv mx = CoreM (\s -> mx >>= (\x -> nop s x)) + +instance MonadIO CoreM where + liftIO = liftIOEnv . IOEnv.liftIO + +-- | Lift an 'IO' operation into 'CoreM' while consuming its 'SimplCount' +liftIOWithCount :: IO (SimplCount, a) -> CoreM a +liftIOWithCount what = liftIO what >>= (\(count, x) -> addSimplCount count >> return x) + +{- +************************************************************************ +* * + Reader, writer and state accessors +* * +************************************************************************ +-} + +getHscEnv :: CoreM HscEnv +getHscEnv = read cr_hsc_env + +getRuleBase :: CoreM RuleBase +getRuleBase = read cr_rule_base + +getVisibleOrphanMods :: CoreM ModuleSet +getVisibleOrphanMods = read cr_visible_orphan_mods + +getPrintUnqualified :: CoreM PrintUnqualified +getPrintUnqualified = read cr_print_unqual + +getSrcSpanM :: CoreM SrcSpan +getSrcSpanM = read cr_loc + +addSimplCount :: SimplCount -> CoreM () +addSimplCount count = write (CoreWriter { cw_simpl_count = count }) + +-- Convenience accessors for useful fields of HscEnv + +instance HasDynFlags CoreM where + getDynFlags = fmap hsc_dflags getHscEnv + +instance HasModule CoreM where + getModule = read cr_module + +-- | The original name cache is the current mapping from 'Module' and +-- 'OccName' to a compiler-wide unique 'Name' +getOrigNameCache :: CoreM OrigNameCache +getOrigNameCache = do + nameCacheRef <- fmap hsc_NC getHscEnv + liftIO $ fmap nsNames $ readIORef nameCacheRef + +getPackageFamInstEnv :: CoreM PackageFamInstEnv +getPackageFamInstEnv = do + hsc_env <- getHscEnv + eps <- liftIO $ hscEPS hsc_env + return $ eps_fam_inst_env eps + +{- +************************************************************************ +* * + Dealing with annotations +* * +************************************************************************ +-} + +-- | Get all annotations of a given type. This happens lazily, that is +-- no deserialization will take place until the [a] is actually demanded and +-- the [a] can also be empty (the UniqFM is not filtered). +-- +-- This should be done once at the start of a Core-to-Core pass that uses +-- annotations. +-- +-- See Note [Annotations] +getAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM [a]) +getAnnotations deserialize guts = do + hsc_env <- getHscEnv + ann_env <- liftIO $ prepareAnnotations hsc_env (Just guts) + return (deserializeAnns deserialize ann_env) + +-- | Get at most one annotation of a given type per Unique. +getFirstAnnotations :: Typeable a => ([Word8] -> a) -> ModGuts -> CoreM (UniqFM a) +getFirstAnnotations deserialize guts + = liftM (mapUFM head . filterUFM (not . null)) + $ getAnnotations deserialize guts + +{- +Note [Annotations] +~~~~~~~~~~~~~~~~~~ +A Core-to-Core pass that wants to make use of annotations calls +getAnnotations or getFirstAnnotations at the beginning to obtain a UniqFM with +annotations of a specific type. This produces all annotations from interface +files read so far. However, annotations from interface files read during the +pass will not be visible until getAnnotations is called again. This is similar +to how rules work and probably isn't too bad. + +The current implementation could be optimised a bit: when looking up +annotations for a thing from the HomePackageTable, we could search directly in +the module where the thing is defined rather than building one UniqFM which +contains all annotations we know of. This would work because annotations can +only be given to things defined in the same module. However, since we would +only want to deserialise every annotation once, we would have to build a cache +for every module in the HTP. In the end, it's probably not worth it as long as +we aren't using annotations heavily. + +************************************************************************ +* * + Direct screen output +* * +************************************************************************ +-} + +msg :: Severity -> SDoc -> CoreM () +msg sev doc + = do { dflags <- getDynFlags + ; loc <- getSrcSpanM + ; unqual <- getPrintUnqualified + ; let sty = case sev of + SevError -> err_sty + SevWarning -> err_sty + SevDump -> dump_sty + _ -> user_sty + err_sty = mkErrStyle dflags unqual + user_sty = mkUserStyle dflags unqual AllTheWay + dump_sty = mkDumpStyle dflags unqual + ; liftIO $ putLogMsg dflags NoReason sev loc sty doc } + +-- | Output a String message to the screen +putMsgS :: String -> CoreM () +putMsgS = putMsg . text + +-- | Output a message to the screen +putMsg :: SDoc -> CoreM () +putMsg = msg SevInfo + +-- | Output an error to the screen. Does not cause the compiler to die. +errorMsgS :: String -> CoreM () +errorMsgS = errorMsg . text + +-- | Output an error to the screen. Does not cause the compiler to die. +errorMsg :: SDoc -> CoreM () +errorMsg = msg SevError + +warnMsg :: SDoc -> CoreM () +warnMsg = msg SevWarning + +-- | Output a fatal error to the screen. Does not cause the compiler to die. +fatalErrorMsgS :: String -> CoreM () +fatalErrorMsgS = fatalErrorMsg . text + +-- | Output a fatal error to the screen. Does not cause the compiler to die. +fatalErrorMsg :: SDoc -> CoreM () +fatalErrorMsg = msg SevFatal + +-- | Output a string debugging message at verbosity level of @-v@ or higher +debugTraceMsgS :: String -> CoreM () +debugTraceMsgS = debugTraceMsg . text + +-- | Outputs a debugging message at verbosity level of @-v@ or higher +debugTraceMsg :: SDoc -> CoreM () +debugTraceMsg = msg SevDump + +-- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher +dumpIfSet_dyn :: DumpFlag -> String -> SDoc -> CoreM () +dumpIfSet_dyn flag str doc + = do { dflags <- getDynFlags + ; unqual <- getPrintUnqualified + ; when (dopt flag dflags) $ liftIO $ + Err.dumpSDoc dflags unqual flag str doc } diff --git a/compiler/simplCore/CoreMonad.hs-boot b/compiler/simplCore/CoreMonad.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/simplCore/CoreMonad.hs-boot @@ -0,0 +1,37 @@ +-- Created this hs-boot file to remove circular dependencies from the use of +-- Plugins. Plugins needs CoreToDo and CoreM types to define core-to-core +-- transformations. +-- However CoreMonad does much more than defining these, and because Plugins are +-- activated in various modules, the imports become circular. To solve this I +-- extracted CoreToDo and CoreM into this file. +-- I needed to write the whole definition of these types, otherwise it created +-- a data-newtype conflict. + +module CoreMonad ( CoreToDo, CoreM ) where + +import GhcPrelude + +import IOEnv ( IOEnv ) +import UniqSupply ( UniqSupply ) + +newtype CoreState = CoreState { + cs_uniq_supply :: UniqSupply +} + +type CoreIOEnv = IOEnv CoreReader + +data CoreReader + +newtype CoreWriter = CoreWriter { + cw_simpl_count :: SimplCount +} + +data SimplCount + +newtype CoreM a + = CoreM { unCoreM :: CoreState + -> CoreIOEnv (a, CoreState, CoreWriter) } + +instance Monad CoreM + +data CoreToDo diff --git a/compiler/simplCore/OccurAnal.hs b/compiler/simplCore/OccurAnal.hs new file mode 100644 --- /dev/null +++ b/compiler/simplCore/OccurAnal.hs @@ -0,0 +1,2891 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +************************************************************************ +* * +\section[OccurAnal]{Occurrence analysis pass} +* * +************************************************************************ + +The occurrence analyser re-typechecks a core expression, returning a new +core expression with (hopefully) improved usage information. +-} + +{-# LANGUAGE CPP, BangPatterns, MultiWayIf, ViewPatterns #-} + +module OccurAnal ( + occurAnalysePgm, occurAnalyseExpr, occurAnalyseExpr_NoBinderSwap + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import CoreSyn +import CoreFVs +import CoreUtils ( exprIsTrivial, isDefaultAlt, isExpandableApp, + stripTicksTopE, mkTicks ) +import CoreArity ( joinRhsArity ) +import Id +import IdInfo +import Name( localiseName ) +import BasicTypes +import Module( Module ) +import Coercion +import Type + +import VarSet +import VarEnv +import Var +import Demand ( argOneShots, argsOneShots ) +import Digraph ( SCC(..), Node(..) + , stronglyConnCompFromEdgedVerticesUniq + , stronglyConnCompFromEdgedVerticesUniqR ) +import Unique +import UniqFM +import UniqSet +import Util +import Outputable +import Data.List +import Control.Arrow ( second ) + +{- +************************************************************************ +* * + occurAnalysePgm, occurAnalyseExpr, occurAnalyseExpr_NoBinderSwap +* * +************************************************************************ + +Here's the externally-callable interface: +-} + +occurAnalysePgm :: Module -- Used only in debug output + -> (Id -> Bool) -- Active unfoldings + -> (Activation -> Bool) -- Active rules + -> [CoreRule] + -> CoreProgram -> CoreProgram +occurAnalysePgm this_mod active_unf active_rule imp_rules binds + | isEmptyDetails final_usage + = occ_anald_binds + + | otherwise -- See Note [Glomming] + = WARN( True, hang (text "Glomming in" <+> ppr this_mod <> colon) + 2 (ppr final_usage ) ) + occ_anald_glommed_binds + where + init_env = initOccEnv { occ_rule_act = active_rule + , occ_unf_act = active_unf } + + (final_usage, occ_anald_binds) = go init_env binds + (_, occ_anald_glommed_binds) = occAnalRecBind init_env TopLevel + imp_rule_edges + (flattenBinds occ_anald_binds) + initial_uds + -- It's crucial to re-analyse the glommed-together bindings + -- so that we establish the right loop breakers. Otherwise + -- we can easily create an infinite loop (#9583 is an example) + + initial_uds = addManyOccsSet emptyDetails + (rulesFreeVars imp_rules) + -- The RULES declarations keep things alive! + + -- Note [Preventing loops due to imported functions rules] + imp_rule_edges = foldr (plusVarEnv_C unionVarSet) emptyVarEnv + [ mapVarEnv (const maps_to) $ + getUniqSet (exprFreeIds arg `delVarSetList` ru_bndrs imp_rule) + | imp_rule <- imp_rules + , not (isBuiltinRule imp_rule) -- See Note [Plugin rules] + , let maps_to = exprFreeIds (ru_rhs imp_rule) + `delVarSetList` ru_bndrs imp_rule + , arg <- ru_args imp_rule ] + + go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind]) + go _ [] + = (initial_uds, []) + go env (bind:binds) + = (final_usage, bind' ++ binds') + where + (bs_usage, binds') = go env binds + (final_usage, bind') = occAnalBind env TopLevel imp_rule_edges bind + bs_usage + +occurAnalyseExpr :: CoreExpr -> CoreExpr + -- Do occurrence analysis, and discard occurrence info returned +occurAnalyseExpr = occurAnalyseExpr' True -- do binder swap + +occurAnalyseExpr_NoBinderSwap :: CoreExpr -> CoreExpr +occurAnalyseExpr_NoBinderSwap = occurAnalyseExpr' False -- do not do binder swap + +occurAnalyseExpr' :: Bool -> CoreExpr -> CoreExpr +occurAnalyseExpr' enable_binder_swap expr + = snd (occAnal env expr) + where + env = initOccEnv { occ_binder_swap = enable_binder_swap } + +{- Note [Plugin rules] +~~~~~~~~~~~~~~~~~~~~~~ +Conal Elliott (#11651) built a GHC plugin that added some +BuiltinRules (for imported Ids) to the mg_rules field of ModGuts, to +do some domain-specific transformations that could not be expressed +with an ordinary pattern-matching CoreRule. But then we can't extract +the dependencies (in imp_rule_edges) from ru_rhs etc, because a +BuiltinRule doesn't have any of that stuff. + +So we simply assume that BuiltinRules have no dependencies, and filter +them out from the imp_rule_edges comprehension. +-} + +{- +************************************************************************ +* * + Bindings +* * +************************************************************************ + +Note [Recursive bindings: the grand plan] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we come across a binding group + Rec { x1 = r1; ...; xn = rn } +we treat it like this (occAnalRecBind): + +1. Occurrence-analyse each right hand side, and build a + "Details" for each binding to capture the results. + + Wrap the details in a Node (details, node-id, dep-node-ids), + where node-id is just the unique of the binder, and + dep-node-ids lists all binders on which this binding depends. + We'll call these the "scope edges". + See Note [Forming the Rec groups]. + + All this is done by makeNode. + +2. Do SCC-analysis on these Nodes. Each SCC will become a new Rec or + NonRec. The key property is that every free variable of a binding + is accounted for by the scope edges, so that when we are done + everything is still in scope. + +3. For each Cyclic SCC of the scope-edge SCC-analysis in (2), we + identify suitable loop-breakers to ensure that inlining terminates. + This is done by occAnalRec. + +4. To do so we form a new set of Nodes, with the same details, but + different edges, the "loop-breaker nodes". The loop-breaker nodes + have both more and fewer dependencies than the scope edges + (see Note [Choosing loop breakers]) + + More edges: if f calls g, and g has an active rule that mentions h + then we add an edge from f -> h + + Fewer edges: we only include dependencies on active rules, on rule + RHSs (not LHSs) and if there is an INLINE pragma only + on the stable unfolding (and vice versa). The scope + edges must be much more inclusive. + +5. The "weak fvs" of a node are, by definition: + the scope fvs - the loop-breaker fvs + See Note [Weak loop breakers], and the nd_weak field of Details + +6. Having formed the loop-breaker nodes + +Note [Dead code] +~~~~~~~~~~~~~~~~ +Dropping dead code for a cyclic Strongly Connected Component is done +in a very simple way: + + the entire SCC is dropped if none of its binders are mentioned + in the body; otherwise the whole thing is kept. + +The key observation is that dead code elimination happens after +dependency analysis: so 'occAnalBind' processes SCCs instead of the +original term's binding groups. + +Thus 'occAnalBind' does indeed drop 'f' in an example like + + letrec f = ...g... + g = ...(...g...)... + in + ...g... + +when 'g' no longer uses 'f' at all (eg 'f' does not occur in a RULE in +'g'). 'occAnalBind' first consumes 'CyclicSCC g' and then it consumes +'AcyclicSCC f', where 'body_usage' won't contain 'f'. + +------------------------------------------------------------ +Note [Forming Rec groups] +~~~~~~~~~~~~~~~~~~~~~~~~~ +We put bindings {f = ef; g = eg } in a Rec group if "f uses g" +and "g uses f", no matter how indirectly. We do a SCC analysis +with an edge f -> g if "f uses g". + +More precisely, "f uses g" iff g should be in scope wherever f is. +That is, g is free in: + a) the rhs 'ef' + b) or the RHS of a rule for f (Note [Rules are extra RHSs]) + c) or the LHS or a rule for f (Note [Rule dependency info]) + +These conditions apply regardless of the activation of the RULE (eg it might be +inactive in this phase but become active later). Once a Rec is broken up +it can never be put back together, so we must be conservative. + +The principle is that, regardless of rule firings, every variable is +always in scope. + + * Note [Rules are extra RHSs] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~ + A RULE for 'f' is like an extra RHS for 'f'. That way the "parent" + keeps the specialised "children" alive. If the parent dies + (because it isn't referenced any more), then the children will die + too (unless they are already referenced directly). + + To that end, we build a Rec group for each cyclic strongly + connected component, + *treating f's rules as extra RHSs for 'f'*. + More concretely, the SCC analysis runs on a graph with an edge + from f -> g iff g is mentioned in + (a) f's rhs + (b) f's RULES + These are rec_edges. + + Under (b) we include variables free in *either* LHS *or* RHS of + the rule. The former might seems silly, but see Note [Rule + dependency info]. So in Example [eftInt], eftInt and eftIntFB + will be put in the same Rec, even though their 'main' RHSs are + both non-recursive. + + * Note [Rule dependency info] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~ + The VarSet in a RuleInfo is used for dependency analysis in the + occurrence analyser. We must track free vars in *both* lhs and rhs. + Hence use of idRuleVars, rather than idRuleRhsVars in occAnalBind. + Why both? Consider + x = y + RULE f x = v+4 + Then if we substitute y for x, we'd better do so in the + rule's LHS too, so we'd better ensure the RULE appears to mention 'x' + as well as 'v' + + * Note [Rules are visible in their own rec group] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + We want the rules for 'f' to be visible in f's right-hand side. + And we'd like them to be visible in other functions in f's Rec + group. E.g. in Note [Specialisation rules] we want f' rule + to be visible in both f's RHS, and fs's RHS. + + This means that we must simplify the RULEs first, before looking + at any of the definitions. This is done by Simplify.simplRecBind, + when it calls addLetIdInfo. + +------------------------------------------------------------ +Note [Choosing loop breakers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Loop breaking is surprisingly subtle. First read the section 4 of +"Secrets of the GHC inliner". This describes our basic plan. +We avoid infinite inlinings by choosing loop breakers, and +ensuring that a loop breaker cuts each loop. + +See also Note [Inlining and hs-boot files] in ToIface, which deals +with a closely related source of infinite loops. + +Fundamentally, we do SCC analysis on a graph. For each recursive +group we choose a loop breaker, delete all edges to that node, +re-analyse the SCC, and iterate. + +But what is the graph? NOT the same graph as was used for Note +[Forming Rec groups]! In particular, a RULE is like an equation for +'f' that is *always* inlined if it is applicable. We do *not* disable +rules for loop-breakers. It's up to whoever makes the rules to make +sure that the rules themselves always terminate. See Note [Rules for +recursive functions] in Simplify.hs + +Hence, if + f's RHS (or its INLINE template if it has one) mentions g, and + g has a RULE that mentions h, and + h has a RULE that mentions f + +then we *must* choose f to be a loop breaker. Example: see Note +[Specialisation rules]. + +In general, take the free variables of f's RHS, and augment it with +all the variables reachable by RULES from those starting points. That +is the whole reason for computing rule_fv_env in occAnalBind. (Of +course we only consider free vars that are also binders in this Rec +group.) See also Note [Finding rule RHS free vars] + +Note that when we compute this rule_fv_env, we only consider variables +free in the *RHS* of the rule, in contrast to the way we build the +Rec group in the first place (Note [Rule dependency info]) + +Note that if 'g' has RHS that mentions 'w', we should add w to +g's loop-breaker edges. More concretely there is an edge from f -> g +iff + (a) g is mentioned in f's RHS `xor` f's INLINE rhs + (see Note [Inline rules]) + (b) or h is mentioned in f's RHS, and + g appears in the RHS of an active RULE of h + or a transitive sequence of active rules starting with h + +Why "active rules"? See Note [Finding rule RHS free vars] + +Note that in Example [eftInt], *neither* eftInt *nor* eftIntFB is +chosen as a loop breaker, because their RHSs don't mention each other. +And indeed both can be inlined safely. + +Note again that the edges of the graph we use for computing loop breakers +are not the same as the edges we use for computing the Rec blocks. +That's why we compute + +- rec_edges for the Rec block analysis +- loop_breaker_nodes for the loop breaker analysis + + * Note [Finding rule RHS free vars] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Consider this real example from Data Parallel Haskell + tagZero :: Array Int -> Array Tag + {-# INLINE [1] tagZeroes #-} + tagZero xs = pmap (\x -> fromBool (x==0)) xs + + {-# RULES "tagZero" [~1] forall xs n. + pmap fromBool = tagZero xs #-} + So tagZero's RHS mentions pmap, and pmap's RULE mentions tagZero. + However, tagZero can only be inlined in phase 1 and later, while + the RULE is only active *before* phase 1. So there's no problem. + + To make this work, we look for the RHS free vars only for + *active* rules. That's the reason for the occ_rule_act field + of the OccEnv. + + * Note [Weak loop breakers] + ~~~~~~~~~~~~~~~~~~~~~~~~~ + There is a last nasty wrinkle. Suppose we have + + Rec { f = f_rhs + RULE f [] = g + + h = h_rhs + g = h + ...more... + } + + Remember that we simplify the RULES before any RHS (see Note + [Rules are visible in their own rec group] above). + + So we must *not* postInlineUnconditionally 'g', even though + its RHS turns out to be trivial. (I'm assuming that 'g' is + not choosen as a loop breaker.) Why not? Because then we + drop the binding for 'g', which leaves it out of scope in the + RULE! + + Here's a somewhat different example of the same thing + Rec { g = h + ; h = ...f... + ; f = f_rhs + RULE f [] = g } + Here the RULE is "below" g, but we *still* can't postInlineUnconditionally + g, because the RULE for f is active throughout. So the RHS of h + might rewrite to h = ...g... + So g must remain in scope in the output program! + + We "solve" this by: + + Make g a "weak" loop breaker (OccInfo = IAmLoopBreaker True) + iff g is a "missing free variable" of the Rec group + + A "missing free variable" x is one that is mentioned in an RHS or + INLINE or RULE of a binding in the Rec group, but where the + dependency on x may not show up in the loop_breaker_nodes (see + note [Choosing loop breakers} above). + + A normal "strong" loop breaker has IAmLoopBreaker False. So + + Inline postInlineUnconditionally + strong IAmLoopBreaker False no no + weak IAmLoopBreaker True yes no + other yes yes + + The **sole** reason for this kind of loop breaker is so that + postInlineUnconditionally does not fire. Ugh. (Typically it'll + inline via the usual callSiteInline stuff, so it'll be dead in the + next pass, so the main Ugh is the tiresome complication.) + +Note [Rules for imported functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + f = /\a. B.g a + RULE B.g Int = 1 + f Int +Note that + * The RULE is for an imported function. + * f is non-recursive +Now we +can get + f Int --> B.g Int Inlining f + --> 1 + f Int Firing RULE +and so the simplifier goes into an infinite loop. This +would not happen if the RULE was for a local function, +because we keep track of dependencies through rules. But +that is pretty much impossible to do for imported Ids. Suppose +f's definition had been + f = /\a. C.h a +where (by some long and devious process), C.h eventually inlines to +B.g. We could only spot such loops by exhaustively following +unfoldings of C.h etc, in case we reach B.g, and hence (via the RULE) +f. + +Note that RULES for imported functions are important in practice; they +occur a lot in the libraries. + +We regard this potential infinite loop as a *programmer* error. +It's up the programmer not to write silly rules like + RULE f x = f x +and the example above is just a more complicated version. + +Note [Preventing loops due to imported functions rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider: + import GHC.Base (foldr) + + {-# RULES "filterList" forall p. foldr (filterFB (:) p) [] = filter p #-} + filter p xs = build (\c n -> foldr (filterFB c p) n xs) + filterFB c p = ... + + f = filter p xs + +Note that filter is not a loop-breaker, so what happens is: + f = filter p xs + = {inline} build (\c n -> foldr (filterFB c p) n xs) + = {inline} foldr (filterFB (:) p) [] xs + = {RULE} filter p xs + +We are in an infinite loop. + +A more elaborate example (that I actually saw in practice when I went to +mark GHC.List.filter as INLINABLE) is as follows. Say I have this module: + {-# LANGUAGE RankNTypes #-} + module GHCList where + + import Prelude hiding (filter) + import GHC.Base (build) + + {-# INLINABLE filter #-} + filter :: (a -> Bool) -> [a] -> [a] + filter p [] = [] + filter p (x:xs) = if p x then x : filter p xs else filter p xs + + {-# NOINLINE [0] filterFB #-} + filterFB :: (a -> b -> b) -> (a -> Bool) -> a -> b -> b + filterFB c p x r | p x = x `c` r + | otherwise = r + + {-# RULES + "filter" [~1] forall p xs. filter p xs = build (\c n -> foldr + (filterFB c p) n xs) + "filterList" [1] forall p. foldr (filterFB (:) p) [] = filter p + #-} + +Then (because RULES are applied inside INLINABLE unfoldings, but inlinings +are not), the unfolding given to "filter" in the interface file will be: + filter p [] = [] + filter p (x:xs) = if p x then x : build (\c n -> foldr (filterFB c p) n xs) + else build (\c n -> foldr (filterFB c p) n xs + +Note that because this unfolding does not mention "filter", filter is not +marked as a strong loop breaker. Therefore at a use site in another module: + filter p xs + = {inline} + case xs of [] -> [] + (x:xs) -> if p x then x : build (\c n -> foldr (filterFB c p) n xs) + else build (\c n -> foldr (filterFB c p) n xs) + + build (\c n -> foldr (filterFB c p) n xs) + = {inline} foldr (filterFB (:) p) [] xs + = {RULE} filter p xs + +And we are in an infinite loop again, except that this time the loop is producing an +infinitely large *term* (an unrolling of filter) and so the simplifier finally +dies with "ticks exhausted" + +Because of this problem, we make a small change in the occurrence analyser +designed to mark functions like "filter" as strong loop breakers on the basis that: + 1. The RHS of filter mentions the local function "filterFB" + 2. We have a rule which mentions "filterFB" on the LHS and "filter" on the RHS + +So for each RULE for an *imported* function we are going to add +dependency edges between the *local* FVS of the rule LHS and the +*local* FVS of the rule RHS. We don't do anything special for RULES on +local functions because the standard occurrence analysis stuff is +pretty good at getting loop-breakerness correct there. + +It is important to note that even with this extra hack we aren't always going to get +things right. For example, it might be that the rule LHS mentions an imported Id, +and another module has a RULE that can rewrite that imported Id to one of our local +Ids. + +Note [Specialising imported functions] (referred to from Specialise) +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +BUT for *automatically-generated* rules, the programmer can't be +responsible for the "programmer error" in Note [Rules for imported +functions]. In paricular, consider specialising a recursive function +defined in another module. If we specialise a recursive function B.g, +we get + g_spec = .....(B.g Int)..... + RULE B.g Int = g_spec +Here, g_spec doesn't look recursive, but when the rule fires, it +becomes so. And if B.g was mutually recursive, the loop might +not be as obvious as it is here. + +To avoid this, + * When specialising a function that is a loop breaker, + give a NOINLINE pragma to the specialised function + +Note [Glomming] +~~~~~~~~~~~~~~~ +RULES for imported Ids can make something at the top refer to something at the bottom: + f = \x -> B.g (q x) + h = \y -> 3 + + RULE: B.g (q x) = h x + +Applying this rule makes f refer to h, although f doesn't appear to +depend on h. (And, as in Note [Rules for imported functions], the +dependency might be more indirect. For example, f might mention C.t +rather than B.g, where C.t eventually inlines to B.g.) + +NOTICE that this cannot happen for rules whose head is a +locally-defined function, because we accurately track dependencies +through RULES. It only happens for rules whose head is an imported +function (B.g in the example above). + +Solution: + - When simplifying, bring all top level identifiers into + scope at the start, ignoring the Rec/NonRec structure, so + that when 'h' pops up in f's rhs, we find it in the in-scope set + (as the simplifier generally expects). This happens in simplTopBinds. + + - In the occurrence analyser, if there are any out-of-scope + occurrences that pop out of the top, which will happen after + firing the rule: f = \x -> h x + h = \y -> 3 + then just glom all the bindings into a single Rec, so that + the *next* iteration of the occurrence analyser will sort + them all out. This part happens in occurAnalysePgm. + +------------------------------------------------------------ +Note [Inline rules] +~~~~~~~~~~~~~~~~~~~ +None of the above stuff about RULES applies to Inline Rules, +stored in a CoreUnfolding. The unfolding, if any, is simplified +at the same time as the regular RHS of the function (ie *not* like +Note [Rules are visible in their own rec group]), so it should be +treated *exactly* like an extra RHS. + +Or, rather, when computing loop-breaker edges, + * If f has an INLINE pragma, and it is active, we treat the + INLINE rhs as f's rhs + * If it's inactive, we treat f as having no rhs + * If it has no INLINE pragma, we look at f's actual rhs + + +There is a danger that we'll be sub-optimal if we see this + f = ...f... + [INLINE f = ..no f...] +where f is recursive, but the INLINE is not. This can just about +happen with a sufficiently odd set of rules; eg + + foo :: Int -> Int + {-# INLINE [1] foo #-} + foo x = x+1 + + bar :: Int -> Int + {-# INLINE [1] bar #-} + bar x = foo x + 1 + + {-# RULES "foo" [~1] forall x. foo x = bar x #-} + +Here the RULE makes bar recursive; but it's INLINE pragma remains +non-recursive. It's tempting to then say that 'bar' should not be +a loop breaker, but an attempt to do so goes wrong in two ways: + a) We may get + $df = ...$cfoo... + $cfoo = ...$df.... + [INLINE $cfoo = ...no-$df...] + But we want $cfoo to depend on $df explicitly so that we + put the bindings in the right order to inline $df in $cfoo + and perhaps break the loop altogether. (Maybe this + b) + + +Example [eftInt] +~~~~~~~~~~~~~~~ +Example (from GHC.Enum): + + eftInt :: Int# -> Int# -> [Int] + eftInt x y = ...(non-recursive)... + + {-# INLINE [0] eftIntFB #-} + eftIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> r + eftIntFB c n x y = ...(non-recursive)... + + {-# RULES + "eftInt" [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y) + "eftIntList" [1] eftIntFB (:) [] = eftInt + #-} + +Note [Specialisation rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this group, which is typical of what SpecConstr builds: + + fs a = ....f (C a).... + f x = ....f (C a).... + {-# RULE f (C a) = fs a #-} + +So 'f' and 'fs' are in the same Rec group (since f refers to fs via its RULE). + +But watch out! If 'fs' is not chosen as a loop breaker, we may get an infinite loop: + - the RULE is applied in f's RHS (see Note [Self-recursive rules] in Simplify + - fs is inlined (say it's small) + - now there's another opportunity to apply the RULE + +This showed up when compiling Control.Concurrent.Chan.getChanContents. + +------------------------------------------------------------ +Note [Finding join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's the occurrence analyser's job to find bindings that we can turn into join +points, but it doesn't perform that transformation right away. Rather, it marks +the eligible bindings as part of their occurrence data, leaving it to the +simplifier (or to simpleOptPgm) to actually change the binder's 'IdDetails'. +The simplifier then eta-expands the RHS if needed and then updates the +occurrence sites. Dividing the work this way means that the occurrence analyser +still only takes one pass, yet one can always tell the difference between a +function call and a jump by looking at the occurrence (because the same pass +changes the 'IdDetails' and propagates the binders to their occurrence sites). + +To track potential join points, we use the 'occ_tail' field of OccInfo. A value +of `AlwaysTailCalled n` indicates that every occurrence of the variable is a +tail call with `n` arguments (counting both value and type arguments). Otherwise +'occ_tail' will be 'NoTailCallInfo'. The tail call info flows bottom-up with the +rest of 'OccInfo' until it goes on the binder. + +Note [Rules and join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Things get fiddly with rules. Suppose we have: + + let j :: Int -> Int + j y = 2 * y + k :: Int -> Int -> Int + {-# RULES "SPEC k 0" k 0 = j #-} + k x y = x + 2 * y + in ... + +Now suppose that both j and k appear only as saturated tail calls in the body. +Thus we would like to make them both join points. The rule complicates matters, +though, as its RHS has an unapplied occurrence of j. *However*, if we were to +eta-expand the rule, all would be well: + + {-# RULES "SPEC k 0" forall a. k 0 a = j a #-} + +So conceivably we could notice that a potential join point would have an +"undersaturated" rule and account for it. This would mean we could make +something that's been specialised a join point, for instance. But local bindings +are rarely specialised, and being overly cautious about rules only +costs us anything when, for some `j`: + + * Before specialisation, `j` has non-tail calls, so it can't be a join point. + * During specialisation, `j` gets specialised and thus acquires rules. + * Sometime afterward, the non-tail calls to `j` disappear (as dead code, say), + and so now `j` *could* become a join point. + +This appears to be very rare in practice. TODO Perhaps we should gather +statistics to be sure. + +------------------------------------------------------------ +Note [Adjusting right-hand sides] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There's a bit of a dance we need to do after analysing a lambda expression or +a right-hand side. In particular, we need to + + a) call 'markAllInsideLam' *unless* the binding is for a thunk, a one-shot + lambda, or a non-recursive join point; and + b) call 'markAllNonTailCalled' *unless* the binding is for a join point. + +Some examples, with how the free occurrences in e (assumed not to be a value +lambda) get marked: + + inside lam non-tail-called + ------------------------------------------------------------ + let x = e No Yes + let f = \x -> e Yes Yes + let f = \x{OneShot} -> e No Yes + \x -> e Yes Yes + join j x = e No No + joinrec j x = e Yes No + +There are a few other caveats; most importantly, if we're marking a binding as +'AlwaysTailCalled', it's *going* to be a join point, so we treat it as one so +that the effect cascades properly. Consequently, at the time the RHS is +analysed, we won't know what adjustments to make; thus 'occAnalLamOrRhs' must +return the unadjusted 'UsageDetails', to be adjusted by 'adjustRhsUsage' once +join-point-hood has been decided. + +Thus the overall sequence taking place in 'occAnalNonRecBind' and +'occAnalRecBind' is as follows: + + 1. Call 'occAnalLamOrRhs' to find usage information for the RHS. + 2. Call 'tagNonRecBinder' or 'tagRecBinders', which decides whether to make + the binding a join point. + 3. Call 'adjustRhsUsage' accordingly. (Done as part of 'tagRecBinders' when + recursive.) + +(In the recursive case, this logic is spread between 'makeNode' and +'occAnalRec'.) +-} + +------------------------------------------------------------------ +-- occAnalBind +------------------------------------------------------------------ + +occAnalBind :: OccEnv -- The incoming OccEnv + -> TopLevelFlag + -> ImpRuleEdges + -> CoreBind + -> UsageDetails -- Usage details of scope + -> (UsageDetails, -- Of the whole let(rec) + [CoreBind]) + +occAnalBind env lvl top_env (NonRec binder rhs) body_usage + = occAnalNonRecBind env lvl top_env binder rhs body_usage +occAnalBind env lvl top_env (Rec pairs) body_usage + = occAnalRecBind env lvl top_env pairs body_usage + +----------------- +occAnalNonRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> Var -> CoreExpr + -> UsageDetails -> (UsageDetails, [CoreBind]) +occAnalNonRecBind env lvl imp_rule_edges binder rhs body_usage + | isTyVar binder -- A type let; we don't gather usage info + = (body_usage, [NonRec binder rhs]) + + | not (binder `usedIn` body_usage) -- It's not mentioned + = (body_usage, []) + + | otherwise -- It's mentioned in the body + = (body_usage' `andUDs` rhs_usage', [NonRec tagged_binder rhs']) + where + (body_usage', tagged_binder) = tagNonRecBinder lvl body_usage binder + mb_join_arity = willBeJoinId_maybe tagged_binder + + (bndrs, body) = collectBinders rhs + + (rhs_usage1, bndrs', body') = occAnalNonRecRhs env tagged_binder bndrs body + rhs' = mkLams (markJoinOneShots mb_join_arity bndrs') body' + -- For a /non-recursive/ join point we can mark all + -- its join-lambda as one-shot; and it's a good idea to do so + + -- Unfoldings + -- See Note [Unfoldings and join points] + rhs_usage2 = case occAnalUnfolding env NonRecursive binder of + Just unf_usage -> rhs_usage1 `andUDs` unf_usage + Nothing -> rhs_usage1 + + -- Rules + -- See Note [Rules are extra RHSs] and Note [Rule dependency info] + rules_w_uds = occAnalRules env mb_join_arity NonRecursive tagged_binder + rule_uds = map (\(_, l, r) -> l `andUDs` r) rules_w_uds + rhs_usage3 = foldr andUDs rhs_usage2 rule_uds + rhs_usage4 = case lookupVarEnv imp_rule_edges binder of + Nothing -> rhs_usage3 + Just vs -> addManyOccsSet rhs_usage3 vs + -- See Note [Preventing loops due to imported functions rules] + + -- Final adjustment + rhs_usage' = adjustRhsUsage mb_join_arity NonRecursive bndrs' rhs_usage4 + +----------------- +occAnalRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> [(Var,CoreExpr)] + -> UsageDetails -> (UsageDetails, [CoreBind]) +occAnalRecBind env lvl imp_rule_edges pairs body_usage + = foldr (occAnalRec env lvl) (body_usage, []) sccs + -- For a recursive group, we + -- * occ-analyse all the RHSs + -- * compute strongly-connected components + -- * feed those components to occAnalRec + -- See Note [Recursive bindings: the grand plan] + where + sccs :: [SCC Details] + sccs = {-# SCC "occAnalBind.scc" #-} + stronglyConnCompFromEdgedVerticesUniq nodes + + nodes :: [LetrecNode] + nodes = {-# SCC "occAnalBind.assoc" #-} + map (makeNode env imp_rule_edges bndr_set) pairs + + bndr_set = mkVarSet (map fst pairs) + +{- +Note [Unfoldings and join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We assume that anything in an unfolding occurs multiple times, since unfoldings +are often copied (that's the whole point!). But we still need to track tail +calls for the purpose of finding join points. +-} + +----------------------------- +occAnalRec :: OccEnv -> TopLevelFlag + -> SCC Details + -> (UsageDetails, [CoreBind]) + -> (UsageDetails, [CoreBind]) + + -- The NonRec case is just like a Let (NonRec ...) above +occAnalRec _ lvl (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs + , nd_uds = rhs_uds, nd_rhs_bndrs = rhs_bndrs })) + (body_uds, binds) + | not (bndr `usedIn` body_uds) + = (body_uds, binds) -- See Note [Dead code] + + | otherwise -- It's mentioned in the body + = (body_uds' `andUDs` rhs_uds', + NonRec tagged_bndr rhs : binds) + where + (body_uds', tagged_bndr) = tagNonRecBinder lvl body_uds bndr + rhs_uds' = adjustRhsUsage (willBeJoinId_maybe tagged_bndr) NonRecursive + rhs_bndrs rhs_uds + + -- The Rec case is the interesting one + -- See Note [Recursive bindings: the grand plan] + -- See Note [Loop breaking] +occAnalRec env lvl (CyclicSCC details_s) (body_uds, binds) + | not (any (`usedIn` body_uds) bndrs) -- NB: look at body_uds, not total_uds + = (body_uds, binds) -- See Note [Dead code] + + | otherwise -- At this point we always build a single Rec + = -- pprTrace "occAnalRec" (vcat + -- [ text "weak_fvs" <+> ppr weak_fvs + -- , text "lb nodes" <+> ppr loop_breaker_nodes]) + (final_uds, Rec pairs : binds) + + where + bndrs = map nd_bndr details_s + bndr_set = mkVarSet bndrs + + ------------------------------ + -- See Note [Choosing loop breakers] for loop_breaker_nodes + final_uds :: UsageDetails + loop_breaker_nodes :: [LetrecNode] + (final_uds, loop_breaker_nodes) + = mkLoopBreakerNodes env lvl bndr_set body_uds details_s + + ------------------------------ + weak_fvs :: VarSet + weak_fvs = mapUnionVarSet nd_weak details_s + + --------------------------- + -- Now reconstruct the cycle + pairs :: [(Id,CoreExpr)] + pairs | isEmptyVarSet weak_fvs = reOrderNodes 0 bndr_set weak_fvs loop_breaker_nodes [] + | otherwise = loopBreakNodes 0 bndr_set weak_fvs loop_breaker_nodes [] + -- If weak_fvs is empty, the loop_breaker_nodes will include + -- all the edges in the original scope edges [remember, + -- weak_fvs is the difference between scope edges and + -- lb-edges], so a fresh SCC computation would yield a + -- single CyclicSCC result; and reOrderNodes deals with + -- exactly that case + + +------------------------------------------------------------------ +-- Loop breaking +------------------------------------------------------------------ + +type Binding = (Id,CoreExpr) + +loopBreakNodes :: Int + -> VarSet -- All binders + -> VarSet -- Binders whose dependencies may be "missing" + -- See Note [Weak loop breakers] + -> [LetrecNode] + -> [Binding] -- Append these to the end + -> [Binding] +{- +loopBreakNodes is applied to the list of nodes for a cyclic strongly +connected component (there's guaranteed to be a cycle). It returns +the same nodes, but + a) in a better order, + b) with some of the Ids having a IAmALoopBreaker pragma + +The "loop-breaker" Ids are sufficient to break all cycles in the SCC. This means +that the simplifier can guarantee not to loop provided it never records an inlining +for these no-inline guys. + +Furthermore, the order of the binds is such that if we neglect dependencies +on the no-inline Ids then the binds are topologically sorted. This means +that the simplifier will generally do a good job if it works from top bottom, +recording inlinings for any Ids which aren't marked as "no-inline" as it goes. +-} + +-- Return the bindings sorted into a plausible order, and marked with loop breakers. +loopBreakNodes depth bndr_set weak_fvs nodes binds + = -- pprTrace "loopBreakNodes" (ppr nodes) $ + go (stronglyConnCompFromEdgedVerticesUniqR nodes) binds + where + go [] binds = binds + go (scc:sccs) binds = loop_break_scc scc (go sccs binds) + + loop_break_scc scc binds + = case scc of + AcyclicSCC node -> mk_non_loop_breaker weak_fvs node : binds + CyclicSCC nodes -> reOrderNodes depth bndr_set weak_fvs nodes binds + +---------------------------------- +reOrderNodes :: Int -> VarSet -> VarSet -> [LetrecNode] -> [Binding] -> [Binding] + -- Choose a loop breaker, mark it no-inline, + -- and call loopBreakNodes on the rest +reOrderNodes _ _ _ [] _ = panic "reOrderNodes" +reOrderNodes _ _ _ [node] binds = mk_loop_breaker node : binds +reOrderNodes depth bndr_set weak_fvs (node : nodes) binds + = -- pprTrace "reOrderNodes" (vcat [ text "unchosen" <+> ppr unchosen + -- , text "chosen" <+> ppr chosen_nodes ]) $ + loopBreakNodes new_depth bndr_set weak_fvs unchosen $ + (map mk_loop_breaker chosen_nodes ++ binds) + where + (chosen_nodes, unchosen) = chooseLoopBreaker approximate_lb + (nd_score (node_payload node)) + [node] [] nodes + + approximate_lb = depth >= 2 + new_depth | approximate_lb = 0 + | otherwise = depth+1 + -- After two iterations (d=0, d=1) give up + -- and approximate, returning to d=0 + +mk_loop_breaker :: LetrecNode -> Binding +mk_loop_breaker (node_payload -> ND { nd_bndr = bndr, nd_rhs = rhs}) + = (bndr `setIdOccInfo` strongLoopBreaker { occ_tail = tail_info }, rhs) + where + tail_info = tailCallInfo (idOccInfo bndr) + +mk_non_loop_breaker :: VarSet -> LetrecNode -> Binding +-- See Note [Weak loop breakers] +mk_non_loop_breaker weak_fvs (node_payload -> ND { nd_bndr = bndr + , nd_rhs = rhs}) + | bndr `elemVarSet` weak_fvs = (setIdOccInfo bndr occ', rhs) + | otherwise = (bndr, rhs) + where + occ' = weakLoopBreaker { occ_tail = tail_info } + tail_info = tailCallInfo (idOccInfo bndr) + +---------------------------------- +chooseLoopBreaker :: Bool -- True <=> Too many iterations, + -- so approximate + -> NodeScore -- Best score so far + -> [LetrecNode] -- Nodes with this score + -> [LetrecNode] -- Nodes with higher scores + -> [LetrecNode] -- Unprocessed nodes + -> ([LetrecNode], [LetrecNode]) + -- This loop looks for the bind with the lowest score + -- to pick as the loop breaker. The rest accumulate in +chooseLoopBreaker _ _ loop_nodes acc [] + = (loop_nodes, acc) -- Done + + -- If approximate_loop_breaker is True, we pick *all* + -- nodes with lowest score, else just one + -- See Note [Complexity of loop breaking] +chooseLoopBreaker approx_lb loop_sc loop_nodes acc (node : nodes) + | approx_lb + , rank sc == rank loop_sc + = chooseLoopBreaker approx_lb loop_sc (node : loop_nodes) acc nodes + + | sc `betterLB` loop_sc -- Better score so pick this new one + = chooseLoopBreaker approx_lb sc [node] (loop_nodes ++ acc) nodes + + | otherwise -- Worse score so don't pick it + = chooseLoopBreaker approx_lb loop_sc loop_nodes (node : acc) nodes + where + sc = nd_score (node_payload node) + +{- +Note [Complexity of loop breaking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The loop-breaking algorithm knocks out one binder at a time, and +performs a new SCC analysis on the remaining binders. That can +behave very badly in tightly-coupled groups of bindings; in the +worst case it can be (N**2)*log N, because it does a full SCC +on N, then N-1, then N-2 and so on. + +To avoid this, we switch plans after 2 (or whatever) attempts: + Plan A: pick one binder with the lowest score, make it + a loop breaker, and try again + Plan B: pick *all* binders with the lowest score, make them + all loop breakers, and try again +Since there are only a small finite number of scores, this will +terminate in a constant number of iterations, rather than O(N) +iterations. + +You might thing that it's very unlikely, but RULES make it much +more likely. Here's a real example from #1969: + Rec { $dm = \d.\x. op d + {-# RULES forall d. $dm Int d = $s$dm1 + forall d. $dm Bool d = $s$dm2 #-} + + dInt = MkD .... opInt ... + dInt = MkD .... opBool ... + opInt = $dm dInt + opBool = $dm dBool + + $s$dm1 = \x. op dInt + $s$dm2 = \x. op dBool } +The RULES stuff means that we can't choose $dm as a loop breaker +(Note [Choosing loop breakers]), so we must choose at least (say) +opInt *and* opBool, and so on. The number of loop breakders is +linear in the number of instance declarations. + +Note [Loop breakers and INLINE/INLINABLE pragmas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Avoid choosing a function with an INLINE pramga as the loop breaker! +If such a function is mutually-recursive with a non-INLINE thing, +then the latter should be the loop-breaker. + +It's vital to distinguish between INLINE and INLINABLE (the +Bool returned by hasStableCoreUnfolding_maybe). If we start with + Rec { {-# INLINABLE f #-} + f x = ...f... } +and then worker/wrapper it through strictness analysis, we'll get + Rec { {-# INLINABLE $wf #-} + $wf p q = let x = (p,q) in ...f... + + {-# INLINE f #-} + f x = case x of (p,q) -> $wf p q } + +Now it is vital that we choose $wf as the loop breaker, so we can +inline 'f' in '$wf'. + +Note [DFuns should not be loop breakers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's particularly bad to make a DFun into a loop breaker. See +Note [How instance declarations are translated] in TcInstDcls + +We give DFuns a higher score than ordinary CONLIKE things because +if there's a choice we want the DFun to be the non-loop breaker. Eg + +rec { sc = /\ a \$dC. $fBWrap (T a) ($fCT @ a $dC) + + $fCT :: forall a_afE. (Roman.C a_afE) => Roman.C (Roman.T a_afE) + {-# DFUN #-} + $fCT = /\a \$dC. MkD (T a) ((sc @ a $dC) |> blah) ($ctoF @ a $dC) + } + +Here 'sc' (the superclass) looks CONLIKE, but we'll never get to it +if we can't unravel the DFun first. + +Note [Constructor applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's really really important to inline dictionaries. Real +example (the Enum Ordering instance from GHC.Base): + + rec f = \ x -> case d of (p,q,r) -> p x + g = \ x -> case d of (p,q,r) -> q x + d = (v, f, g) + +Here, f and g occur just once; but we can't inline them into d. +On the other hand we *could* simplify those case expressions if +we didn't stupidly choose d as the loop breaker. +But we won't because constructor args are marked "Many". +Inlining dictionaries is really essential to unravelling +the loops in static numeric dictionaries, see GHC.Float. + +Note [Closure conversion] +~~~~~~~~~~~~~~~~~~~~~~~~~ +We treat (\x. C p q) as a high-score candidate in the letrec scoring algorithm. +The immediate motivation came from the result of a closure-conversion transformation +which generated code like this: + + data Clo a b = forall c. Clo (c -> a -> b) c + + ($:) :: Clo a b -> a -> b + Clo f env $: x = f env x + + rec { plus = Clo plus1 () + + ; plus1 _ n = Clo plus2 n + + ; plus2 Zero n = n + ; plus2 (Succ m) n = Succ (plus $: m $: n) } + +If we inline 'plus' and 'plus1', everything unravels nicely. But if +we choose 'plus1' as the loop breaker (which is entirely possible +otherwise), the loop does not unravel nicely. + + +@occAnalUnfolding@ deals with the question of bindings where the Id is marked +by an INLINE pragma. For these we record that anything which occurs +in its RHS occurs many times. This pessimistically assumes that this +inlined binder also occurs many times in its scope, but if it doesn't +we'll catch it next time round. At worst this costs an extra simplifier pass. +ToDo: try using the occurrence info for the inline'd binder. + +[March 97] We do the same for atomic RHSs. Reason: see notes with loopBreakSCC. +[June 98, SLPJ] I've undone this change; I don't understand it. See notes with loopBreakSCC. + + +************************************************************************ +* * + Making nodes +* * +************************************************************************ +-} + +type ImpRuleEdges = IdEnv IdSet -- Mapping from FVs of imported RULE LHSs to RHS FVs + +noImpRuleEdges :: ImpRuleEdges +noImpRuleEdges = emptyVarEnv + +type LetrecNode = Node Unique Details -- Node comes from Digraph + -- The Unique key is gotten from the Id +data Details + = ND { nd_bndr :: Id -- Binder + , nd_rhs :: CoreExpr -- RHS, already occ-analysed + , nd_rhs_bndrs :: [CoreBndr] -- Outer lambdas of RHS + -- INVARIANT: (nd_rhs_bndrs nd, _) == + -- collectBinders (nd_rhs nd) + + , nd_uds :: UsageDetails -- Usage from RHS, and RULES, and stable unfoldings + -- ignoring phase (ie assuming all are active) + -- See Note [Forming Rec groups] + + , nd_inl :: IdSet -- Free variables of + -- the stable unfolding (if present and active) + -- or the RHS (if not) + -- but excluding any RULES + -- This is the IdSet that may be used if the Id is inlined + + , nd_weak :: IdSet -- Binders of this Rec that are mentioned in nd_uds + -- but are *not* in nd_inl. These are the ones whose + -- dependencies might not be respected by loop_breaker_nodes + -- See Note [Weak loop breakers] + + , nd_active_rule_fvs :: IdSet -- Free variables of the RHS of active RULES + + , nd_score :: NodeScore + } + +instance Outputable Details where + ppr nd = text "ND" <> braces + (sep [ text "bndr =" <+> ppr (nd_bndr nd) + , text "uds =" <+> ppr (nd_uds nd) + , text "inl =" <+> ppr (nd_inl nd) + , text "weak =" <+> ppr (nd_weak nd) + , text "rule =" <+> ppr (nd_active_rule_fvs nd) + , text "score =" <+> ppr (nd_score nd) + ]) + +-- The NodeScore is compared lexicographically; +-- e.g. lower rank wins regardless of size +type NodeScore = ( Int -- Rank: lower => more likely to be picked as loop breaker + , Int -- Size of rhs: higher => more likely to be picked as LB + -- Maxes out at maxExprSize; we just use it to prioritise + -- small functions + , Bool ) -- Was it a loop breaker before? + -- True => more likely to be picked + -- Note [Loop breakers, node scoring, and stability] + +rank :: NodeScore -> Int +rank (r, _, _) = r + +makeNode :: OccEnv -> ImpRuleEdges -> VarSet + -> (Var, CoreExpr) -> LetrecNode +-- See Note [Recursive bindings: the grand plan] +makeNode env imp_rule_edges bndr_set (bndr, rhs) + = DigraphNode details (varUnique bndr) (nonDetKeysUniqSet node_fvs) + -- It's OK to use nonDetKeysUniqSet here as stronglyConnCompFromEdgedVerticesR + -- is still deterministic with edges in nondeterministic order as + -- explained in Note [Deterministic SCC] in Digraph. + where + details = ND { nd_bndr = bndr + , nd_rhs = rhs' + , nd_rhs_bndrs = bndrs' + , nd_uds = rhs_usage3 + , nd_inl = inl_fvs + , nd_weak = node_fvs `minusVarSet` inl_fvs + , nd_active_rule_fvs = active_rule_fvs + , nd_score = pprPanic "makeNodeDetails" (ppr bndr) } + + -- Constructing the edges for the main Rec computation + -- See Note [Forming Rec groups] + (bndrs, body) = collectBinders rhs + (rhs_usage1, bndrs', body') = occAnalRecRhs env bndrs body + rhs' = mkLams bndrs' body' + rhs_usage2 = foldr andUDs rhs_usage1 rule_uds + -- Note [Rules are extra RHSs] + -- Note [Rule dependency info] + rhs_usage3 = case mb_unf_uds of + Just unf_uds -> rhs_usage2 `andUDs` unf_uds + Nothing -> rhs_usage2 + node_fvs = udFreeVars bndr_set rhs_usage3 + + -- Finding the free variables of the rules + is_active = occ_rule_act env :: Activation -> Bool + + rules_w_uds :: [(CoreRule, UsageDetails, UsageDetails)] + rules_w_uds = occAnalRules env (Just (length bndrs)) Recursive bndr + + rules_w_rhs_fvs :: [(Activation, VarSet)] -- Find the RHS fvs + rules_w_rhs_fvs = maybe id (\ids -> ((AlwaysActive, ids):)) + (lookupVarEnv imp_rule_edges bndr) + -- See Note [Preventing loops due to imported functions rules] + [ (ru_act rule, udFreeVars bndr_set rhs_uds) + | (rule, _, rhs_uds) <- rules_w_uds ] + rule_uds = map (\(_, l, r) -> l `andUDs` r) rules_w_uds + active_rule_fvs = unionVarSets [fvs | (a,fvs) <- rules_w_rhs_fvs + , is_active a] + + -- Finding the usage details of the INLINE pragma (if any) + mb_unf_uds = occAnalUnfolding env Recursive bndr + + -- Find the "nd_inl" free vars; for the loop-breaker phase + inl_fvs = case mb_unf_uds of + Nothing -> udFreeVars bndr_set rhs_usage1 -- No INLINE, use RHS + Just unf_uds -> udFreeVars bndr_set unf_uds + -- We could check for an *active* INLINE (returning + -- emptyVarSet for an inactive one), but is_active + -- isn't the right thing (it tells about + -- RULE activation), so we'd need more plumbing + +mkLoopBreakerNodes :: OccEnv -> TopLevelFlag + -> VarSet + -> UsageDetails -- for BODY of let + -> [Details] + -> (UsageDetails, -- adjusted + [LetrecNode]) +-- Does four things +-- a) tag each binder with its occurrence info +-- b) add a NodeScore to each node +-- c) make a Node with the right dependency edges for +-- the loop-breaker SCC analysis +-- d) adjust each RHS's usage details according to +-- the binder's (new) shotness and join-point-hood +mkLoopBreakerNodes env lvl bndr_set body_uds details_s + = (final_uds, zipWith mk_lb_node details_s bndrs') + where + (final_uds, bndrs') = tagRecBinders lvl body_uds + [ ((nd_bndr nd) + ,(nd_uds nd) + ,(nd_rhs_bndrs nd)) + | nd <- details_s ] + mk_lb_node nd@(ND { nd_bndr = bndr, nd_rhs = rhs, nd_inl = inl_fvs }) bndr' + = DigraphNode nd' (varUnique bndr) (nonDetKeysUniqSet lb_deps) + -- It's OK to use nonDetKeysUniqSet here as + -- stronglyConnCompFromEdgedVerticesR is still deterministic with edges + -- in nondeterministic order as explained in + -- Note [Deterministic SCC] in Digraph. + where + nd' = nd { nd_bndr = bndr', nd_score = score } + score = nodeScore env bndr bndr' rhs lb_deps + lb_deps = extendFvs_ rule_fv_env inl_fvs + + rule_fv_env :: IdEnv IdSet + -- Maps a variable f to the variables from this group + -- mentioned in RHS of active rules for f + -- Domain is *subset* of bound vars (others have no rule fvs) + rule_fv_env = transClosureFV (mkVarEnv init_rule_fvs) + init_rule_fvs -- See Note [Finding rule RHS free vars] + = [ (b, trimmed_rule_fvs) + | ND { nd_bndr = b, nd_active_rule_fvs = rule_fvs } <- details_s + , let trimmed_rule_fvs = rule_fvs `intersectVarSet` bndr_set + , not (isEmptyVarSet trimmed_rule_fvs) ] + + +------------------------------------------ +nodeScore :: OccEnv + -> Id -- Binder has old occ-info (just for loop-breaker-ness) + -> Id -- Binder with new occ-info + -> CoreExpr -- RHS + -> VarSet -- Loop-breaker dependencies + -> NodeScore +nodeScore env old_bndr new_bndr bind_rhs lb_deps + | not (isId old_bndr) -- A type or cercion variable is never a loop breaker + = (100, 0, False) + + | old_bndr `elemVarSet` lb_deps -- Self-recursive things are great loop breakers + = (0, 0, True) -- See Note [Self-recursion and loop breakers] + + | not (occ_unf_act env old_bndr) -- A binder whose inlining is inactive (e.g. has + = (0, 0, True) -- a NOINLINE pragma) makes a great loop breaker + + | exprIsTrivial rhs + = mk_score 10 -- Practically certain to be inlined + -- Used to have also: && not (isExportedId bndr) + -- But I found this sometimes cost an extra iteration when we have + -- rec { d = (a,b); a = ...df...; b = ...df...; df = d } + -- where df is the exported dictionary. Then df makes a really + -- bad choice for loop breaker + + | DFunUnfolding { df_args = args } <- id_unfolding + -- Never choose a DFun as a loop breaker + -- Note [DFuns should not be loop breakers] + = (9, length args, is_lb) + + -- Data structures are more important than INLINE pragmas + -- so that dictionary/method recursion unravels + + | CoreUnfolding { uf_guidance = UnfWhen {} } <- id_unfolding + = mk_score 6 + + | is_con_app rhs -- Data types help with cases: + = mk_score 5 -- Note [Constructor applications] + + | isStableUnfolding id_unfolding + , can_unfold + = mk_score 3 + + | isOneOcc (idOccInfo new_bndr) + = mk_score 2 -- Likely to be inlined + + | can_unfold -- The Id has some kind of unfolding + = mk_score 1 + + | otherwise + = (0, 0, is_lb) + + where + mk_score :: Int -> NodeScore + mk_score rank = (rank, rhs_size, is_lb) + + is_lb = isStrongLoopBreaker (idOccInfo old_bndr) + rhs = case id_unfolding of + CoreUnfolding { uf_src = src, uf_tmpl = unf_rhs } + | isStableSource src + -> unf_rhs + _ -> bind_rhs + -- 'bind_rhs' is irrelevant for inlining things with a stable unfolding + rhs_size = case id_unfolding of + CoreUnfolding { uf_guidance = guidance } + | UnfIfGoodArgs { ug_size = size } <- guidance + -> size + _ -> cheapExprSize rhs + + can_unfold = canUnfold id_unfolding + id_unfolding = realIdUnfolding old_bndr + -- realIdUnfolding: Ignore loop-breaker-ness here because + -- that is what we are setting! + + -- Checking for a constructor application + -- Cheap and cheerful; the simplifier moves casts out of the way + -- The lambda case is important to spot x = /\a. C (f a) + -- which comes up when C is a dictionary constructor and + -- f is a default method. + -- Example: the instance for Show (ST s a) in GHC.ST + -- + -- However we *also* treat (\x. C p q) as a con-app-like thing, + -- Note [Closure conversion] + is_con_app (Var v) = isConLikeId v + is_con_app (App f _) = is_con_app f + is_con_app (Lam _ e) = is_con_app e + is_con_app (Tick _ e) = is_con_app e + is_con_app _ = False + +maxExprSize :: Int +maxExprSize = 20 -- Rather arbitrary + +cheapExprSize :: CoreExpr -> Int +-- Maxes out at maxExprSize +cheapExprSize e + = go 0 e + where + go n e | n >= maxExprSize = n + | otherwise = go1 n e + + go1 n (Var {}) = n+1 + go1 n (Lit {}) = n+1 + go1 n (Type {}) = n + go1 n (Coercion {}) = n + go1 n (Tick _ e) = go1 n e + go1 n (Cast e _) = go1 n e + go1 n (App f a) = go (go1 n f) a + go1 n (Lam b e) + | isTyVar b = go1 n e + | otherwise = go (n+1) e + go1 n (Let b e) = gos (go1 n e) (rhssOfBind b) + go1 n (Case e _ _ as) = gos (go1 n e) (rhssOfAlts as) + + gos n [] = n + gos n (e:es) | n >= maxExprSize = n + | otherwise = gos (go1 n e) es + +betterLB :: NodeScore -> NodeScore -> Bool +-- If n1 `betterLB` n2 then choose n1 as the loop breaker +betterLB (rank1, size1, lb1) (rank2, size2, _) + | rank1 < rank2 = True + | rank1 > rank2 = False + | size1 < size2 = False -- Make the bigger n2 into the loop breaker + | size1 > size2 = True + | lb1 = True -- Tie-break: if n1 was a loop breaker before, choose it + | otherwise = False -- See Note [Loop breakers, node scoring, and stability] + +{- Note [Self-recursion and loop breakers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have + rec { f = ...f...g... + ; g = .....f... } +then 'f' has to be a loop breaker anyway, so we may as well choose it +right away, so that g can inline freely. + +This is really just a cheap hack. Consider + rec { f = ...g... + ; g = ..f..h... + ; h = ...f....} +Here f or g are better loop breakers than h; but we might accidentally +choose h. Finding the minimal set of loop breakers is hard. + +Note [Loop breakers, node scoring, and stability] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +To choose a loop breaker, we give a NodeScore to each node in the SCC, +and pick the one with the best score (according to 'betterLB'). + +We need to be jolly careful (#12425, #12234) about the stability +of this choice. Suppose we have + + let rec { f = ...g...g... + ; g = ...f...f... } + in + case x of + True -> ...f.. + False -> ..f... + +In each iteration of the simplifier the occurrence analyser OccAnal +chooses a loop breaker. Suppose in iteration 1 it choose g as the loop +breaker. That means it is free to inline f. + +Suppose that GHC decides to inline f in the branches of the case, but +(for some reason; eg it is not saturated) in the rhs of g. So we get + + let rec { f = ...g...g... + ; g = ...f...f... } + in + case x of + True -> ...g...g..... + False -> ..g..g.... + +Now suppose that, for some reason, in the next iteration the occurrence +analyser chooses f as the loop breaker, so it can freely inline g. And +again for some reason the simplifier inlines g at its calls in the case +branches, but not in the RHS of f. Then we get + + let rec { f = ...g...g... + ; g = ...f...f... } + in + case x of + True -> ...(...f...f...)...(...f..f..)..... + False -> ..(...f...f...)...(..f..f...).... + +You can see where this is going! Each iteration of the simplifier +doubles the number of calls to f or g. No wonder GHC is slow! + +(In the particular example in comment:3 of #12425, f and g are the two +mutually recursive fmap instances for CondT and Result. They are both +marked INLINE which, oddly, is why they don't inline in each other's +RHS, because the call there is not saturated.) + +The root cause is that we flip-flop on our choice of loop breaker. I +always thought it didn't matter, and indeed for any single iteration +to terminate, it doesn't matter. But when we iterate, it matters a +lot!! + +So The Plan is this: + If there is a tie, choose the node that + was a loop breaker last time round + +Hence the is_lb field of NodeScore + +************************************************************************ +* * + Right hand sides +* * +************************************************************************ +-} + +occAnalRhs :: OccEnv -> RecFlag -> Id -> [CoreBndr] -> CoreExpr + -> (UsageDetails, [CoreBndr], CoreExpr) + -- Returned usage details covers only the RHS, + -- and *not* the RULE or INLINE template for the Id +occAnalRhs env Recursive _ bndrs body + = occAnalRecRhs env bndrs body +occAnalRhs env NonRecursive id bndrs body + = occAnalNonRecRhs env id bndrs body + +occAnalRecRhs :: OccEnv -> [CoreBndr] -> CoreExpr -- Rhs lambdas, body + -> (UsageDetails, [CoreBndr], CoreExpr) + -- Returned usage details covers only the RHS, + -- and *not* the RULE or INLINE template for the Id +occAnalRecRhs env bndrs body = occAnalLamOrRhs (rhsCtxt env) bndrs body + +occAnalNonRecRhs :: OccEnv + -> Id -> [CoreBndr] -> CoreExpr -- Binder; rhs lams, body + -- Binder is already tagged with occurrence info + -> (UsageDetails, [CoreBndr], CoreExpr) + -- Returned usage details covers only the RHS, + -- and *not* the RULE or INLINE template for the Id +occAnalNonRecRhs env bndr bndrs body + = occAnalLamOrRhs rhs_env bndrs body + where + env1 | is_join_point = env -- See Note [Join point RHSs] + | certainly_inline = env -- See Note [Cascading inlines] + | otherwise = rhsCtxt env + + -- See Note [Sources of one-shot information] + rhs_env = env1 { occ_one_shots = argOneShots dmd } + + certainly_inline -- See Note [Cascading inlines] + = case occ of + OneOcc { occ_in_lam = in_lam, occ_one_br = one_br } + -> not in_lam && one_br && active && not_stable + _ -> False + + is_join_point = isAlwaysTailCalled occ + -- Like (isJoinId bndr) but happens one step earlier + -- c.f. willBeJoinId_maybe + + occ = idOccInfo bndr + dmd = idDemandInfo bndr + active = isAlwaysActive (idInlineActivation bndr) + not_stable = not (isStableUnfolding (idUnfolding bndr)) + +occAnalUnfolding :: OccEnv + -> RecFlag + -> Id + -> Maybe UsageDetails + -- Just the analysis, not a new unfolding. The unfolding + -- got analysed when it was created and we don't need to + -- update it. +occAnalUnfolding env rec_flag id + = case realIdUnfolding id of -- ignore previous loop-breaker flag + CoreUnfolding { uf_tmpl = rhs, uf_src = src } + | not (isStableSource src) + -> Nothing + | otherwise + -> Just $ markAllMany usage + where + (bndrs, body) = collectBinders rhs + (usage, _, _) = occAnalRhs env rec_flag id bndrs body + + DFunUnfolding { df_bndrs = bndrs, df_args = args } + -> Just $ zapDetails (delDetailsList usage bndrs) + where + usage = andUDsList (map (fst . occAnal env) args) + + _ -> Nothing + +occAnalRules :: OccEnv + -> Maybe JoinArity -- If the binder is (or MAY become) a join + -- point, what its join arity is (or WOULD + -- become). See Note [Rules and join points]. + -> RecFlag + -> Id + -> [(CoreRule, -- Each (non-built-in) rule + UsageDetails, -- Usage details for LHS + UsageDetails)] -- Usage details for RHS +occAnalRules env mb_expected_join_arity rec_flag id + = [ (rule, lhs_uds, rhs_uds) | rule@Rule {} <- idCoreRules id + , let (lhs_uds, rhs_uds) = occ_anal_rule rule ] + where + occ_anal_rule (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs }) + = (lhs_uds, final_rhs_uds) + where + lhs_uds = addManyOccsSet emptyDetails $ + (exprsFreeVars args `delVarSetList` bndrs) + (rhs_bndrs, rhs_body) = collectBinders rhs + (rhs_uds, _, _) = occAnalRhs env rec_flag id rhs_bndrs rhs_body + -- Note [Rules are extra RHSs] + -- Note [Rule dependency info] + final_rhs_uds = adjust_tail_info args $ markAllMany $ + (rhs_uds `delDetailsList` bndrs) + occ_anal_rule _ + = (emptyDetails, emptyDetails) + + adjust_tail_info args uds -- see Note [Rules and join points] + = case mb_expected_join_arity of + Just ar | args `lengthIs` ar -> uds + _ -> markAllNonTailCalled uds +{- Note [Join point RHSs] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + x = e + join j = Just x + +We want to inline x into j right away, so we don't want to give +the join point a RhsCtxt (#14137). It's not a huge deal, because +the FloatIn pass knows to float into join point RHSs; and the simplifier +does not float things out of join point RHSs. But it's a simple, cheap +thing to do. See #14137. + +Note [Cascading inlines] +~~~~~~~~~~~~~~~~~~~~~~~~ +By default we use an rhsCtxt for the RHS of a binding. This tells the +occ anal n that it's looking at an RHS, which has an effect in +occAnalApp. In particular, for constructor applications, it makes +the arguments appear to have NoOccInfo, so that we don't inline into +them. Thus x = f y + k = Just x +we do not want to inline x. + +But there's a problem. Consider + x1 = a0 : [] + x2 = a1 : x1 + x3 = a2 : x2 + g = f x3 +First time round, it looks as if x1 and x2 occur as an arg of a +let-bound constructor ==> give them a many-occurrence. +But then x3 is inlined (unconditionally as it happens) and +next time round, x2 will be, and the next time round x1 will be +Result: multiple simplifier iterations. Sigh. + +So, when analysing the RHS of x3 we notice that x3 will itself +definitely inline the next time round, and so we analyse x3's rhs in +an ordinary context, not rhsCtxt. Hence the "certainly_inline" stuff. + +Annoyingly, we have to approximate SimplUtils.preInlineUnconditionally. +If (a) the RHS is expandable (see isExpandableApp in occAnalApp), and + (b) certainly_inline says "yes" when preInlineUnconditionally says "no" +then the simplifier iterates indefinitely: + x = f y + k = Just x -- We decide that k is 'certainly_inline' + v = ...k... -- but preInlineUnconditionally doesn't inline it +inline ==> + k = Just (f y) + v = ...k... +float ==> + x1 = f y + k = Just x1 + v = ...k... + +This is worse than the slow cascade, so we only want to say "certainly_inline" +if it really is certain. Look at the note with preInlineUnconditionally +for the various clauses. + + +************************************************************************ +* * + Expressions +* * +************************************************************************ +-} + +occAnal :: OccEnv + -> CoreExpr + -> (UsageDetails, -- Gives info only about the "interesting" Ids + CoreExpr) + +occAnal _ expr@(Type _) = (emptyDetails, expr) +occAnal _ expr@(Lit _) = (emptyDetails, expr) +occAnal env expr@(Var _) = occAnalApp env (expr, [], []) + -- At one stage, I gathered the idRuleVars for the variable here too, + -- which in a way is the right thing to do. + -- But that went wrong right after specialisation, when + -- the *occurrences* of the overloaded function didn't have any + -- rules in them, so the *specialised* versions looked as if they + -- weren't used at all. + +occAnal _ (Coercion co) + = (addManyOccsSet emptyDetails (coVarsOfCo co), Coercion co) + -- See Note [Gather occurrences of coercion variables] + +{- +Note [Gather occurrences of coercion variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to gather info about what coercion variables appear, so that +we can sort them into the right place when doing dependency analysis. +-} + +occAnal env (Tick tickish body) + | SourceNote{} <- tickish + = (usage, Tick tickish body') + -- SourceNotes are best-effort; so we just proceed as usual. + -- If we drop a tick due to the issues described below it's + -- not the end of the world. + + | tickish `tickishScopesLike` SoftScope + = (markAllNonTailCalled usage, Tick tickish body') + + | Breakpoint _ ids <- tickish + = (usage_lam `andUDs` foldr addManyOccs emptyDetails ids, Tick tickish body') + -- never substitute for any of the Ids in a Breakpoint + + | otherwise + = (usage_lam, Tick tickish body') + where + !(usage,body') = occAnal env body + -- for a non-soft tick scope, we can inline lambdas only + usage_lam = markAllNonTailCalled (markAllInsideLam usage) + -- TODO There may be ways to make ticks and join points play + -- nicer together, but right now there are problems: + -- let j x = ... in tick (j 1) + -- Making j a join point may cause the simplifier to drop t + -- (if the tick is put into the continuation). So we don't + -- count j 1 as a tail call. + -- See #14242. + +occAnal env (Cast expr co) + = case occAnal env expr of { (usage, expr') -> + let usage1 = zapDetailsIf (isRhsEnv env) usage + -- usage1: if we see let x = y `cast` co + -- then mark y as 'Many' so that we don't + -- immediately inline y again. + usage2 = addManyOccsSet usage1 (coVarsOfCo co) + -- usage2: see Note [Gather occurrences of coercion variables] + in (markAllNonTailCalled usage2, Cast expr' co) + } + +occAnal env app@(App _ _) + = occAnalApp env (collectArgsTicks tickishFloatable app) + +-- Ignore type variables altogether +-- (a) occurrences inside type lambdas only not marked as InsideLam +-- (b) type variables not in environment + +occAnal env (Lam x body) + | isTyVar x + = case occAnal env body of { (body_usage, body') -> + (markAllNonTailCalled body_usage, Lam x body') + } + +-- For value lambdas we do a special hack. Consider +-- (\x. \y. ...x...) +-- If we did nothing, x is used inside the \y, so would be marked +-- as dangerous to dup. But in the common case where the abstraction +-- is applied to two arguments this is over-pessimistic. +-- So instead, we just mark each binder with its occurrence +-- info in the *body* of the multiple lambda. +-- Then, the simplifier is careful when partially applying lambdas. + +occAnal env expr@(Lam _ _) + = case occAnalLamOrRhs env binders body of { (usage, tagged_binders, body') -> + let + expr' = mkLams tagged_binders body' + usage1 = markAllNonTailCalled usage + one_shot_gp = all isOneShotBndr tagged_binders + final_usage | one_shot_gp = usage1 + | otherwise = markAllInsideLam usage1 + in + (final_usage, expr') } + where + (binders, body) = collectBinders expr + +occAnal env (Case scrut bndr ty alts) + = case occ_anal_scrut scrut alts of { (scrut_usage, scrut') -> + case mapAndUnzip occ_anal_alt alts of { (alts_usage_s, alts') -> + let + alts_usage = foldr orUDs emptyDetails alts_usage_s + (alts_usage1, tagged_bndr) = tagLamBinder alts_usage bndr + total_usage = markAllNonTailCalled scrut_usage `andUDs` alts_usage1 + -- Alts can have tail calls, but the scrutinee can't + in + total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }} + where + alt_env = mkAltEnv env scrut bndr + occ_anal_alt = occAnalAlt alt_env + + occ_anal_scrut (Var v) (alt1 : other_alts) + | not (null other_alts) || not (isDefaultAlt alt1) + = (mkOneOcc env v True 0, Var v) + -- The 'True' says that the variable occurs in an interesting + -- context; the case has at least one non-default alternative + occ_anal_scrut (Tick t e) alts + | t `tickishScopesLike` SoftScope + -- No reason to not look through all ticks here, but only + -- for soft-scoped ticks we can do so without having to + -- update returned occurance info (see occAnal) + = second (Tick t) $ occ_anal_scrut e alts + + occ_anal_scrut scrut _alts + = occAnal (vanillaCtxt env) scrut -- No need for rhsCtxt + +occAnal env (Let bind body) + = case occAnal env body of { (body_usage, body') -> + case occAnalBind env NotTopLevel + noImpRuleEdges bind + body_usage of { (final_usage, new_binds) -> + (final_usage, mkLets new_binds body') }} + +occAnalArgs :: OccEnv -> [CoreExpr] -> [OneShots] -> (UsageDetails, [CoreExpr]) +occAnalArgs _ [] _ + = (emptyDetails, []) + +occAnalArgs env (arg:args) one_shots + | isTypeArg arg + = case occAnalArgs env args one_shots of { (uds, args') -> + (uds, arg:args') } + + | otherwise + = case argCtxt env one_shots of { (arg_env, one_shots') -> + case occAnal arg_env arg of { (uds1, arg') -> + case occAnalArgs env args one_shots' of { (uds2, args') -> + (uds1 `andUDs` uds2, arg':args') }}} + +{- +Applications are dealt with specially because we want +the "build hack" to work. + +Note [Arguments of let-bound constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f x = let y = expensive x in + let z = (True,y) in + (case z of {(p,q)->q}, case z of {(p,q)->q}) +We feel free to duplicate the WHNF (True,y), but that means +that y may be duplicated thereby. + +If we aren't careful we duplicate the (expensive x) call! +Constructors are rather like lambdas in this way. +-} + +occAnalApp :: OccEnv + -> (Expr CoreBndr, [Arg CoreBndr], [Tickish Id]) + -> (UsageDetails, Expr CoreBndr) +occAnalApp env (Var fun, args, ticks) + | null ticks = (uds, mkApps (Var fun) args') + | otherwise = (uds, mkTicks ticks $ mkApps (Var fun) args') + where + uds = fun_uds `andUDs` final_args_uds + + !(args_uds, args') = occAnalArgs env args one_shots + !final_args_uds + | isRhsEnv env && is_exp = markAllNonTailCalled $ + markAllInsideLam args_uds + | otherwise = markAllNonTailCalled args_uds + -- We mark the free vars of the argument of a constructor or PAP + -- as "inside-lambda", if it is the RHS of a let(rec). + -- This means that nothing gets inlined into a constructor or PAP + -- argument position, which is what we want. Typically those + -- constructor arguments are just variables, or trivial expressions. + -- We use inside-lam because it's like eta-expanding the PAP. + -- + -- This is the *whole point* of the isRhsEnv predicate + -- See Note [Arguments of let-bound constructors] + + n_val_args = valArgCount args + n_args = length args + fun_uds = mkOneOcc env fun (n_val_args > 0) n_args + is_exp = isExpandableApp fun n_val_args + -- See Note [CONLIKE pragma] in BasicTypes + -- The definition of is_exp should match that in Simplify.prepareRhs + + one_shots = argsOneShots (idStrictness fun) guaranteed_val_args + guaranteed_val_args = n_val_args + length (takeWhile isOneShotInfo + (occ_one_shots env)) + -- See Note [Sources of one-shot information], bullet point A'] + +occAnalApp env (fun, args, ticks) + = (markAllNonTailCalled (fun_uds `andUDs` args_uds), + mkTicks ticks $ mkApps fun' args') + where + !(fun_uds, fun') = occAnal (addAppCtxt env args) fun + -- The addAppCtxt is a bit cunning. One iteration of the simplifier + -- often leaves behind beta redexs like + -- (\x y -> e) a1 a2 + -- Here we would like to mark x,y as one-shot, and treat the whole + -- thing much like a let. We do this by pushing some True items + -- onto the context stack. + !(args_uds, args') = occAnalArgs env args [] + +zapDetailsIf :: Bool -- If this is true + -> UsageDetails -- Then do zapDetails on this + -> UsageDetails +zapDetailsIf True uds = zapDetails uds +zapDetailsIf False uds = uds + +{- +Note [Sources of one-shot information] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The occurrence analyser obtains one-shot-lambda information from two sources: + +A: Saturated applications: eg f e1 .. en + + In general, given a call (f e1 .. en) we can propagate one-shot info from + f's strictness signature into e1 .. en, but /only/ if n is enough to + saturate the strictness signature. A strictness signature like + + f :: C1(C1(L))LS + + means that *if f is applied to three arguments* then it will guarantee to + call its first argument at most once, and to call the result of that at + most once. But if f has fewer than three arguments, all bets are off; e.g. + + map (f (\x y. expensive) e2) xs + + Here the \x y abstraction may be called many times (once for each element of + xs) so we should not mark x and y as one-shot. But if it was + + map (f (\x y. expensive) 3 2) xs + + then the first argument of f will be called at most once. + + The one-shot info, derived from f's strictness signature, is + computed by 'argsOneShots', called in occAnalApp. + +A': Non-obviously saturated applications: eg build (f (\x y -> expensive)) + where f is as above. + + In this case, f is only manifestly applied to one argument, so it does not + look saturated. So by the previous point, we should not use its strictness + signature to learn about the one-shotness of \x y. But in this case we can: + build is fully applied, so we may use its strictness signature; and from + that we learn that build calls its argument with two arguments *at most once*. + + So there is really only one call to f, and it will have three arguments. In + that sense, f is saturated, and we may proceed as described above. + + Hence the computation of 'guaranteed_val_args' in occAnalApp, using + '(occ_one_shots env)'. See also #13227, comment:9 + +B: Let-bindings: eg let f = \c. let ... in \n -> blah + in (build f, build f) + + Propagate one-shot info from the demanand-info on 'f' to the + lambdas in its RHS (which may not be syntactically at the top) + + This information must have come from a previous run of the demanand + analyser. + +Previously, the demand analyser would *also* set the one-shot information, but +that code was buggy (see #11770), so doing it only in on place, namely here, is +saner. + +Note [OneShots] +~~~~~~~~~~~~~~~ +When analysing an expression, the occ_one_shots argument contains information +about how the function is being used. The length of the list indicates +how many arguments will eventually be passed to the analysed expression, +and the OneShotInfo indicates whether this application is once or multiple times. + +Example: + + Context of f occ_one_shots when analysing f + + f 1 2 [OneShot, OneShot] + map (f 1) [OneShot, NoOneShotInfo] + build f [OneShot, OneShot] + f 1 2 `seq` f 2 1 [NoOneShotInfo, OneShot] + +Note [Binders in case alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + case x of y { (a,b) -> f y } +We treat 'a', 'b' as dead, because they don't physically occur in the +case alternative. (Indeed, a variable is dead iff it doesn't occur in +its scope in the output of OccAnal.) It really helps to know when +binders are unused. See esp the call to isDeadBinder in +Simplify.mkDupableAlt + +In this example, though, the Simplifier will bring 'a' and 'b' back to +life, beause it binds 'y' to (a,b) (imagine got inlined and +scrutinised y). +-} + +occAnalLamOrRhs :: OccEnv -> [CoreBndr] -> CoreExpr + -> (UsageDetails, [CoreBndr], CoreExpr) +occAnalLamOrRhs env [] body + = case occAnal env body of (body_usage, body') -> (body_usage, [], body') + -- RHS of thunk or nullary join point +occAnalLamOrRhs env (bndr:bndrs) body + | isTyVar bndr + = -- Important: Keep the environment so that we don't inline into an RHS like + -- \(@ x) -> C @x (f @x) + -- (see the beginning of Note [Cascading inlines]). + case occAnalLamOrRhs env bndrs body of + (body_usage, bndrs', body') -> (body_usage, bndr:bndrs', body') +occAnalLamOrRhs env binders body + = case occAnal env_body body of { (body_usage, body') -> + let + (final_usage, tagged_binders) = tagLamBinders body_usage binders' + -- Use binders' to put one-shot info on the lambdas + in + (final_usage, tagged_binders, body') } + where + (env_body, binders') = oneShotGroup env binders + +occAnalAlt :: (OccEnv, Maybe (Id, CoreExpr)) + -> CoreAlt + -> (UsageDetails, Alt IdWithOccInfo) +occAnalAlt (env, scrut_bind) (con, bndrs, rhs) + = case occAnal env rhs of { (rhs_usage1, rhs1) -> + let + (alt_usg, tagged_bndrs) = tagLamBinders rhs_usage1 bndrs + -- See Note [Binders in case alternatives] + (alt_usg', rhs2) = wrapAltRHS env scrut_bind alt_usg tagged_bndrs rhs1 + in + (alt_usg', (con, tagged_bndrs, rhs2)) } + +wrapAltRHS :: OccEnv + -> Maybe (Id, CoreExpr) -- proxy mapping generated by mkAltEnv + -> UsageDetails -- usage for entire alt (p -> rhs) + -> [Var] -- alt binders + -> CoreExpr -- alt RHS + -> (UsageDetails, CoreExpr) +wrapAltRHS env (Just (scrut_var, let_rhs)) alt_usg bndrs alt_rhs + | occ_binder_swap env + , scrut_var `usedIn` alt_usg -- bndrs are not be present in alt_usg so this + -- handles condition (a) in Note [Binder swap] + , not captured -- See condition (b) in Note [Binder swap] + = ( alt_usg' `andUDs` let_rhs_usg + , Let (NonRec tagged_scrut_var let_rhs') alt_rhs ) + where + captured = any (`usedIn` let_rhs_usg) bndrs -- Check condition (b) + + -- The rhs of the let may include coercion variables + -- if the scrutinee was a cast, so we must gather their + -- usage. See Note [Gather occurrences of coercion variables] + -- Moreover, the rhs of the let may mention the case-binder, and + -- we want to gather its occ-info as well + (let_rhs_usg, let_rhs') = occAnal env let_rhs + + (alt_usg', tagged_scrut_var) = tagLamBinder alt_usg scrut_var + +wrapAltRHS _ _ alt_usg _ alt_rhs + = (alt_usg, alt_rhs) + +{- +************************************************************************ +* * + OccEnv +* * +************************************************************************ +-} + +data OccEnv + = OccEnv { occ_encl :: !OccEncl -- Enclosing context information + , occ_one_shots :: !OneShots -- See Note [OneShots] + , occ_gbl_scrut :: GlobalScruts + + , occ_unf_act :: Id -> Bool -- Which Id unfoldings are active + + , occ_rule_act :: Activation -> Bool -- Which rules are active + -- See Note [Finding rule RHS free vars] + + , occ_binder_swap :: !Bool -- enable the binder_swap + -- See CorePrep Note [Dead code in CorePrep] + } + +type GlobalScruts = IdSet -- See Note [Binder swap on GlobalId scrutinees] + +----------------------------- +-- OccEncl is used to control whether to inline into constructor arguments +-- For example: +-- x = (p,q) -- Don't inline p or q +-- y = /\a -> (p a, q a) -- Still don't inline p or q +-- z = f (p,q) -- Do inline p,q; it may make a rule fire +-- So OccEncl tells enough about the context to know what to do when +-- we encounter a constructor application or PAP. + +data OccEncl + = OccRhs -- RHS of let(rec), albeit perhaps inside a type lambda + -- Don't inline into constructor args here + | OccVanilla -- Argument of function, body of lambda, scruintee of case etc. + -- Do inline into constructor args here + +instance Outputable OccEncl where + ppr OccRhs = text "occRhs" + ppr OccVanilla = text "occVanilla" + +-- See note [OneShots] +type OneShots = [OneShotInfo] + +initOccEnv :: OccEnv +initOccEnv + = OccEnv { occ_encl = OccVanilla + , occ_one_shots = [] + , occ_gbl_scrut = emptyVarSet + -- To be conservative, we say that all + -- inlines and rules are active + , occ_unf_act = \_ -> True + , occ_rule_act = \_ -> True + , occ_binder_swap = True } + +vanillaCtxt :: OccEnv -> OccEnv +vanillaCtxt env = env { occ_encl = OccVanilla, occ_one_shots = [] } + +rhsCtxt :: OccEnv -> OccEnv +rhsCtxt env = env { occ_encl = OccRhs, occ_one_shots = [] } + +argCtxt :: OccEnv -> [OneShots] -> (OccEnv, [OneShots]) +argCtxt env [] + = (env { occ_encl = OccVanilla, occ_one_shots = [] }, []) +argCtxt env (one_shots:one_shots_s) + = (env { occ_encl = OccVanilla, occ_one_shots = one_shots }, one_shots_s) + +isRhsEnv :: OccEnv -> Bool +isRhsEnv (OccEnv { occ_encl = OccRhs }) = True +isRhsEnv (OccEnv { occ_encl = OccVanilla }) = False + +oneShotGroup :: OccEnv -> [CoreBndr] + -> ( OccEnv + , [CoreBndr] ) + -- The result binders have one-shot-ness set that they might not have had originally. + -- This happens in (build (\c n -> e)). Here the occurrence analyser + -- linearity context knows that c,n are one-shot, and it records that fact in + -- the binder. This is useful to guide subsequent float-in/float-out tranformations + +oneShotGroup env@(OccEnv { occ_one_shots = ctxt }) bndrs + = go ctxt bndrs [] + where + go ctxt [] rev_bndrs + = ( env { occ_one_shots = ctxt, occ_encl = OccVanilla } + , reverse rev_bndrs ) + + go [] bndrs rev_bndrs + = ( env { occ_one_shots = [], occ_encl = OccVanilla } + , reverse rev_bndrs ++ bndrs ) + + go ctxt@(one_shot : ctxt') (bndr : bndrs) rev_bndrs + | isId bndr = go ctxt' bndrs (bndr': rev_bndrs) + | otherwise = go ctxt bndrs (bndr : rev_bndrs) + where + bndr' = updOneShotInfo bndr one_shot + -- Use updOneShotInfo, not setOneShotInfo, as pre-existing + -- one-shot info might be better than what we can infer, e.g. + -- due to explicit use of the magic 'oneShot' function. + -- See Note [The oneShot function] + + +markJoinOneShots :: Maybe JoinArity -> [Var] -> [Var] +-- Mark the lambdas of a non-recursive join point as one-shot. +-- This is good to prevent gratuitous float-out etc +markJoinOneShots mb_join_arity bndrs + = case mb_join_arity of + Nothing -> bndrs + Just n -> go n bndrs + where + go 0 bndrs = bndrs + go _ [] = [] -- This can legitimately happen. + -- e.g. let j = case ... in j True + -- This will become an arity-1 join point after the + -- simplifier has eta-expanded it; but it may not have + -- enough lambdas /yet/. (Lint checks that JoinIds do + -- have enough lambdas.) + go n (b:bs) = b' : go (n-1) bs + where + b' | isId b = setOneShotLambda b + | otherwise = b + +addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv +addAppCtxt env@(OccEnv { occ_one_shots = ctxt }) args + = env { occ_one_shots = replicate (valArgCount args) OneShotLam ++ ctxt } + +transClosureFV :: UniqFM VarSet -> UniqFM VarSet +-- If (f,g), (g,h) are in the input, then (f,h) is in the output +-- as well as (f,g), (g,h) +transClosureFV env + | no_change = env + | otherwise = transClosureFV (listToUFM new_fv_list) + where + (no_change, new_fv_list) = mapAccumL bump True (nonDetUFMToList env) + -- It's OK to use nonDetUFMToList here because we'll forget the + -- ordering by creating a new set with listToUFM + bump no_change (b,fvs) + | no_change_here = (no_change, (b,fvs)) + | otherwise = (False, (b,new_fvs)) + where + (new_fvs, no_change_here) = extendFvs env fvs + +------------- +extendFvs_ :: UniqFM VarSet -> VarSet -> VarSet +extendFvs_ env s = fst (extendFvs env s) -- Discard the Bool flag + +extendFvs :: UniqFM VarSet -> VarSet -> (VarSet, Bool) +-- (extendFVs env s) returns +-- (s `union` env(s), env(s) `subset` s) +extendFvs env s + | isNullUFM env + = (s, True) + | otherwise + = (s `unionVarSet` extras, extras `subVarSet` s) + where + extras :: VarSet -- env(s) + extras = nonDetFoldUFM unionVarSet emptyVarSet $ + -- It's OK to use nonDetFoldUFM here because unionVarSet commutes + intersectUFM_C (\x _ -> x) env (getUniqSet s) + +{- +************************************************************************ +* * + Binder swap +* * +************************************************************************ + +Note [Binder swap] +~~~~~~~~~~~~~~~~~~ +The "binder swap" tranformation swaps occurence of the +scrutinee of a case for occurrences of the case-binder: + + (1) case x of b { pi -> ri } + ==> + case x of b { pi -> let x=b in ri } + + (2) case (x |> co) of b { pi -> ri } + ==> + case (x |> co) of b { pi -> let x = b |> sym co in ri } + +In both cases, the trivial 'let' can be eliminated by the +immediately following simplifier pass. + +There are two reasons for making this swap: + +(A) It reduces the number of occurrences of the scrutinee, x. + That in turn might reduce its occurrences to one, so we + can inline it and save an allocation. E.g. + let x = factorial y in case x of b { I# v -> ...x... } + If we replace 'x' by 'b' in the alternative we get + let x = factorial y in case x of b { I# v -> ...b... } + and now we can inline 'x', thus + case (factorial y) of b { I# v -> ...b... } + +(B) The case-binder b has unfolding information; in the + example above we know that b = I# v. That in turn allows + nested cases to simplify. Consider + case x of b { I# v -> + ...(case x of b2 { I# v2 -> rhs })... + If we replace 'x' by 'b' in the alternative we get + case x of b { I# v -> + ...(case b of b2 { I# v2 -> rhs })... + and now it is trivial to simplify the inner case: + case x of b { I# v -> + ...(let b2 = b in rhs)... + + The same can happen even if the scrutinee is a variable + with a cast: see Note [Case of cast] + +In both cases, in a particular alternative (pi -> ri), we only +add the binding if + (a) x occurs free in (pi -> ri) + (ie it occurs in ri, but is not bound in pi) + (b) the pi does not bind b (or the free vars of co) +We need (a) and (b) for the inserted binding to be correct. + +For the alternatives where we inject the binding, we can transfer +all x's OccInfo to b. And that is the point. + +Notice that + * The deliberate shadowing of 'x'. + * That (a) rapidly becomes false, so no bindings are injected. + +The reason for doing these transformations /here in the occurrence +analyser/ is because it allows us to adjust the OccInfo for 'x' and +'b' as we go. + + * Suppose the only occurrences of 'x' are the scrutinee and in the + ri; then this transformation makes it occur just once, and hence + get inlined right away. + + * If instead we do this in the Simplifier, we don't know whether 'x' + is used in ri, so we are forced to pessimistically zap b's OccInfo + even though it is typically dead (ie neither it nor x appear in + the ri). There's nothing actually wrong with zapping it, except + that it's kind of nice to know which variables are dead. My nose + tells me to keep this information as robustly as possible. + +The Maybe (Id,CoreExpr) passed to occAnalAlt is the extra let-binding +{x=b}; it's Nothing if the binder-swap doesn't happen. + +There is a danger though. Consider + let v = x +# y + in case (f v) of w -> ...v...v... +And suppose that (f v) expands to just v. Then we'd like to +use 'w' instead of 'v' in the alternative. But it may be too +late; we may have substituted the (cheap) x+#y for v in the +same simplifier pass that reduced (f v) to v. + +I think this is just too bad. CSE will recover some of it. + +Note [Case of cast] +~~~~~~~~~~~~~~~~~~~ +Consider case (x `cast` co) of b { I# -> + ... (case (x `cast` co) of {...}) ... +We'd like to eliminate the inner case. That is the motivation for +equation (2) in Note [Binder swap]. When we get to the inner case, we +inline x, cancel the casts, and away we go. + +Note [Binder swap on GlobalId scrutinees] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When the scrutinee is a GlobalId we must take care in two ways + + i) In order to *know* whether 'x' occurs free in the RHS, we need its + occurrence info. BUT, we don't gather occurrence info for + GlobalIds. That's the reason for the (small) occ_gbl_scrut env in + OccEnv is for: it says "gather occurrence info for these". + + ii) We must call localiseId on 'x' first, in case it's a GlobalId, or + has an External Name. See, for example, SimplEnv Note [Global Ids in + the substitution]. + +Note [Zap case binders in proxy bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +From the original + case x of cb(dead) { p -> ...x... } +we will get + case x of cb(live) { p -> let x = cb in ...x... } + +Core Lint never expects to find an *occurrence* of an Id marked +as Dead, so we must zap the OccInfo on cb before making the +binding x = cb. See #5028. + +NB: the OccInfo on /occurrences/ really doesn't matter much; the simplifier +doesn't use it. So this is only to satisfy the perhpas-over-picky Lint. + +Historical note [no-case-of-case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We *used* to suppress the binder-swap in case expressions when +-fno-case-of-case is on. Old remarks: + "This happens in the first simplifier pass, + and enhances full laziness. Here's the bad case: + f = \ y -> ...(case x of I# v -> ...(case x of ...) ... ) + If we eliminate the inner case, we trap it inside the I# v -> arm, + which might prevent some full laziness happening. I've seen this + in action in spectral/cichelli/Prog.hs: + [(m,n) | m <- [1..max], n <- [1..max]] + Hence the check for NoCaseOfCase." +However, now the full-laziness pass itself reverses the binder-swap, so this +check is no longer necessary. + +Historical note [Suppressing the case binder-swap] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This old note describes a problem that is also fixed by doing the +binder-swap in OccAnal: + + There is another situation when it might make sense to suppress the + case-expression binde-swap. If we have + + case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 } + ...other cases .... } + + We'll perform the binder-swap for the outer case, giving + + case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 } + ...other cases .... } + + But there is no point in doing it for the inner case, because w1 can't + be inlined anyway. Furthermore, doing the case-swapping involves + zapping w2's occurrence info (see paragraphs that follow), and that + forces us to bind w2 when doing case merging. So we get + + case x of w1 { A -> let w2 = w1 in e1 + B -> let w2 = w1 in e2 + ...other cases .... } + + This is plain silly in the common case where w2 is dead. + + Even so, I can't see a good way to implement this idea. I tried + not doing the binder-swap if the scrutinee was already evaluated + but that failed big-time: + + data T = MkT !Int + + case v of w { MkT x -> + case x of x1 { I# y1 -> + case x of x2 { I# y2 -> ... + + Notice that because MkT is strict, x is marked "evaluated". But to + eliminate the last case, we must either make sure that x (as well as + x1) has unfolding MkT y1. The straightforward thing to do is to do + the binder-swap. So this whole note is a no-op. + +It's fixed by doing the binder-swap in OccAnal because we can do the +binder-swap unconditionally and still get occurrence analysis +information right. +-} + +mkAltEnv :: OccEnv -> CoreExpr -> Id -> (OccEnv, Maybe (Id, CoreExpr)) +-- Does three things: a) makes the occ_one_shots = OccVanilla +-- b) extends the GlobalScruts if possible +-- c) returns a proxy mapping, binding the scrutinee +-- to the case binder, if possible +mkAltEnv env@(OccEnv { occ_gbl_scrut = pe }) scrut case_bndr + = case stripTicksTopE (const True) scrut of + Var v -> add_scrut v case_bndr' + Cast (Var v) co -> add_scrut v (Cast case_bndr' (mkSymCo co)) + -- See Note [Case of cast] + _ -> (env { occ_encl = OccVanilla }, Nothing) + + where + add_scrut v rhs + | isGlobalId v = (env { occ_encl = OccVanilla }, Nothing) + | otherwise = ( env { occ_encl = OccVanilla + , occ_gbl_scrut = pe `extendVarSet` v } + , Just (localise v, rhs) ) + -- ToDO: this isGlobalId stuff is a TEMPORARY FIX + -- to avoid the binder-swap for GlobalIds + -- See #16346 + + case_bndr' = Var (zapIdOccInfo case_bndr) + -- See Note [Zap case binders in proxy bindings] + + -- Localise the scrut_var before shadowing it; we're making a + -- new binding for it, and it might have an External Name, or + -- even be a GlobalId; Note [Binder swap on GlobalId scrutinees] + -- Also we don't want any INLINE or NOINLINE pragmas! + localise scrut_var = mkLocalIdOrCoVar (localiseName (idName scrut_var)) + (idType scrut_var) + +{- +************************************************************************ +* * +\subsection[OccurAnal-types]{OccEnv} +* * +************************************************************************ + +Note [UsageDetails and zapping] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +On many occasions, we must modify all gathered occurrence data at once. For +instance, all occurrences underneath a (non-one-shot) lambda set the +'occ_in_lam' flag to become 'True'. We could use 'mapVarEnv' to do this, but +that takes O(n) time and we will do this often---in particular, there are many +places where tail calls are not allowed, and each of these causes all variables +to get marked with 'NoTailCallInfo'. + +Instead of relying on `mapVarEnv`, then, we carry three 'IdEnv's around along +with the 'OccInfoEnv'. Each of these extra environments is a "zapped set" +recording which variables have been zapped in some way. Zapping all occurrence +info then simply means setting the corresponding zapped set to the whole +'OccInfoEnv', a fast O(1) operation. +-} + +type OccInfoEnv = IdEnv OccInfo -- A finite map from ids to their usage + -- INVARIANT: never IAmDead + -- (Deadness is signalled by not being in the map at all) + +type ZappedSet = OccInfoEnv -- Values are ignored + +data UsageDetails + = UD { ud_env :: !OccInfoEnv + , ud_z_many :: ZappedSet -- apply 'markMany' to these + , ud_z_in_lam :: ZappedSet -- apply 'markInsideLam' to these + , ud_z_no_tail :: ZappedSet } -- apply 'markNonTailCalled' to these + -- INVARIANT: All three zapped sets are subsets of the OccInfoEnv + +instance Outputable UsageDetails where + ppr ud = ppr (ud_env (flattenUsageDetails ud)) + +------------------- +-- UsageDetails API + +andUDs, orUDs + :: UsageDetails -> UsageDetails -> UsageDetails +andUDs = combineUsageDetailsWith addOccInfo +orUDs = combineUsageDetailsWith orOccInfo + +andUDsList :: [UsageDetails] -> UsageDetails +andUDsList = foldl' andUDs emptyDetails + +mkOneOcc :: OccEnv -> Id -> InterestingCxt -> JoinArity -> UsageDetails +mkOneOcc env id int_cxt arity + | isLocalId id + = singleton $ OneOcc { occ_in_lam = False + , occ_one_br = True + , occ_int_cxt = int_cxt + , occ_tail = AlwaysTailCalled arity } + | id `elemVarSet` occ_gbl_scrut env + = singleton noOccInfo + + | otherwise + = emptyDetails + where + singleton info = emptyDetails { ud_env = unitVarEnv id info } + +addOneOcc :: UsageDetails -> Id -> OccInfo -> UsageDetails +addOneOcc ud id info + = ud { ud_env = extendVarEnv_C plus_zapped (ud_env ud) id info } + `alterZappedSets` (`delVarEnv` id) + where + plus_zapped old new = doZapping ud id old `addOccInfo` new + +addManyOccsSet :: UsageDetails -> VarSet -> UsageDetails +addManyOccsSet usage id_set = nonDetFoldUniqSet addManyOccs usage id_set + -- It's OK to use nonDetFoldUFM here because addManyOccs commutes + +-- Add several occurrences, assumed not to be tail calls +addManyOccs :: Var -> UsageDetails -> UsageDetails +addManyOccs v u | isId v = addOneOcc u v noOccInfo + | otherwise = u + -- Give a non-committal binder info (i.e noOccInfo) because + -- a) Many copies of the specialised thing can appear + -- b) We don't want to substitute a BIG expression inside a RULE + -- even if that's the only occurrence of the thing + -- (Same goes for INLINE.) + +delDetails :: UsageDetails -> Id -> UsageDetails +delDetails ud bndr + = ud `alterUsageDetails` (`delVarEnv` bndr) + +delDetailsList :: UsageDetails -> [Id] -> UsageDetails +delDetailsList ud bndrs + = ud `alterUsageDetails` (`delVarEnvList` bndrs) + +emptyDetails :: UsageDetails +emptyDetails = UD { ud_env = emptyVarEnv + , ud_z_many = emptyVarEnv + , ud_z_in_lam = emptyVarEnv + , ud_z_no_tail = emptyVarEnv } + +isEmptyDetails :: UsageDetails -> Bool +isEmptyDetails = isEmptyVarEnv . ud_env + +markAllMany, markAllInsideLam, markAllNonTailCalled, zapDetails + :: UsageDetails -> UsageDetails +markAllMany ud = ud { ud_z_many = ud_env ud } +markAllInsideLam ud = ud { ud_z_in_lam = ud_env ud } +markAllNonTailCalled ud = ud { ud_z_no_tail = ud_env ud } + +zapDetails = markAllMany . markAllNonTailCalled -- effectively sets to noOccInfo + +lookupDetails :: UsageDetails -> Id -> OccInfo +lookupDetails ud id + | isCoVar id -- We do not currenly gather occurrence info (from types) + = noOccInfo -- for CoVars, so we must conservatively mark them as used + -- See Note [DoO not mark CoVars as dead] + | otherwise + = case lookupVarEnv (ud_env ud) id of + Just occ -> doZapping ud id occ + Nothing -> IAmDead + +usedIn :: Id -> UsageDetails -> Bool +v `usedIn` ud = isExportedId v || v `elemVarEnv` ud_env ud + +udFreeVars :: VarSet -> UsageDetails -> VarSet +-- Find the subset of bndrs that are mentioned in uds +udFreeVars bndrs ud = restrictUniqSetToUFM bndrs (ud_env ud) + +{- Note [Do not mark CoVars as dead] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's obviously wrong to mark CoVars as dead if they are used. +Currently we don't traverse types to gather usase info for CoVars, +so we had better treat them as having noOccInfo. + +This showed up in #15696 we had something like + case eq_sel d of co -> ...(typeError @(...co...) "urk")... + +Then 'd' was substitued by a dictionary, so the expression +simpified to + case (Coercion ) of co -> ...(typeError @(...co...) "urk")... + +But then the "drop the case altogether" equation of rebuildCase +thought that 'co' was dead, and discarded the entire case. Urk! + +I have no idea how we managed to avoid this pitfall for so long! +-} + +------------------- +-- Auxiliary functions for UsageDetails implementation + +combineUsageDetailsWith :: (OccInfo -> OccInfo -> OccInfo) + -> UsageDetails -> UsageDetails -> UsageDetails +combineUsageDetailsWith plus_occ_info ud1 ud2 + | isEmptyDetails ud1 = ud2 + | isEmptyDetails ud2 = ud1 + | otherwise + = UD { ud_env = plusVarEnv_C plus_occ_info (ud_env ud1) (ud_env ud2) + , ud_z_many = plusVarEnv (ud_z_many ud1) (ud_z_many ud2) + , ud_z_in_lam = plusVarEnv (ud_z_in_lam ud1) (ud_z_in_lam ud2) + , ud_z_no_tail = plusVarEnv (ud_z_no_tail ud1) (ud_z_no_tail ud2) } + +doZapping :: UsageDetails -> Var -> OccInfo -> OccInfo +doZapping ud var occ + = doZappingByUnique ud (varUnique var) occ + +doZappingByUnique :: UsageDetails -> Unique -> OccInfo -> OccInfo +doZappingByUnique ud uniq + = (if | in_subset ud_z_many -> markMany + | in_subset ud_z_in_lam -> markInsideLam + | otherwise -> id) . + (if | in_subset ud_z_no_tail -> markNonTailCalled + | otherwise -> id) + where + in_subset field = uniq `elemVarEnvByKey` field ud + +alterZappedSets :: UsageDetails -> (ZappedSet -> ZappedSet) -> UsageDetails +alterZappedSets ud f + = ud { ud_z_many = f (ud_z_many ud) + , ud_z_in_lam = f (ud_z_in_lam ud) + , ud_z_no_tail = f (ud_z_no_tail ud) } + +alterUsageDetails :: UsageDetails -> (OccInfoEnv -> OccInfoEnv) -> UsageDetails +alterUsageDetails ud f + = ud { ud_env = f (ud_env ud) } + `alterZappedSets` f + +flattenUsageDetails :: UsageDetails -> UsageDetails +flattenUsageDetails ud + = ud { ud_env = mapUFM_Directly (doZappingByUnique ud) (ud_env ud) } + `alterZappedSets` const emptyVarEnv + +------------------- +-- See Note [Adjusting right-hand sides] +adjustRhsUsage :: Maybe JoinArity -> RecFlag + -> [CoreBndr] -- Outer lambdas, AFTER occ anal + -> UsageDetails -> UsageDetails +adjustRhsUsage mb_join_arity rec_flag bndrs usage + = maybe_mark_lam (maybe_drop_tails usage) + where + maybe_mark_lam ud | one_shot = ud + | otherwise = markAllInsideLam ud + maybe_drop_tails ud | exact_join = ud + | otherwise = markAllNonTailCalled ud + + one_shot = case mb_join_arity of + Just join_arity + | isRec rec_flag -> False + | otherwise -> all isOneShotBndr (drop join_arity bndrs) + Nothing -> all isOneShotBndr bndrs + + exact_join = case mb_join_arity of + Just join_arity -> bndrs `lengthIs` join_arity + _ -> False + +type IdWithOccInfo = Id + +tagLamBinders :: UsageDetails -- Of scope + -> [Id] -- Binders + -> (UsageDetails, -- Details with binders removed + [IdWithOccInfo]) -- Tagged binders +tagLamBinders usage binders + = usage' `seq` (usage', bndrs') + where + (usage', bndrs') = mapAccumR tagLamBinder usage binders + +tagLamBinder :: UsageDetails -- Of scope + -> Id -- Binder + -> (UsageDetails, -- Details with binder removed + IdWithOccInfo) -- Tagged binders +-- Used for lambda and case binders +-- It copes with the fact that lambda bindings can have a +-- stable unfolding, used for join points +tagLamBinder usage bndr + = (usage2, bndr') + where + occ = lookupDetails usage bndr + bndr' = setBinderOcc (markNonTailCalled occ) bndr + -- Don't try to make an argument into a join point + usage1 = usage `delDetails` bndr + usage2 | isId bndr = addManyOccsSet usage1 (idUnfoldingVars bndr) + -- This is effectively the RHS of a + -- non-join-point binding, so it's okay to use + -- addManyOccsSet, which assumes no tail calls + | otherwise = usage1 + +tagNonRecBinder :: TopLevelFlag -- At top level? + -> UsageDetails -- Of scope + -> CoreBndr -- Binder + -> (UsageDetails, -- Details with binder removed + IdWithOccInfo) -- Tagged binder + +tagNonRecBinder lvl usage binder + = let + occ = lookupDetails usage binder + will_be_join = decideJoinPointHood lvl usage [binder] + occ' | will_be_join = -- must already be marked AlwaysTailCalled + ASSERT(isAlwaysTailCalled occ) occ + | otherwise = markNonTailCalled occ + binder' = setBinderOcc occ' binder + usage' = usage `delDetails` binder + in + usage' `seq` (usage', binder') + +tagRecBinders :: TopLevelFlag -- At top level? + -> UsageDetails -- Of body of let ONLY + -> [(CoreBndr, -- Binder + UsageDetails, -- RHS usage details + [CoreBndr])] -- Lambdas in new RHS + -> (UsageDetails, -- Adjusted details for whole scope, + -- with binders removed + [IdWithOccInfo]) -- Tagged binders +-- Substantially more complicated than non-recursive case. Need to adjust RHS +-- details *before* tagging binders (because the tags depend on the RHSes). +tagRecBinders lvl body_uds triples + = let + (bndrs, rhs_udss, _) = unzip3 triples + + -- 1. Determine join-point-hood of whole group, as determined by + -- the *unadjusted* usage details + unadj_uds = foldr andUDs body_uds rhs_udss + will_be_joins = decideJoinPointHood lvl unadj_uds bndrs + + -- 2. Adjust usage details of each RHS, taking into account the + -- join-point-hood decision + rhs_udss' = map adjust triples + adjust (bndr, rhs_uds, rhs_bndrs) + = adjustRhsUsage mb_join_arity Recursive rhs_bndrs rhs_uds + where + -- Can't use willBeJoinId_maybe here because we haven't tagged the + -- binder yet (the tag depends on these adjustments!) + mb_join_arity + | will_be_joins + , let occ = lookupDetails unadj_uds bndr + , AlwaysTailCalled arity <- tailCallInfo occ + = Just arity + | otherwise + = ASSERT(not will_be_joins) -- Should be AlwaysTailCalled if + Nothing -- we are making join points! + + -- 3. Compute final usage details from adjusted RHS details + adj_uds = foldr andUDs body_uds rhs_udss' + + -- 4. Tag each binder with its adjusted details + bndrs' = [ setBinderOcc (lookupDetails adj_uds bndr) bndr + | bndr <- bndrs ] + + -- 5. Drop the binders from the adjusted details and return + usage' = adj_uds `delDetailsList` bndrs + in + (usage', bndrs') + +setBinderOcc :: OccInfo -> CoreBndr -> CoreBndr +setBinderOcc occ_info bndr + | isTyVar bndr = bndr + | isExportedId bndr = if isManyOccs (idOccInfo bndr) + then bndr + else setIdOccInfo bndr noOccInfo + -- Don't use local usage info for visible-elsewhere things + -- BUT *do* erase any IAmALoopBreaker annotation, because we're + -- about to re-generate it and it shouldn't be "sticky" + + | otherwise = setIdOccInfo bndr occ_info + +-- | Decide whether some bindings should be made into join points or not. +-- Returns `False` if they can't be join points. Note that it's an +-- all-or-nothing decision, as if multiple binders are given, they're +-- assumed to be mutually recursive. +-- +-- It must, however, be a final decision. If we say "True" for 'f', +-- and then subsequently decide /not/ make 'f' into a join point, then +-- the decision about another binding 'g' might be invalidated if (say) +-- 'f' tail-calls 'g'. +-- +-- See Note [Invariants on join points] in CoreSyn. +decideJoinPointHood :: TopLevelFlag -> UsageDetails + -> [CoreBndr] + -> Bool +decideJoinPointHood TopLevel _ _ + = False +decideJoinPointHood NotTopLevel usage bndrs + | isJoinId (head bndrs) + = WARN(not all_ok, text "OccurAnal failed to rediscover join point(s):" <+> + ppr bndrs) + all_ok + | otherwise + = all_ok + where + -- See Note [Invariants on join points]; invariants cited by number below. + -- Invariant 2 is always satisfiable by the simplifier by eta expansion. + all_ok = -- Invariant 3: Either all are join points or none are + all ok bndrs + + ok bndr + | -- Invariant 1: Only tail calls, all same join arity + AlwaysTailCalled arity <- tailCallInfo (lookupDetails usage bndr) + + , -- Invariant 1 as applied to LHSes of rules + all (ok_rule arity) (idCoreRules bndr) + + -- Invariant 2a: stable unfoldings + -- See Note [Join points and INLINE pragmas] + , ok_unfolding arity (realIdUnfolding bndr) + + -- Invariant 4: Satisfies polymorphism rule + , isValidJoinPointType arity (idType bndr) + = True + + | otherwise + = False + + ok_rule _ BuiltinRule{} = False -- only possible with plugin shenanigans + ok_rule join_arity (Rule { ru_args = args }) + = args `lengthIs` join_arity + -- Invariant 1 as applied to LHSes of rules + + -- ok_unfolding returns False if we should /not/ convert a non-join-id + -- into a join-id, even though it is AlwaysTailCalled + ok_unfolding join_arity (CoreUnfolding { uf_src = src, uf_tmpl = rhs }) + = not (isStableSource src && join_arity > joinRhsArity rhs) + ok_unfolding _ (DFunUnfolding {}) + = False + ok_unfolding _ _ + = True + +willBeJoinId_maybe :: CoreBndr -> Maybe JoinArity +willBeJoinId_maybe bndr + = case tailCallInfo (idOccInfo bndr) of + AlwaysTailCalled arity -> Just arity + _ -> isJoinId_maybe bndr + + +{- Note [Join points and INLINE pragmas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f x = let g = \x. not -- Arity 1 + {-# INLINE g #-} + in case x of + A -> g True True + B -> g True False + C -> blah2 + +Here 'g' is always tail-called applied to 2 args, but the stable +unfolding captured by the INLINE pragma has arity 1. If we try to +convert g to be a join point, its unfolding will still have arity 1 +(since it is stable, and we don't meddle with stable unfoldings), and +Lint will complain (see Note [Invariants on join points], (2a), in +CoreSyn. #13413. + +Moreover, since g is going to be inlined anyway, there is no benefit +from making it a join point. + +If it is recursive, and uselessly marked INLINE, this will stop us +making it a join point, which is annoying. But occasionally +(notably in class methods; see Note [Instances and loop breakers] in +TcInstDcls) we mark recursive things as INLINE but the recursion +unravels; so ignoring INLINE pragmas on recursive things isn't good +either. + +See Invariant 2a of Note [Invariants on join points] in CoreSyn + + +************************************************************************ +* * +\subsection{Operations over OccInfo} +* * +************************************************************************ +-} + +markMany, markInsideLam, markNonTailCalled :: OccInfo -> OccInfo + +markMany IAmDead = IAmDead +markMany occ = ManyOccs { occ_tail = occ_tail occ } + +markInsideLam occ@(OneOcc {}) = occ { occ_in_lam = True } +markInsideLam occ = occ + +markNonTailCalled IAmDead = IAmDead +markNonTailCalled occ = occ { occ_tail = NoTailCallInfo } + +addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo + +addOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) ) + ManyOccs { occ_tail = tailCallInfo a1 `andTailCallInfo` + tailCallInfo a2 } + -- Both branches are at least One + -- (Argument is never IAmDead) + +-- (orOccInfo orig new) is used +-- when combining occurrence info from branches of a case + +orOccInfo (OneOcc { occ_in_lam = in_lam1, occ_int_cxt = int_cxt1 + , occ_tail = tail1 }) + (OneOcc { occ_in_lam = in_lam2, occ_int_cxt = int_cxt2 + , occ_tail = tail2 }) + = OneOcc { occ_one_br = False -- False, because it occurs in both branches + , occ_in_lam = in_lam1 || in_lam2 + , occ_int_cxt = int_cxt1 && int_cxt2 + , occ_tail = tail1 `andTailCallInfo` tail2 } + +orOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) ) + ManyOccs { occ_tail = tailCallInfo a1 `andTailCallInfo` + tailCallInfo a2 } + +andTailCallInfo :: TailCallInfo -> TailCallInfo -> TailCallInfo +andTailCallInfo info@(AlwaysTailCalled arity1) (AlwaysTailCalled arity2) + | arity1 == arity2 = info +andTailCallInfo _ _ = NoTailCallInfo diff --git a/compiler/simplStg/RepType.hs b/compiler/simplStg/RepType.hs new file mode 100644 --- /dev/null +++ b/compiler/simplStg/RepType.hs @@ -0,0 +1,370 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} + +module RepType + ( + -- * Code generator views onto Types + UnaryType, NvUnaryType, isNvUnaryType, + unwrapType, + + -- * Predicates on types + isVoidTy, + + -- * Type representation for the code generator + typePrimRep, typePrimRep1, + runtimeRepPrimRep, typePrimRepArgs, + PrimRep(..), primRepToType, + countFunRepArgs, countConRepArgs, tyConPrimRep, tyConPrimRep1, + + -- * Unboxed sum representation type + ubxSumRepType, layoutUbxSum, typeSlotTy, SlotTy (..), + slotPrimRep, primRepSlot + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import BasicTypes (Arity, RepArity) +import DataCon +import Outputable +import PrelNames +import Coercion +import TyCon +import TyCoRep +import Type +import Util +import TysPrim +import {-# SOURCE #-} TysWiredIn ( anyTypeOfKind ) + +import Data.List (sort) +import qualified Data.IntSet as IS + +{- ********************************************************************** +* * + Representation types +* * +********************************************************************** -} + +type NvUnaryType = Type +type UnaryType = Type + -- Both are always a value type; i.e. its kind is TYPE rr + -- for some rr; moreover the rr is never a variable. + -- + -- NvUnaryType : never an unboxed tuple or sum, or void + -- + -- UnaryType : never an unboxed tuple or sum; + -- can be Void# or (# #) + +isNvUnaryType :: Type -> Bool +isNvUnaryType ty + | [_] <- typePrimRep ty + = True + | otherwise + = False + +-- INVARIANT: the result list is never empty. +typePrimRepArgs :: Type -> [PrimRep] +typePrimRepArgs ty + | [] <- reps + = [VoidRep] + | otherwise + = reps + where + reps = typePrimRep ty + +-- | Gets rid of the stuff that prevents us from understanding the +-- runtime representation of a type. Including: +-- 1. Casts +-- 2. Newtypes +-- 3. Foralls +-- 4. Synonyms +-- But not type/data families, because we don't have the envs to hand. +unwrapType :: Type -> Type +unwrapType ty + | Just (_, unwrapped) + <- topNormaliseTypeX stepper mappend inner_ty + = unwrapped + | otherwise + = inner_ty + where + inner_ty = go ty + + go t | Just t' <- coreView t = go t' + go (ForAllTy _ t) = go t + go (CastTy t _) = go t + go t = t + + -- cf. Coercion.unwrapNewTypeStepper + stepper rec_nts tc tys + | Just (ty', _) <- instNewTyCon_maybe tc tys + = case checkRecTc rec_nts tc of + Just rec_nts' -> NS_Step rec_nts' (go ty') () + Nothing -> NS_Abort -- infinite newtypes + | otherwise + = NS_Done + +countFunRepArgs :: Arity -> Type -> RepArity +countFunRepArgs 0 _ + = 0 +countFunRepArgs n ty + | FunTy _ arg res <- unwrapType ty + = length (typePrimRepArgs arg) + countFunRepArgs (n - 1) res + | otherwise + = pprPanic "countFunRepArgs: arity greater than type can handle" (ppr (n, ty, typePrimRep ty)) + +countConRepArgs :: DataCon -> RepArity +countConRepArgs dc = go (dataConRepArity dc) (dataConRepType dc) + where + go :: Arity -> Type -> RepArity + go 0 _ + = 0 + go n ty + | FunTy _ arg res <- unwrapType ty + = length (typePrimRep arg) + go (n - 1) res + | otherwise + = pprPanic "countConRepArgs: arity greater than type can handle" (ppr (n, ty, typePrimRep ty)) + +-- | True if the type has zero width. +isVoidTy :: Type -> Bool +isVoidTy = null . typePrimRep + + +{- ********************************************************************** +* * + Unboxed sums + See Note [Translating unboxed sums to unboxed tuples] in UnariseStg.hs +* * +********************************************************************** -} + +type SortedSlotTys = [SlotTy] + +-- | Given the arguments of a sum type constructor application, +-- return the unboxed sum rep type. +-- +-- E.g. +-- +-- (# Int# | Maybe Int | (# Int#, Float# #) #) +-- +-- We call `ubxSumRepType [ [IntRep], [LiftedRep], [IntRep, FloatRep] ]`, +-- which returns [WordSlot, PtrSlot, WordSlot, FloatSlot] +-- +-- INVARIANT: Result slots are sorted (via Ord SlotTy), except that at the head +-- of the list we have the slot for the tag. +ubxSumRepType :: [[PrimRep]] -> [SlotTy] +ubxSumRepType constrs0 + -- These first two cases never classify an actual unboxed sum, which always + -- has at least two disjuncts. But it could happen if a user writes, e.g., + -- forall (a :: TYPE (SumRep [IntRep])). ... + -- which could never be instantiated. We still don't want to panic. + | constrs0 `lengthLessThan` 2 + = [WordSlot] + + | otherwise + = let + combine_alts :: [SortedSlotTys] -- slots of constructors + -> SortedSlotTys -- final slots + combine_alts constrs = foldl' merge [] constrs + + merge :: SortedSlotTys -> SortedSlotTys -> SortedSlotTys + merge existing_slots [] + = existing_slots + merge [] needed_slots + = needed_slots + merge (es : ess) (s : ss) + | Just s' <- s `fitsIn` es + = -- found a slot, use it + s' : merge ess ss + | s < es + = -- we need a new slot and this is the right place for it + s : merge (es : ess) ss + | otherwise + = -- keep searching for a slot + es : merge ess (s : ss) + + -- Nesting unboxed tuples and sums is OK, so we need to flatten first. + rep :: [PrimRep] -> SortedSlotTys + rep ty = sort (map primRepSlot ty) + + sumRep = WordSlot : combine_alts (map rep constrs0) + -- WordSlot: for the tag of the sum + in + sumRep + +layoutUbxSum :: SortedSlotTys -- Layout of sum. Does not include tag. + -- We assume that they are in increasing order + -> [SlotTy] -- Slot types of things we want to map to locations in the + -- sum layout + -> [Int] -- Where to map 'things' in the sum layout +layoutUbxSum sum_slots0 arg_slots0 = + go arg_slots0 IS.empty + where + go :: [SlotTy] -> IS.IntSet -> [Int] + go [] _ + = [] + go (arg : args) used + = let slot_idx = findSlot arg 0 sum_slots0 used + in slot_idx : go args (IS.insert slot_idx used) + + findSlot :: SlotTy -> Int -> SortedSlotTys -> IS.IntSet -> Int + findSlot arg slot_idx (slot : slots) useds + | not (IS.member slot_idx useds) + , Just slot == arg `fitsIn` slot + = slot_idx + | otherwise + = findSlot arg (slot_idx + 1) slots useds + findSlot _ _ [] _ + = pprPanic "findSlot" (text "Can't find slot" $$ ppr sum_slots0 $$ ppr arg_slots0) + +-------------------------------------------------------------------------------- + +-- We have 3 kinds of slots: +-- +-- - Pointer slot: Only shared between actual pointers to Haskell heap (i.e. +-- boxed objects) +-- +-- - Word slots: Shared between IntRep, WordRep, Int64Rep, Word64Rep, AddrRep. +-- +-- - Float slots: Shared between floating point types. +-- +-- - Void slots: Shared between void types. Not used in sums. +-- +-- TODO(michalt): We should probably introduce `SlotTy`s for 8-/16-/32-bit +-- values, so that we can pack things more tightly. +data SlotTy = PtrSlot | WordSlot | Word64Slot | FloatSlot | DoubleSlot + deriving (Eq, Ord) + -- Constructor order is important! If slot A could fit into slot B + -- then slot A must occur first. E.g. FloatSlot before DoubleSlot + -- + -- We are assuming that WordSlot is smaller than or equal to Word64Slot + -- (would not be true on a 128-bit machine) + +instance Outputable SlotTy where + ppr PtrSlot = text "PtrSlot" + ppr Word64Slot = text "Word64Slot" + ppr WordSlot = text "WordSlot" + ppr DoubleSlot = text "DoubleSlot" + ppr FloatSlot = text "FloatSlot" + +typeSlotTy :: UnaryType -> Maybe SlotTy +typeSlotTy ty + | isVoidTy ty + = Nothing + | otherwise + = Just (primRepSlot (typePrimRep1 ty)) + +primRepSlot :: PrimRep -> SlotTy +primRepSlot VoidRep = pprPanic "primRepSlot" (text "No slot for VoidRep") +primRepSlot LiftedRep = PtrSlot +primRepSlot UnliftedRep = PtrSlot +primRepSlot IntRep = WordSlot +primRepSlot Int8Rep = WordSlot +primRepSlot Int16Rep = WordSlot +primRepSlot Int64Rep = Word64Slot +primRepSlot WordRep = WordSlot +primRepSlot Word8Rep = WordSlot +primRepSlot Word16Rep = WordSlot +primRepSlot Word64Rep = Word64Slot +primRepSlot AddrRep = WordSlot +primRepSlot FloatRep = FloatSlot +primRepSlot DoubleRep = DoubleSlot +primRepSlot VecRep{} = pprPanic "primRepSlot" (text "No slot for VecRep") + +slotPrimRep :: SlotTy -> PrimRep +slotPrimRep PtrSlot = LiftedRep -- choice between lifted & unlifted seems arbitrary +slotPrimRep Word64Slot = Word64Rep +slotPrimRep WordSlot = WordRep +slotPrimRep DoubleSlot = DoubleRep +slotPrimRep FloatSlot = FloatRep + +-- | Returns the bigger type if one fits into the other. (commutative) +fitsIn :: SlotTy -> SlotTy -> Maybe SlotTy +fitsIn ty1 ty2 + | isWordSlot ty1 && isWordSlot ty2 + = Just (max ty1 ty2) + | isFloatSlot ty1 && isFloatSlot ty2 + = Just (max ty1 ty2) + | isPtrSlot ty1 && isPtrSlot ty2 + = Just PtrSlot + | otherwise + = Nothing + where + isPtrSlot PtrSlot = True + isPtrSlot _ = False + + isWordSlot Word64Slot = True + isWordSlot WordSlot = True + isWordSlot _ = False + + isFloatSlot DoubleSlot = True + isFloatSlot FloatSlot = True + isFloatSlot _ = False + + +{- ********************************************************************** +* * + PrimRep +* * +********************************************************************** -} + +-- | Discovers the primitive representation of a 'Type'. Returns +-- a list of 'PrimRep': it's a list because of the possibility of +-- no runtime representation (void) or multiple (unboxed tuple/sum) +typePrimRep :: HasDebugCallStack => Type -> [PrimRep] +typePrimRep ty = kindPrimRep (text "typePrimRep" <+> + parens (ppr ty <+> dcolon <+> ppr (typeKind ty))) + (typeKind ty) + +-- | Like 'typePrimRep', but assumes that there is precisely one 'PrimRep' output; +-- an empty list of PrimReps becomes a VoidRep +typePrimRep1 :: HasDebugCallStack => UnaryType -> PrimRep +typePrimRep1 ty = case typePrimRep ty of + [] -> VoidRep + [rep] -> rep + _ -> pprPanic "typePrimRep1" (ppr ty $$ ppr (typePrimRep ty)) + +-- | Find the runtime representation of a 'TyCon'. Defined here to +-- avoid module loops. Returns a list of the register shapes necessary. +tyConPrimRep :: HasDebugCallStack => TyCon -> [PrimRep] +tyConPrimRep tc + = kindPrimRep (text "kindRep tc" <+> ppr tc $$ ppr res_kind) + res_kind + where + res_kind = tyConResKind tc + +-- | Like 'tyConPrimRep', but assumed that there is precisely zero or +-- one 'PrimRep' output +tyConPrimRep1 :: HasDebugCallStack => TyCon -> PrimRep +tyConPrimRep1 tc = case tyConPrimRep tc of + [] -> VoidRep + [rep] -> rep + _ -> pprPanic "tyConPrimRep1" (ppr tc $$ ppr (tyConPrimRep tc)) + +-- | Take a kind (of shape @TYPE rr@) and produce the 'PrimRep's +-- of values of types of this kind. +kindPrimRep :: HasDebugCallStack => SDoc -> Kind -> [PrimRep] +kindPrimRep doc ki + | Just ki' <- coreView ki + = kindPrimRep doc ki' +kindPrimRep doc (TyConApp typ [runtime_rep]) + = ASSERT( typ `hasKey` tYPETyConKey ) + runtimeRepPrimRep doc runtime_rep +kindPrimRep doc ki + = pprPanic "kindPrimRep" (ppr ki $$ doc) + +-- | Take a type of kind RuntimeRep and extract the list of 'PrimRep' that +-- it encodes. +runtimeRepPrimRep :: HasDebugCallStack => SDoc -> Type -> [PrimRep] +runtimeRepPrimRep doc rr_ty + | Just rr_ty' <- coreView rr_ty + = runtimeRepPrimRep doc rr_ty' + | TyConApp rr_dc args <- rr_ty + , RuntimeRep fun <- tyConRuntimeRepInfo rr_dc + = fun args + | otherwise + = pprPanic "runtimeRepPrimRep" (doc $$ ppr rr_ty) + +-- | Convert a PrimRep back to a Type. Used only in the unariser to give types +-- to fresh Ids. Really, only the type's representation matters. +primRepToType :: PrimRep -> Type +primRepToType = anyTypeOfKind . tYPE . primRepToRuntimeRep diff --git a/compiler/specialise/Rules.hs b/compiler/specialise/Rules.hs new file mode 100644 --- /dev/null +++ b/compiler/specialise/Rules.hs @@ -0,0 +1,1280 @@ +{- +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[CoreRules]{Transformation rules} +-} + +{-# LANGUAGE CPP #-} + +-- | Functions for collecting together and applying rewrite rules to a module. +-- The 'CoreRule' datatype itself is declared elsewhere. +module Rules ( + -- ** Constructing + emptyRuleBase, mkRuleBase, extendRuleBaseList, + unionRuleBase, pprRuleBase, + + -- ** Checking rule applications + ruleCheckProgram, + + -- ** Manipulating 'RuleInfo' rules + mkRuleInfo, extendRuleInfo, addRuleInfo, + addIdSpecialisations, + + -- * Misc. CoreRule helpers + rulesOfBinds, getRules, pprRulesForUser, + + lookupRule, mkRule, roughTopNames + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import CoreSyn -- All of it +import Module ( Module, ModuleSet, elemModuleSet ) +import CoreSubst +import CoreOpt ( exprIsLambda_maybe ) +import CoreFVs ( exprFreeVars, exprsFreeVars, bindFreeVars + , rulesFreeVarsDSet, exprsOrphNames, exprFreeVarsList ) +import CoreUtils ( exprType, eqExpr, mkTick, mkTicks, + stripTicksTopT, stripTicksTopE, + isJoinBind ) +import PprCore ( pprRules ) +import Type ( Type, Kind, substTy, mkTCvSubst ) +import TcType ( tcSplitTyConApp_maybe ) +import TysWiredIn ( anyTypeOfKind ) +import Coercion +import CoreTidy ( tidyRules ) +import Id +import IdInfo ( RuleInfo( RuleInfo ) ) +import Var +import VarEnv +import VarSet +import Name ( Name, NamedThing(..), nameIsLocalOrFrom ) +import NameSet +import NameEnv +import UniqFM +import Unify ( ruleMatchTyKiX ) +import BasicTypes +import DynFlags ( DynFlags ) +import Outputable +import FastString +import Maybes +import Bag +import Util +import Data.List +import Data.Ord +import Control.Monad ( guard ) + +{- +Note [Overall plumbing for rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* After the desugarer: + - The ModGuts initially contains mg_rules :: [CoreRule] of + locally-declared rules for imported Ids. + - Locally-declared rules for locally-declared Ids are attached to + the IdInfo for that Id. See Note [Attach rules to local ids] in + DsBinds + +* TidyPgm strips off all the rules from local Ids and adds them to + mg_rules, so that the ModGuts has *all* the locally-declared rules. + +* The HomePackageTable contains a ModDetails for each home package + module. Each contains md_rules :: [CoreRule] of rules declared in + that module. The HomePackageTable grows as ghc --make does its + up-sweep. In batch mode (ghc -c), the HPT is empty; all imported modules + are treated by the "external" route, discussed next, regardless of + which package they come from. + +* The ExternalPackageState has a single eps_rule_base :: RuleBase for + Ids in other packages. This RuleBase simply grow monotonically, as + ghc --make compiles one module after another. + + During simplification, interface files may get demand-loaded, + as the simplifier explores the unfoldings for Ids it has in + its hand. (Via an unsafePerformIO; the EPS is really a cache.) + That in turn may make the EPS rule-base grow. In contrast, the + HPT never grows in this way. + +* The result of all this is that during Core-to-Core optimisation + there are four sources of rules: + + (a) Rules in the IdInfo of the Id they are a rule for. These are + easy: fast to look up, and if you apply a substitution then + it'll be applied to the IdInfo as a matter of course. + + (b) Rules declared in this module for imported Ids, kept in the + ModGuts. If you do a substitution, you'd better apply the + substitution to these. There are seldom many of these. + + (c) Rules declared in the HomePackageTable. These never change. + + (d) Rules in the ExternalPackageTable. These can grow in response + to lazy demand-loading of interfaces. + +* At the moment (c) is carried in a reader-monad way by the CoreMonad. + The HomePackageTable doesn't have a single RuleBase because technically + we should only be able to "see" rules "below" this module; so we + generate a RuleBase for (c) by combing rules from all the modules + "below" us. That's why we can't just select the home-package RuleBase + from HscEnv. + + [NB: we are inconsistent here. We should do the same for external + packages, but we don't. Same for type-class instances.] + +* So in the outer simplifier loop, we combine (b-d) into a single + RuleBase, reading + (b) from the ModGuts, + (c) from the CoreMonad, and + (d) from its mutable variable + [Of coures this means that we won't see new EPS rules that come in + during a single simplifier iteration, but that probably does not + matter.] + + +************************************************************************ +* * +\subsection[specialisation-IdInfo]{Specialisation info about an @Id@} +* * +************************************************************************ + +A @CoreRule@ holds details of one rule for an @Id@, which +includes its specialisations. + +For example, if a rule for @f@ contains the mapping: +\begin{verbatim} + forall a b d. [Type (List a), Type b, Var d] ===> f' a b +\end{verbatim} +then when we find an application of f to matching types, we simply replace +it by the matching RHS: +\begin{verbatim} + f (List Int) Bool dict ===> f' Int Bool +\end{verbatim} +All the stuff about how many dictionaries to discard, and what types +to apply the specialised function to, are handled by the fact that the +Rule contains a template for the result of the specialisation. + +There is one more exciting case, which is dealt with in exactly the same +way. If the specialised value is unboxed then it is lifted at its +definition site and unlifted at its uses. For example: + + pi :: forall a. Num a => a + +might have a specialisation + + [Int#] ===> (case pi' of Lift pi# -> pi#) + +where pi' :: Lift Int# is the specialised version of pi. +-} + +mkRule :: Module -> Bool -> Bool -> RuleName -> Activation + -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule +-- ^ Used to make 'CoreRule' for an 'Id' defined in the module being +-- compiled. See also 'CoreSyn.CoreRule' +mkRule this_mod is_auto is_local name act fn bndrs args rhs + = Rule { ru_name = name, ru_fn = fn, ru_act = act, + ru_bndrs = bndrs, ru_args = args, + ru_rhs = rhs, + ru_rough = roughTopNames args, + ru_origin = this_mod, + ru_orphan = orph, + ru_auto = is_auto, ru_local = is_local } + where + -- Compute orphanhood. See Note [Orphans] in InstEnv + -- A rule is an orphan only if none of the variables + -- mentioned on its left-hand side are locally defined + lhs_names = extendNameSet (exprsOrphNames args) fn + + -- Since rules get eventually attached to one of the free names + -- from the definition when compiling the ABI hash, we should make + -- it deterministic. This chooses the one with minimal OccName + -- as opposed to uniq value. + local_lhs_names = filterNameSet (nameIsLocalOrFrom this_mod) lhs_names + orph = chooseOrphanAnchor local_lhs_names + +-------------- +roughTopNames :: [CoreExpr] -> [Maybe Name] +-- ^ Find the \"top\" free names of several expressions. +-- Such names are either: +-- +-- 1. The function finally being applied to in an application chain +-- (if that name is a GlobalId: see "Var#globalvslocal"), or +-- +-- 2. The 'TyCon' if the expression is a 'Type' +-- +-- This is used for the fast-match-check for rules; +-- if the top names don't match, the rest can't +roughTopNames args = map roughTopName args + +roughTopName :: CoreExpr -> Maybe Name +roughTopName (Type ty) = case tcSplitTyConApp_maybe ty of + Just (tc,_) -> Just (getName tc) + Nothing -> Nothing +roughTopName (Coercion _) = Nothing +roughTopName (App f _) = roughTopName f +roughTopName (Var f) | isGlobalId f -- Note [Care with roughTopName] + , isDataConWorkId f || idArity f > 0 + = Just (idName f) +roughTopName (Tick t e) | tickishFloatable t + = roughTopName e +roughTopName _ = Nothing + +ruleCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool +-- ^ @ruleCantMatch tpl actual@ returns True only if @actual@ +-- definitely can't match @tpl@ by instantiating @tpl@. +-- It's only a one-way match; unlike instance matching we +-- don't consider unification. +-- +-- Notice that [_$_] +-- @ruleCantMatch [Nothing] [Just n2] = False@ +-- Reason: a template variable can be instantiated by a constant +-- Also: +-- @ruleCantMatch [Just n1] [Nothing] = False@ +-- Reason: a local variable @v@ in the actuals might [_$_] + +ruleCantMatch (Just n1 : ts) (Just n2 : as) = n1 /= n2 || ruleCantMatch ts as +ruleCantMatch (_ : ts) (_ : as) = ruleCantMatch ts as +ruleCantMatch _ _ = False + +{- +Note [Care with roughTopName] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + module M where { x = a:b } + module N where { ...f x... + RULE f (p:q) = ... } +You'd expect the rule to match, because the matcher can +look through the unfolding of 'x'. So we must avoid roughTopName +returning 'M.x' for the call (f x), or else it'll say "can't match" +and we won't even try!! + +However, suppose we have + RULE g (M.h x) = ... + foo = ...(g (M.k v)).... +where k is a *function* exported by M. We never really match +functions (lambdas) except by name, so in this case it seems like +a good idea to treat 'M.k' as a roughTopName of the call. +-} + +pprRulesForUser :: DynFlags -> [CoreRule] -> SDoc +-- (a) tidy the rules +-- (b) sort them into order based on the rule name +-- (c) suppress uniques (unless -dppr-debug is on) +-- This combination makes the output stable so we can use in testing +-- It's here rather than in PprCore because it calls tidyRules +pprRulesForUser dflags rules + = withPprStyle (defaultUserStyle dflags) $ + pprRules $ + sortBy (comparing ruleName) $ + tidyRules emptyTidyEnv rules + +{- +************************************************************************ +* * + RuleInfo: the rules in an IdInfo +* * +************************************************************************ +-} + +-- | Make a 'RuleInfo' containing a number of 'CoreRule's, suitable +-- for putting into an 'IdInfo' +mkRuleInfo :: [CoreRule] -> RuleInfo +mkRuleInfo rules = RuleInfo rules (rulesFreeVarsDSet rules) + +extendRuleInfo :: RuleInfo -> [CoreRule] -> RuleInfo +extendRuleInfo (RuleInfo rs1 fvs1) rs2 + = RuleInfo (rs2 ++ rs1) (rulesFreeVarsDSet rs2 `unionDVarSet` fvs1) + +addRuleInfo :: RuleInfo -> RuleInfo -> RuleInfo +addRuleInfo (RuleInfo rs1 fvs1) (RuleInfo rs2 fvs2) + = RuleInfo (rs1 ++ rs2) (fvs1 `unionDVarSet` fvs2) + +addIdSpecialisations :: Id -> [CoreRule] -> Id +addIdSpecialisations id rules + | null rules + = id + | otherwise + = setIdSpecialisation id $ + extendRuleInfo (idSpecialisation id) rules + +-- | Gather all the rules for locally bound identifiers from the supplied bindings +rulesOfBinds :: [CoreBind] -> [CoreRule] +rulesOfBinds binds = concatMap (concatMap idCoreRules . bindersOf) binds + +getRules :: RuleEnv -> Id -> [CoreRule] +-- See Note [Where rules are found] +getRules (RuleEnv { re_base = rule_base, re_visible_orphs = orphs }) fn + = idCoreRules fn ++ filter (ruleIsVisible orphs) imp_rules + where + imp_rules = lookupNameEnv rule_base (idName fn) `orElse` [] + +ruleIsVisible :: ModuleSet -> CoreRule -> Bool +ruleIsVisible _ BuiltinRule{} = True +ruleIsVisible vis_orphs Rule { ru_orphan = orph, ru_origin = origin } + = notOrphan orph || origin `elemModuleSet` vis_orphs + +{- Note [Where rules are found] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The rules for an Id come from two places: + (a) the ones it is born with, stored inside the Id iself (idCoreRules fn), + (b) rules added in other modules, stored in the global RuleBase (imp_rules) + +It's tempting to think that + - LocalIds have only (a) + - non-LocalIds have only (b) + +but that isn't quite right: + + - PrimOps and ClassOps are born with a bunch of rules inside the Id, + even when they are imported + + - The rules in PrelRules.builtinRules should be active even + in the module defining the Id (when it's a LocalId), but + the rules are kept in the global RuleBase + + +************************************************************************ +* * + RuleBase +* * +************************************************************************ +-} + +-- RuleBase itself is defined in CoreSyn, along with CoreRule + +emptyRuleBase :: RuleBase +emptyRuleBase = emptyNameEnv + +mkRuleBase :: [CoreRule] -> RuleBase +mkRuleBase rules = extendRuleBaseList emptyRuleBase rules + +extendRuleBaseList :: RuleBase -> [CoreRule] -> RuleBase +extendRuleBaseList rule_base new_guys + = foldl' extendRuleBase rule_base new_guys + +unionRuleBase :: RuleBase -> RuleBase -> RuleBase +unionRuleBase rb1 rb2 = plusNameEnv_C (++) rb1 rb2 + +extendRuleBase :: RuleBase -> CoreRule -> RuleBase +extendRuleBase rule_base rule + = extendNameEnv_Acc (:) singleton rule_base (ruleIdName rule) rule + +pprRuleBase :: RuleBase -> SDoc +pprRuleBase rules = pprUFM rules $ \rss -> + vcat [ pprRules (tidyRules emptyTidyEnv rs) + | rs <- rss ] + +{- +************************************************************************ +* * + Matching +* * +************************************************************************ +-} + +-- | The main rule matching function. Attempts to apply all (active) +-- supplied rules to this instance of an application in a given +-- context, returning the rule applied and the resulting expression if +-- successful. +lookupRule :: DynFlags -> InScopeEnv + -> (Activation -> Bool) -- When rule is active + -> Id -> [CoreExpr] + -> [CoreRule] -> Maybe (CoreRule, CoreExpr) + +-- See Note [Extra args in rule matching] +-- See comments on matchRule +lookupRule dflags in_scope is_active fn args rules + = -- pprTrace "matchRules" (ppr fn <+> ppr args $$ ppr rules ) $ + case go [] rules of + [] -> Nothing + (m:ms) -> Just (findBest (fn,args') m ms) + where + rough_args = map roughTopName args + + -- Strip ticks from arguments, see note [Tick annotations in RULE + -- matching]. We only collect ticks if a rule actually matches - + -- this matters for performance tests. + args' = map (stripTicksTopE tickishFloatable) args + ticks = concatMap (stripTicksTopT tickishFloatable) args + + go :: [(CoreRule,CoreExpr)] -> [CoreRule] -> [(CoreRule,CoreExpr)] + go ms [] = ms + go ms (r:rs) + | Just e <- matchRule dflags in_scope is_active fn args' rough_args r + = go ((r,mkTicks ticks e):ms) rs + | otherwise + = -- pprTrace "match failed" (ppr r $$ ppr args $$ + -- ppr [ (arg_id, unfoldingTemplate unf) + -- | Var arg_id <- args + -- , let unf = idUnfolding arg_id + -- , isCheapUnfolding unf] ) + go ms rs + +findBest :: (Id, [CoreExpr]) + -> (CoreRule,CoreExpr) -> [(CoreRule,CoreExpr)] -> (CoreRule,CoreExpr) +-- All these pairs matched the expression +-- Return the pair the most specific rule +-- The (fn,args) is just for overlap reporting + +findBest _ (rule,ans) [] = (rule,ans) +findBest target (rule1,ans1) ((rule2,ans2):prs) + | rule1 `isMoreSpecific` rule2 = findBest target (rule1,ans1) prs + | rule2 `isMoreSpecific` rule1 = findBest target (rule2,ans2) prs + | debugIsOn = let pp_rule rule + = ifPprDebug (ppr rule) + (doubleQuotes (ftext (ruleName rule))) + in pprTrace "Rules.findBest: rule overlap (Rule 1 wins)" + (vcat [ whenPprDebug $ + text "Expression to match:" <+> ppr fn + <+> sep (map ppr args) + , text "Rule 1:" <+> pp_rule rule1 + , text "Rule 2:" <+> pp_rule rule2]) $ + findBest target (rule1,ans1) prs + | otherwise = findBest target (rule1,ans1) prs + where + (fn,args) = target + +isMoreSpecific :: CoreRule -> CoreRule -> Bool +-- This tests if one rule is more specific than another +-- We take the view that a BuiltinRule is less specific than +-- anything else, because we want user-define rules to "win" +-- In particular, class ops have a built-in rule, but we +-- any user-specific rules to win +-- eg (#4397) +-- truncate :: (RealFrac a, Integral b) => a -> b +-- {-# RULES "truncate/Double->Int" truncate = double2Int #-} +-- double2Int :: Double -> Int +-- We want the specific RULE to beat the built-in class-op rule +isMoreSpecific (BuiltinRule {}) _ = False +isMoreSpecific (Rule {}) (BuiltinRule {}) = True +isMoreSpecific (Rule { ru_bndrs = bndrs1, ru_args = args1 }) + (Rule { ru_bndrs = bndrs2, ru_args = args2, ru_name = rule_name2 }) + = isJust (matchN (in_scope, id_unfolding_fun) rule_name2 bndrs2 args2 args1) + where + id_unfolding_fun _ = NoUnfolding -- Don't expand in templates + in_scope = mkInScopeSet (mkVarSet bndrs1) + -- Actually we should probably include the free vars + -- of rule1's args, but I can't be bothered + +noBlackList :: Activation -> Bool +noBlackList _ = False -- Nothing is black listed + +{- +Note [Extra args in rule matching] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we find a matching rule, we return (Just (rule, rhs)), +but the rule firing has only consumed as many of the input args +as the ruleArity says. It's up to the caller to keep track +of any left-over args. E.g. if you call + lookupRule ... f [e1, e2, e3] +and it returns Just (r, rhs), where r has ruleArity 2 +then the real rewrite is + f e1 e2 e3 ==> rhs e3 + +You might think it'd be cleaner for lookupRule to deal with the +leftover arguments, by applying 'rhs' to them, but the main call +in the Simplifier works better as it is. Reason: the 'args' passed +to lookupRule are the result of a lazy substitution +-} + +------------------------------------ +matchRule :: DynFlags -> InScopeEnv -> (Activation -> Bool) + -> Id -> [CoreExpr] -> [Maybe Name] + -> CoreRule -> Maybe CoreExpr + +-- If (matchRule rule args) returns Just (name,rhs) +-- then (f args) matches the rule, and the corresponding +-- rewritten RHS is rhs +-- +-- The returned expression is occurrence-analysed +-- +-- Example +-- +-- The rule +-- forall f g x. map f (map g x) ==> map (f . g) x +-- is stored +-- CoreRule "map/map" +-- [f,g,x] -- tpl_vars +-- [f,map g x] -- tpl_args +-- map (f.g) x) -- rhs +-- +-- Then the call: matchRule the_rule [e1,map e2 e3] +-- = Just ("map/map", (\f,g,x -> rhs) e1 e2 e3) +-- +-- Any 'surplus' arguments in the input are simply put on the end +-- of the output. + +matchRule dflags rule_env _is_active fn args _rough_args + (BuiltinRule { ru_try = match_fn }) +-- Built-in rules can't be switched off, it seems + = case match_fn dflags rule_env fn args of + Nothing -> Nothing + Just expr -> Just expr + +matchRule _ in_scope is_active _ args rough_args + (Rule { ru_name = rule_name, ru_act = act, ru_rough = tpl_tops + , ru_bndrs = tpl_vars, ru_args = tpl_args, ru_rhs = rhs }) + | not (is_active act) = Nothing + | ruleCantMatch tpl_tops rough_args = Nothing + | otherwise + = case matchN in_scope rule_name tpl_vars tpl_args args of + Nothing -> Nothing + Just (bind_wrapper, tpl_vals) -> Just (bind_wrapper $ + rule_fn `mkApps` tpl_vals) + where + rule_fn = mkLams tpl_vars rhs + +--------------------------------------- +matchN :: InScopeEnv + -> RuleName -> [Var] -> [CoreExpr] + -> [CoreExpr] -- ^ Target; can have more elements than the template + -> Maybe (BindWrapper, -- Floated bindings; see Note [Matching lets] + [CoreExpr]) +-- For a given match template and context, find bindings to wrap around +-- the entire result and what should be substituted for each template variable. +-- Fail if there are two few actual arguments from the target to match the template + +matchN (in_scope, id_unf) rule_name tmpl_vars tmpl_es target_es + = do { subst <- go init_menv emptyRuleSubst tmpl_es target_es + ; let (_, matched_es) = mapAccumL lookup_tmpl subst $ + tmpl_vars `zip` tmpl_vars1 + ; return (rs_binds subst, matched_es) } + where + (init_rn_env, tmpl_vars1) = mapAccumL rnBndrL (mkRnEnv2 in_scope) tmpl_vars + -- See Note [Cloning the template binders] + + init_menv = RV { rv_tmpls = mkVarSet tmpl_vars1 + , rv_lcl = init_rn_env + , rv_fltR = mkEmptySubst (rnInScopeSet init_rn_env) + , rv_unf = id_unf } + + go _ subst [] _ = Just subst + go _ _ _ [] = Nothing -- Fail if too few actual args + go menv subst (t:ts) (e:es) = do { subst1 <- match menv subst t e + ; go menv subst1 ts es } + + lookup_tmpl :: RuleSubst -> (InVar,OutVar) -> (RuleSubst, CoreExpr) + -- Need to return a RuleSubst solely for the benefit of mk_fake_ty + lookup_tmpl rs@(RS { rs_tv_subst = tv_subst, rs_id_subst = id_subst }) + (tmpl_var, tmpl_var1) + | isId tmpl_var1 + = case lookupVarEnv id_subst tmpl_var1 of + Just e -> (rs, e) + Nothing | Just refl_co <- isReflCoVar_maybe tmpl_var1 + , let co_expr = Coercion refl_co + id_subst' = extendVarEnv id_subst tmpl_var1 co_expr + rs' = rs { rs_id_subst = id_subst' } + -> (rs', co_expr) -- See Note [Unbound RULE binders] + | otherwise + -> unbound tmpl_var + | otherwise + = case lookupVarEnv tv_subst tmpl_var1 of + Just ty -> (rs, Type ty) + Nothing -> (rs', Type fake_ty) -- See Note [Unbound RULE binders] + where + rs' = rs { rs_tv_subst = extendVarEnv tv_subst tmpl_var1 fake_ty } + fake_ty = mk_fake_ty in_scope rs tmpl_var1 + -- This call is the sole reason we accumulate + -- RuleSubst in lookup_tmpl + + unbound tmpl_var + = pprPanic "Template variable unbound in rewrite rule" $ + vcat [ text "Variable:" <+> ppr tmpl_var <+> dcolon <+> ppr (varType tmpl_var) + , text "Rule" <+> pprRuleName rule_name + , text "Rule bndrs:" <+> ppr tmpl_vars + , text "LHS args:" <+> ppr tmpl_es + , text "Actual args:" <+> ppr target_es ] + + +mk_fake_ty :: InScopeSet -> RuleSubst -> TyVar -> Kind +-- Roughly: +-- mk_fake_ty subst tv = Any @(subst (tyVarKind tv)) +-- That is: apply the substitution to the kind of the given tyvar, +-- and make an 'any' type of that kind. +-- Tiresomely, the RuleSubst is not well adapted to substTy, leading to +-- horrible impedence matching. +-- +-- Happily, this function is seldom called +mk_fake_ty in_scope (RS { rs_tv_subst = tv_subst, rs_id_subst = id_subst }) tmpl_var1 + = anyTypeOfKind kind + where + kind = Type.substTy (mkTCvSubst in_scope (tv_subst, cv_subst)) + (tyVarKind tmpl_var1) + + cv_subst = to_co_env id_subst + + to_co_env :: IdSubstEnv -> CvSubstEnv + to_co_env env = nonDetFoldUFM_Directly to_co emptyVarEnv env + -- It's OK to use nonDetFoldUFM_Directly because we forget the + -- order immediately by creating a new env + + to_co uniq expr env + = case exprToCoercion_maybe expr of + Just co -> extendVarEnv_Directly env uniq co + Nothing -> env + +{- Note [Unbound RULE binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It can be the case that the binder in a rule is not actually +bound on the LHS: + +* Type variables. Type synonyms with phantom args can give rise to + unbound template type variables. Consider this (#10689, + simplCore/should_compile/T10689): + + type Foo a b = b + + f :: Eq a => a -> Bool + f x = x==x + + {-# RULES "foo" forall (x :: Foo a Char). f x = True #-} + finkle = f 'c' + + The rule looks like + forall (a::*) (d::Eq Char) (x :: Foo a Char). + f (Foo a Char) d x = True + + Matching the rule won't bind 'a', and legitimately so. We fudge by + pretending that 'a' is bound to (Any :: *). + +* Coercion variables. On the LHS of a RULE for a local binder + we might have + RULE forall (c :: a~b). f (x |> c) = e + Now, if that binding is inlined, so that a=b=Int, we'd get + RULE forall (c :: Int~Int). f (x |> c) = e + and now when we simplify the LHS (Simplify.simplRule) we + optCoercion will turn that 'c' into Refl: + RULE forall (c :: Int~Int). f (x |> ) = e + and then perhaps drop it altogether. Now 'c' is unbound. + + It's tricky to be sure this never happens, so instead I + say it's OK to have an unbound coercion binder in a RULE + provided its type is (c :: t~t). Then, when the RULE + fires we can substitute for c. + + This actually happened (in a RULE for a local function) + in #13410, and also in test T10602. + + +Note [Cloning the template binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following match (example 1): + Template: forall x. f x + Target: f (x+1) +This should succeed, because the template variable 'x' has nothing to +do with the 'x' in the target. + +Likewise this one (example 2): + Template: forall x. f (\x.x) + Target: f (\y.y) + +We achieve this simply by using rnBndrL to clone the template +binders if they are already in scope. + +------ Historical note ------- +At one point I tried simply adding the template binders to the +in-scope set /without/ cloning them, but that failed in a horribly +obscure way in #14777. Problem was that during matching we look +up target-term variables in the in-scope set (see Note [Lookup +in-scope]). If a target-term variable happens to name-clash with a +template variable, that lookup will find the template variable, which +is /utterly/ bogus. In #14777, this transformed a term variable +into a type variable, and then crashed when we wanted its idInfo. +------ End of historical note ------- + + +************************************************************************ +* * + The main matcher +* * +********************************************************************* -} + +-- * The domain of the TvSubstEnv and IdSubstEnv are the template +-- variables passed into the match. +-- +-- * The BindWrapper in a RuleSubst are the bindings floated out +-- from nested matches; see the Let case of match, below +-- +data RuleMatchEnv + = RV { rv_lcl :: RnEnv2 -- Renamings for *local bindings* + -- (lambda/case) + , rv_tmpls :: VarSet -- Template variables + -- (after applying envL of rv_lcl) + , rv_fltR :: Subst -- Renamings for floated let-bindings + -- (domain disjoint from envR of rv_lcl) + -- See Note [Matching lets] + , rv_unf :: IdUnfoldingFun + } + +rvInScopeEnv :: RuleMatchEnv -> InScopeEnv +rvInScopeEnv renv = (rnInScopeSet (rv_lcl renv), rv_unf renv) + +data RuleSubst = RS { rs_tv_subst :: TvSubstEnv -- Range is the + , rs_id_subst :: IdSubstEnv -- template variables + , rs_binds :: BindWrapper -- Floated bindings + , rs_bndrs :: VarSet -- Variables bound by floated lets + } + +type BindWrapper = CoreExpr -> CoreExpr + -- See Notes [Matching lets] and [Matching cases] + -- we represent the floated bindings as a core-to-core function + +emptyRuleSubst :: RuleSubst +emptyRuleSubst = RS { rs_tv_subst = emptyVarEnv, rs_id_subst = emptyVarEnv + , rs_binds = \e -> e, rs_bndrs = emptyVarSet } + +-- At one stage I tried to match even if there are more +-- template args than real args. + +-- I now think this is probably a bad idea. +-- Should the template (map f xs) match (map g)? I think not. +-- For a start, in general eta expansion wastes work. +-- SLPJ July 99 + +match :: RuleMatchEnv + -> RuleSubst + -> CoreExpr -- Template + -> CoreExpr -- Target + -> Maybe RuleSubst + +-- We look through certain ticks. See note [Tick annotations in RULE matching] +match renv subst e1 (Tick t e2) + | tickishFloatable t + = match renv subst' e1 e2 + where subst' = subst { rs_binds = rs_binds subst . mkTick t } +match _ _ e@Tick{} _ + = pprPanic "Tick in rule" (ppr e) + +-- See the notes with Unify.match, which matches types +-- Everything is very similar for terms + +-- Interesting examples: +-- Consider matching +-- \x->f against \f->f +-- When we meet the lambdas we must remember to rename f to f' in the +-- second expression. The RnEnv2 does that. +-- +-- Consider matching +-- forall a. \b->b against \a->3 +-- We must rename the \a. Otherwise when we meet the lambdas we +-- might substitute [a/b] in the template, and then erroneously +-- succeed in matching what looks like the template variable 'a' against 3. + +-- The Var case follows closely what happens in Unify.match +match renv subst (Var v1) e2 + = match_var renv subst v1 e2 + +match renv subst e1 (Var v2) -- Note [Expanding variables] + | not (inRnEnvR rn_env v2) -- Note [Do not expand locally-bound variables] + , Just e2' <- expandUnfolding_maybe (rv_unf renv v2') + = match (renv { rv_lcl = nukeRnEnvR rn_env }) subst e1 e2' + where + v2' = lookupRnInScope rn_env v2 + rn_env = rv_lcl renv + -- Notice that we look up v2 in the in-scope set + -- See Note [Lookup in-scope] + -- No need to apply any renaming first (hence no rnOccR) + -- because of the not-inRnEnvR + +match renv subst e1 (Let bind e2) + | -- pprTrace "match:Let" (vcat [ppr bind, ppr $ okToFloat (rv_lcl renv) (bindFreeVars bind)]) $ + not (isJoinBind bind) -- can't float join point out of argument position + , okToFloat (rv_lcl renv) (bindFreeVars bind) -- See Note [Matching lets] + = match (renv { rv_fltR = flt_subst' }) + (subst { rs_binds = rs_binds subst . Let bind' + , rs_bndrs = extendVarSetList (rs_bndrs subst) new_bndrs }) + e1 e2 + where + flt_subst = addInScopeSet (rv_fltR renv) (rs_bndrs subst) + (flt_subst', bind') = substBind flt_subst bind + new_bndrs = bindersOf bind' + +{- Disabled: see Note [Matching cases] below +match renv (tv_subst, id_subst, binds) e1 + (Case scrut case_bndr ty [(con, alt_bndrs, rhs)]) + | exprOkForSpeculation scrut -- See Note [Matching cases] + , okToFloat rn_env bndrs (exprFreeVars scrut) + = match (renv { me_env = rn_env' }) + (tv_subst, id_subst, binds . case_wrap) + e1 rhs + where + rn_env = me_env renv + rn_env' = extendRnInScopeList rn_env bndrs + bndrs = case_bndr : alt_bndrs + case_wrap rhs' = Case scrut case_bndr ty [(con, alt_bndrs, rhs')] +-} + +match _ subst (Lit lit1) (Lit lit2) + | lit1 == lit2 + = Just subst + +match renv subst (App f1 a1) (App f2 a2) + = do { subst' <- match renv subst f1 f2 + ; match renv subst' a1 a2 } + +match renv subst (Lam x1 e1) e2 + | Just (x2, e2, ts) <- exprIsLambda_maybe (rvInScopeEnv renv) e2 + = let renv' = renv { rv_lcl = rnBndr2 (rv_lcl renv) x1 x2 + , rv_fltR = delBndr (rv_fltR renv) x2 } + subst' = subst { rs_binds = rs_binds subst . flip (foldr mkTick) ts } + in match renv' subst' e1 e2 + +match renv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2) + = do { subst1 <- match_ty renv subst ty1 ty2 + ; subst2 <- match renv subst1 e1 e2 + ; let renv' = rnMatchBndr2 renv subst x1 x2 + ; match_alts renv' subst2 alts1 alts2 -- Alts are both sorted + } + +match renv subst (Type ty1) (Type ty2) + = match_ty renv subst ty1 ty2 +match renv subst (Coercion co1) (Coercion co2) + = match_co renv subst co1 co2 + +match renv subst (Cast e1 co1) (Cast e2 co2) + = do { subst1 <- match_co renv subst co1 co2 + ; match renv subst1 e1 e2 } + +-- Everything else fails +match _ _ _e1 _e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ (text "e2:" <+> ppr _e2)) $ + Nothing + +------------- +match_co :: RuleMatchEnv + -> RuleSubst + -> Coercion + -> Coercion + -> Maybe RuleSubst +match_co renv subst co1 co2 + | Just cv <- getCoVar_maybe co1 + = match_var renv subst cv (Coercion co2) + | Just (ty1, r1) <- isReflCo_maybe co1 + = do { (ty2, r2) <- isReflCo_maybe co2 + ; guard (r1 == r2) + ; match_ty renv subst ty1 ty2 } +match_co renv subst co1 co2 + | Just (tc1, cos1) <- splitTyConAppCo_maybe co1 + = case splitTyConAppCo_maybe co2 of + Just (tc2, cos2) + | tc1 == tc2 + -> match_cos renv subst cos1 cos2 + _ -> Nothing +match_co renv subst co1 co2 + | Just (arg1, res1) <- splitFunCo_maybe co1 + = case splitFunCo_maybe co2 of + Just (arg2, res2) + -> match_cos renv subst [arg1, res1] [arg2, res2] + _ -> Nothing +match_co _ _ _co1 _co2 + -- Currently just deals with CoVarCo, TyConAppCo and Refl +#if defined(DEBUG) + = pprTrace "match_co: needs more cases" (ppr _co1 $$ ppr _co2) Nothing +#else + = Nothing +#endif + +match_cos :: RuleMatchEnv + -> RuleSubst + -> [Coercion] + -> [Coercion] + -> Maybe RuleSubst +match_cos renv subst (co1:cos1) (co2:cos2) = + do { subst' <- match_co renv subst co1 co2 + ; match_cos renv subst' cos1 cos2 } +match_cos _ subst [] [] = Just subst +match_cos _ _ cos1 cos2 = pprTrace "match_cos: not same length" (ppr cos1 $$ ppr cos2) Nothing + +------------- +rnMatchBndr2 :: RuleMatchEnv -> RuleSubst -> Var -> Var -> RuleMatchEnv +rnMatchBndr2 renv subst x1 x2 + = renv { rv_lcl = rnBndr2 rn_env x1 x2 + , rv_fltR = delBndr (rv_fltR renv) x2 } + where + rn_env = addRnInScopeSet (rv_lcl renv) (rs_bndrs subst) + -- Typically this is a no-op, but it may matter if + -- there are some floated let-bindings + +------------------------------------------ +match_alts :: RuleMatchEnv + -> RuleSubst + -> [CoreAlt] -- Template + -> [CoreAlt] -- Target + -> Maybe RuleSubst +match_alts _ subst [] [] + = return subst +match_alts renv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2) + | c1 == c2 + = do { subst1 <- match renv' subst r1 r2 + ; match_alts renv subst1 alts1 alts2 } + where + renv' = foldl' mb renv (vs1 `zip` vs2) + mb renv (v1,v2) = rnMatchBndr2 renv subst v1 v2 + +match_alts _ _ _ _ + = Nothing + +------------------------------------------ +okToFloat :: RnEnv2 -> VarSet -> Bool +okToFloat rn_env bind_fvs + = allVarSet not_captured bind_fvs + where + not_captured fv = not (inRnEnvR rn_env fv) + +------------------------------------------ +match_var :: RuleMatchEnv + -> RuleSubst + -> Var -- Template + -> CoreExpr -- Target + -> Maybe RuleSubst +match_var renv@(RV { rv_tmpls = tmpls, rv_lcl = rn_env, rv_fltR = flt_env }) + subst v1 e2 + | v1' `elemVarSet` tmpls + = match_tmpl_var renv subst v1' e2 + + | otherwise -- v1' is not a template variable; check for an exact match with e2 + = case e2 of -- Remember, envR of rn_env is disjoint from rv_fltR + Var v2 | v1' == rnOccR rn_env v2 + -> Just subst + + | Var v2' <- lookupIdSubst (text "match_var") flt_env v2 + , v1' == v2' + -> Just subst + + _ -> Nothing + + where + v1' = rnOccL rn_env v1 + -- If the template is + -- forall x. f x (\x -> x) = ... + -- Then the x inside the lambda isn't the + -- template x, so we must rename first! + +------------------------------------------ +match_tmpl_var :: RuleMatchEnv + -> RuleSubst + -> Var -- Template + -> CoreExpr -- Target + -> Maybe RuleSubst + +match_tmpl_var renv@(RV { rv_lcl = rn_env, rv_fltR = flt_env }) + subst@(RS { rs_id_subst = id_subst, rs_bndrs = let_bndrs }) + v1' e2 + | any (inRnEnvR rn_env) (exprFreeVarsList e2) + = Nothing -- Occurs check failure + -- e.g. match forall a. (\x-> a x) against (\y. y y) + + | Just e1' <- lookupVarEnv id_subst v1' + = if eqExpr (rnInScopeSet rn_env) e1' e2' + then Just subst + else Nothing + + | otherwise + = -- Note [Matching variable types] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- However, we must match the *types*; e.g. + -- forall (c::Char->Int) (x::Char). + -- f (c x) = "RULE FIRED" + -- We must only match on args that have the right type + -- It's actually quite difficult to come up with an example that shows + -- you need type matching, esp since matching is left-to-right, so type + -- args get matched first. But it's possible (e.g. simplrun008) and + -- this is the Right Thing to do + do { subst' <- match_ty renv subst (idType v1') (exprType e2) + ; return (subst' { rs_id_subst = id_subst' }) } + where + -- e2' is the result of applying flt_env to e2 + e2' | isEmptyVarSet let_bndrs = e2 + | otherwise = substExpr (text "match_tmpl_var") flt_env e2 + + id_subst' = extendVarEnv (rs_id_subst subst) v1' e2' + -- No further renaming to do on e2', + -- because no free var of e2' is in the rnEnvR of the envt + +------------------------------------------ +match_ty :: RuleMatchEnv + -> RuleSubst + -> Type -- Template + -> Type -- Target + -> Maybe RuleSubst +-- Matching Core types: use the matcher in TcType. +-- Notice that we treat newtypes as opaque. For example, suppose +-- we have a specialised version of a function at a newtype, say +-- newtype T = MkT Int +-- We only want to replace (f T) with f', not (f Int). + +match_ty renv subst ty1 ty2 + = do { tv_subst' + <- Unify.ruleMatchTyKiX (rv_tmpls renv) (rv_lcl renv) tv_subst ty1 ty2 + ; return (subst { rs_tv_subst = tv_subst' }) } + where + tv_subst = rs_tv_subst subst + +{- +Note [Expanding variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Here is another Very Important rule: if the term being matched is a +variable, we expand it so long as its unfolding is "expandable". (Its +occurrence information is not necessarily up to date, so we don't use +it.) By "expandable" we mean a WHNF or a "constructor-like" application. +This is the key reason for "constructor-like" Ids. If we have + {-# NOINLINE [1] CONLIKE g #-} + {-# RULE f (g x) = h x #-} +then in the term + let v = g 3 in ....(f v).... +we want to make the rule fire, to replace (f v) with (h 3). + +Note [Do not expand locally-bound variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Do *not* expand locally-bound variables, else there's a worry that the +unfolding might mention variables that are themselves renamed. +Example + case x of y { (p,q) -> ...y... } +Don't expand 'y' to (p,q) because p,q might themselves have been +renamed. Essentially we only expand unfoldings that are "outside" +the entire match. + +Hence, (a) the guard (not (isLocallyBoundR v2)) + (b) when we expand we nuke the renaming envt (nukeRnEnvR). + +Note [Tick annotations in RULE matching] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We used to unconditionally look through Notes in both template and +expression being matched. This is actually illegal for counting or +cost-centre-scoped ticks, because we have no place to put them without +changing entry counts and/or costs. So now we just fail the match in +these cases. + +On the other hand, where we are allowed to insert new cost into the +tick scope, we can float them upwards to the rule application site. + +cf Note [Notes in call patterns] in SpecConstr + +Note [Matching lets] +~~~~~~~~~~~~~~~~~~~~ +Matching a let-expression. Consider + RULE forall x. f (g x) = +and target expression + f (let { w=R } in g E)) +Then we'd like the rule to match, to generate + let { w=R } in (\x. ) E +In effect, we want to float the let-binding outward, to enable +the match to happen. This is the WHOLE REASON for accumulating +bindings in the RuleSubst + +We can only do this if the free variables of R are not bound by the +part of the target expression outside the let binding; e.g. + f (\v. let w = v+1 in g E) +Here we obviously cannot float the let-binding for w. Hence the +use of okToFloat. + +There are a couple of tricky points. + (a) What if floating the binding captures a variable? + f (let v = x+1 in v) v + --> NOT! + let v = x+1 in f (x+1) v + + (b) What if two non-nested let bindings bind the same variable? + f (let v = e1 in b1) (let v = e2 in b2) + --> NOT! + let v = e1 in let v = e2 in (f b2 b2) + See testsuite test "RuleFloatLet". + +Our cunning plan is this: + * Along with the growing substitution for template variables + we maintain a growing set of floated let-bindings (rs_binds) + plus the set of variables thus bound. + + * The RnEnv2 in the MatchEnv binds only the local binders + in the term (lambdas, case) + + * When we encounter a let in the term to be matched, we + check that does not mention any locally bound (lambda, case) + variables. If so we fail + + * We use CoreSubst.substBind to freshen the binding, using an + in-scope set that is the original in-scope variables plus the + rs_bndrs (currently floated let-bindings). So in (a) above + we'll freshen the 'v' binding; in (b) above we'll freshen + the *second* 'v' binding. + + * We apply that freshening substitution, in a lexically-scoped + way to the term, although lazily; this is the rv_fltR field. + + +Note [Matching cases] +~~~~~~~~~~~~~~~~~~~~~ +{- NOTE: This idea is currently disabled. It really only works if + the primops involved are OkForSpeculation, and, since + they have side effects readIntOfAddr and touch are not. + Maybe we'll get back to this later . -} + +Consider + f (case readIntOffAddr# p# i# realWorld# of { (# s#, n# #) -> + case touch# fp s# of { _ -> + I# n# } } ) +This happened in a tight loop generated by stream fusion that +Roman encountered. We'd like to treat this just like the let +case, because the primops concerned are ok-for-speculation. +That is, we'd like to behave as if it had been + case readIntOffAddr# p# i# realWorld# of { (# s#, n# #) -> + case touch# fp s# of { _ -> + f (I# n# } } ) + +Note [Lookup in-scope] +~~~~~~~~~~~~~~~~~~~~~~ +Consider this example + foo :: Int -> Maybe Int -> Int + foo 0 (Just n) = n + foo m (Just n) = foo (m-n) (Just n) + +SpecConstr sees this fragment: + + case w_smT of wild_Xf [Just A] { + Data.Maybe.Nothing -> lvl_smf; + Data.Maybe.Just n_acT [Just S(L)] -> + case n_acT of wild1_ams [Just A] { GHC.Base.I# y_amr [Just L] -> + $wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf + }}; + +and correctly generates the rule + + RULES: "SC:$wfoo1" [0] __forall {y_amr [Just L] :: GHC.Prim.Int# + sc_snn :: GHC.Prim.Int#} + $wfoo_smW sc_snn (Data.Maybe.Just @ GHC.Base.Int (GHC.Base.I# y_amr)) + = $s$wfoo_sno y_amr sc_snn ;] + +BUT we must ensure that this rule matches in the original function! +Note that the call to $wfoo is + $wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf + +During matching we expand wild_Xf to (Just n_acT). But then we must also +expand n_acT to (I# y_amr). And we can only do that if we look up n_acT +in the in-scope set, because in wild_Xf's unfolding it won't have an unfolding +at all. + +That is why the 'lookupRnInScope' call in the (Var v2) case of 'match' +is so important. + + +************************************************************************ +* * + Rule-check the program +* * +************************************************************************ + + We want to know what sites have rules that could have fired but didn't. + This pass runs over the tree (without changing it) and reports such. +-} + +-- | Report partial matches for rules beginning with the specified +-- string for the purposes of error reporting +ruleCheckProgram :: CompilerPhase -- ^ Rule activation test + -> String -- ^ Rule pattern + -> (Id -> [CoreRule]) -- ^ Rules for an Id + -> CoreProgram -- ^ Bindings to check in + -> SDoc -- ^ Resulting check message +ruleCheckProgram phase rule_pat rules binds + | isEmptyBag results + = text "Rule check results: no rule application sites" + | otherwise + = vcat [text "Rule check results:", + line, + vcat [ p $$ line | p <- bagToList results ] + ] + where + env = RuleCheckEnv { rc_is_active = isActive phase + , rc_id_unf = idUnfolding -- Not quite right + -- Should use activeUnfolding + , rc_pattern = rule_pat + , rc_rules = rules } + results = unionManyBags (map (ruleCheckBind env) binds) + line = text (replicate 20 '-') + +data RuleCheckEnv = RuleCheckEnv { + rc_is_active :: Activation -> Bool, + rc_id_unf :: IdUnfoldingFun, + rc_pattern :: String, + rc_rules :: Id -> [CoreRule] +} + +ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc + -- The Bag returned has one SDoc for each call site found +ruleCheckBind env (NonRec _ r) = ruleCheck env r +ruleCheckBind env (Rec prs) = unionManyBags [ruleCheck env r | (_,r) <- prs] + +ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc +ruleCheck _ (Var _) = emptyBag +ruleCheck _ (Lit _) = emptyBag +ruleCheck _ (Type _) = emptyBag +ruleCheck _ (Coercion _) = emptyBag +ruleCheck env (App f a) = ruleCheckApp env (App f a) [] +ruleCheck env (Tick _ e) = ruleCheck env e +ruleCheck env (Cast e _) = ruleCheck env e +ruleCheck env (Let bd e) = ruleCheckBind env bd `unionBags` ruleCheck env e +ruleCheck env (Lam _ e) = ruleCheck env e +ruleCheck env (Case e _ _ as) = ruleCheck env e `unionBags` + unionManyBags [ruleCheck env r | (_,_,r) <- as] + +ruleCheckApp :: RuleCheckEnv -> Expr CoreBndr -> [Arg CoreBndr] -> Bag SDoc +ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as) +ruleCheckApp env (Var f) as = ruleCheckFun env f as +ruleCheckApp env other _ = ruleCheck env other + +ruleCheckFun :: RuleCheckEnv -> Id -> [CoreExpr] -> Bag SDoc +-- Produce a report for all rules matching the predicate +-- saying why it doesn't match the specified application + +ruleCheckFun env fn args + | null name_match_rules = emptyBag + | otherwise = unitBag (ruleAppCheck_help env fn args name_match_rules) + where + name_match_rules = filter match (rc_rules env fn) + match rule = (rc_pattern env) `isPrefixOf` unpackFS (ruleName rule) + +ruleAppCheck_help :: RuleCheckEnv -> Id -> [CoreExpr] -> [CoreRule] -> SDoc +ruleAppCheck_help env fn args rules + = -- The rules match the pattern, so we want to print something + vcat [text "Expression:" <+> ppr (mkApps (Var fn) args), + vcat (map check_rule rules)] + where + n_args = length args + i_args = args `zip` [1::Int ..] + rough_args = map roughTopName args + + check_rule rule = sdocWithDynFlags $ \dflags -> + rule_herald rule <> colon <+> rule_info dflags rule + + rule_herald (BuiltinRule { ru_name = name }) + = text "Builtin rule" <+> doubleQuotes (ftext name) + rule_herald (Rule { ru_name = name }) + = text "Rule" <+> doubleQuotes (ftext name) + + rule_info dflags rule + | Just _ <- matchRule dflags (emptyInScopeSet, rc_id_unf env) + noBlackList fn args rough_args rule + = text "matches (which is very peculiar!)" + + rule_info _ (BuiltinRule {}) = text "does not match" + + rule_info _ (Rule { ru_act = act, + ru_bndrs = rule_bndrs, ru_args = rule_args}) + | not (rc_is_active env act) = text "active only in later phase" + | n_args < n_rule_args = text "too few arguments" + | n_mismatches == n_rule_args = text "no arguments match" + | n_mismatches == 0 = text "all arguments match (considered individually), but rule as a whole does not" + | otherwise = text "arguments" <+> ppr mismatches <+> text "do not match (1-indexing)" + where + n_rule_args = length rule_args + n_mismatches = length mismatches + mismatches = [i | (rule_arg, (arg,i)) <- rule_args `zip` i_args, + not (isJust (match_fn rule_arg arg))] + + lhs_fvs = exprsFreeVars rule_args -- Includes template tyvars + match_fn rule_arg arg = match renv emptyRuleSubst rule_arg arg + where + in_scope = mkInScopeSet (lhs_fvs `unionVarSet` exprFreeVars arg) + renv = RV { rv_lcl = mkRnEnv2 in_scope + , rv_tmpls = mkVarSet rule_bndrs + , rv_fltR = mkEmptySubst in_scope + , rv_unf = rc_id_unf env } diff --git a/compiler/typecheck/TcEvidence.hs b/compiler/typecheck/TcEvidence.hs new file mode 100644 --- /dev/null +++ b/compiler/typecheck/TcEvidence.hs @@ -0,0 +1,991 @@ +-- (c) The University of Glasgow 2006 + +{-# LANGUAGE CPP, DeriveDataTypeable #-} + +module TcEvidence ( + + -- HsWrapper + HsWrapper(..), + (<.>), mkWpTyApps, mkWpEvApps, mkWpEvVarApps, mkWpTyLams, + mkWpLams, mkWpLet, mkWpCastN, mkWpCastR, collectHsWrapBinders, + mkWpFun, mkWpFuns, idHsWrapper, isIdHsWrapper, pprHsWrapper, + + -- Evidence bindings + TcEvBinds(..), EvBindsVar(..), + EvBindMap(..), emptyEvBindMap, extendEvBinds, + lookupEvBind, evBindMapBinds, foldEvBindMap, filterEvBindMap, + isEmptyEvBindMap, + EvBind(..), emptyTcEvBinds, isEmptyTcEvBinds, mkGivenEvBind, mkWantedEvBind, + evBindVar, isCoEvBindsVar, + + -- EvTerm (already a CoreExpr) + EvTerm(..), EvExpr, + evId, evCoercion, evCast, evDFunApp, evDataConApp, evSelector, + mkEvCast, evVarsOfTerm, mkEvScSelectors, evTypeable, findNeededEvVars, + + evTermCoercion, evTermCoercion_maybe, + EvCallStack(..), + EvTypeable(..), + + -- TcCoercion + TcCoercion, TcCoercionR, TcCoercionN, TcCoercionP, CoercionHole, + Role(..), LeftOrRight(..), pickLR, + mkTcReflCo, mkTcNomReflCo, mkTcRepReflCo, + mkTcTyConAppCo, mkTcAppCo, mkTcFunCo, + mkTcAxInstCo, mkTcUnbranchedAxInstCo, mkTcForAllCo, mkTcForAllCos, + mkTcSymCo, mkTcTransCo, mkTcNthCo, mkTcLRCo, mkTcSubCo, maybeTcSubCo, + tcDowngradeRole, + mkTcAxiomRuleCo, mkTcGReflRightCo, mkTcGReflLeftCo, mkTcPhantomCo, + mkTcCoherenceLeftCo, + mkTcCoherenceRightCo, + mkTcKindCo, + tcCoercionKind, coVarsOfTcCo, + mkTcCoVarCo, + isTcReflCo, isTcReflexiveCo, + tcCoercionRole, + unwrapIP, wrapIP + ) where +#include "HsVersions.h" + +import GhcPrelude + +import Var +import CoAxiom +import Coercion +import PprCore () -- Instance OutputableBndr TyVar +import TcType +import Type +import TyCon +import DataCon( DataCon, dataConWrapId ) +import Class( Class ) +import PrelNames +import DynFlags ( gopt, GeneralFlag(Opt_PrintTypecheckerElaboration) ) +import VarEnv +import VarSet +import Name +import Pair + +import CoreSyn +import Class ( classSCSelId ) +import Id ( isEvVar ) +import CoreFVs ( exprSomeFreeVars ) + +import Util +import Bag +import qualified Data.Data as Data +import Outputable +import SrcLoc +import Data.IORef( IORef ) +import UniqSet + +{- +Note [TcCoercions] +~~~~~~~~~~~~~~~~~~ +| TcCoercions are a hack used by the typechecker. Normally, +Coercions have free variables of type (a ~# b): we call these +CoVars. However, the type checker passes around equality evidence +(boxed up) at type (a ~ b). + +An TcCoercion is simply a Coercion whose free variables have may be either +boxed or unboxed. After we are done with typechecking the desugarer finds the +boxed free variables, unboxes them, and creates a resulting real Coercion with +kosher free variables. + +-} + +type TcCoercion = Coercion +type TcCoercionN = CoercionN -- A Nominal coercion ~N +type TcCoercionR = CoercionR -- A Representational coercion ~R +type TcCoercionP = CoercionP -- a phantom coercion + +mkTcReflCo :: Role -> TcType -> TcCoercion +mkTcSymCo :: TcCoercion -> TcCoercion +mkTcTransCo :: TcCoercion -> TcCoercion -> TcCoercion +mkTcNomReflCo :: TcType -> TcCoercionN +mkTcRepReflCo :: TcType -> TcCoercionR +mkTcTyConAppCo :: Role -> TyCon -> [TcCoercion] -> TcCoercion +mkTcAppCo :: TcCoercion -> TcCoercionN -> TcCoercion +mkTcFunCo :: Role -> TcCoercion -> TcCoercion -> TcCoercion +mkTcAxInstCo :: Role -> CoAxiom br -> BranchIndex + -> [TcType] -> [TcCoercion] -> TcCoercion +mkTcUnbranchedAxInstCo :: CoAxiom Unbranched -> [TcType] + -> [TcCoercion] -> TcCoercionR +mkTcForAllCo :: TyVar -> TcCoercionN -> TcCoercion -> TcCoercion +mkTcForAllCos :: [(TyVar, TcCoercionN)] -> TcCoercion -> TcCoercion +mkTcNthCo :: Role -> Int -> TcCoercion -> TcCoercion +mkTcLRCo :: LeftOrRight -> TcCoercion -> TcCoercion +mkTcSubCo :: TcCoercionN -> TcCoercionR +maybeTcSubCo :: EqRel -> TcCoercion -> TcCoercion +tcDowngradeRole :: Role -> Role -> TcCoercion -> TcCoercion +mkTcAxiomRuleCo :: CoAxiomRule -> [TcCoercion] -> TcCoercionR +mkTcGReflRightCo :: Role -> TcType -> TcCoercionN -> TcCoercion +mkTcGReflLeftCo :: Role -> TcType -> TcCoercionN -> TcCoercion +mkTcCoherenceLeftCo :: Role -> TcType -> TcCoercionN + -> TcCoercion -> TcCoercion +mkTcCoherenceRightCo :: Role -> TcType -> TcCoercionN + -> TcCoercion -> TcCoercion +mkTcPhantomCo :: TcCoercionN -> TcType -> TcType -> TcCoercionP +mkTcKindCo :: TcCoercion -> TcCoercionN +mkTcCoVarCo :: CoVar -> TcCoercion + +tcCoercionKind :: TcCoercion -> Pair TcType +tcCoercionRole :: TcCoercion -> Role +coVarsOfTcCo :: TcCoercion -> TcTyCoVarSet +isTcReflCo :: TcCoercion -> Bool + +-- | This version does a slow check, calculating the related types and seeing +-- if they are equal. +isTcReflexiveCo :: TcCoercion -> Bool + +mkTcReflCo = mkReflCo +mkTcSymCo = mkSymCo +mkTcTransCo = mkTransCo +mkTcNomReflCo = mkNomReflCo +mkTcRepReflCo = mkRepReflCo +mkTcTyConAppCo = mkTyConAppCo +mkTcAppCo = mkAppCo +mkTcFunCo = mkFunCo +mkTcAxInstCo = mkAxInstCo +mkTcUnbranchedAxInstCo = mkUnbranchedAxInstCo Representational +mkTcForAllCo = mkForAllCo +mkTcForAllCos = mkForAllCos +mkTcNthCo = mkNthCo +mkTcLRCo = mkLRCo +mkTcSubCo = mkSubCo +maybeTcSubCo = maybeSubCo +tcDowngradeRole = downgradeRole +mkTcAxiomRuleCo = mkAxiomRuleCo +mkTcGReflRightCo = mkGReflRightCo +mkTcGReflLeftCo = mkGReflLeftCo +mkTcCoherenceLeftCo = mkCoherenceLeftCo +mkTcCoherenceRightCo = mkCoherenceRightCo +mkTcPhantomCo = mkPhantomCo +mkTcKindCo = mkKindCo +mkTcCoVarCo = mkCoVarCo + +tcCoercionKind = coercionKind +tcCoercionRole = coercionRole +coVarsOfTcCo = coVarsOfCo +isTcReflCo = isReflCo +isTcReflexiveCo = isReflexiveCo + +{- +%************************************************************************ +%* * + HsWrapper +* * +************************************************************************ +-} + +data HsWrapper + = WpHole -- The identity coercion + + | WpCompose HsWrapper HsWrapper + -- (wrap1 `WpCompose` wrap2)[e] = wrap1[ wrap2[ e ]] + -- + -- Hence (\a. []) `WpCompose` (\b. []) = (\a b. []) + -- But ([] a) `WpCompose` ([] b) = ([] b a) + + | WpFun HsWrapper HsWrapper TcType SDoc + -- (WpFun wrap1 wrap2 t1)[e] = \(x:t1). wrap2[ e wrap1[x] ] + -- So note that if wrap1 :: exp_arg <= act_arg + -- wrap2 :: act_res <= exp_res + -- then WpFun wrap1 wrap2 : (act_arg -> arg_res) <= (exp_arg -> exp_res) + -- This isn't the same as for mkFunCo, but it has to be this way + -- because we can't use 'sym' to flip around these HsWrappers + -- The TcType is the "from" type of the first wrapper + -- The SDoc explains the circumstances under which we have created this + -- WpFun, in case we run afoul of levity polymorphism restrictions in + -- the desugarer. See Note [Levity polymorphism checking] in DsMonad + + | WpCast TcCoercionR -- A cast: [] `cast` co + -- Guaranteed not the identity coercion + -- At role Representational + + -- Evidence abstraction and application + -- (both dictionaries and coercions) + | WpEvLam EvVar -- \d. [] the 'd' is an evidence variable + | WpEvApp EvTerm -- [] d the 'd' is evidence for a constraint + -- Kind and Type abstraction and application + | WpTyLam TyVar -- \a. [] the 'a' is a type/kind variable (not coercion var) + | WpTyApp KindOrType -- [] t the 't' is a type (not coercion) + + + | WpLet TcEvBinds -- Non-empty (or possibly non-empty) evidence bindings, + -- so that the identity coercion is always exactly WpHole + +-- Cannot derive Data instance because SDoc is not Data (it stores a function). +-- So we do it manually: +instance Data.Data HsWrapper where + gfoldl _ z WpHole = z WpHole + gfoldl k z (WpCompose a1 a2) = z WpCompose `k` a1 `k` a2 + gfoldl k z (WpFun a1 a2 a3 _) = z wpFunEmpty `k` a1 `k` a2 `k` a3 + gfoldl k z (WpCast a1) = z WpCast `k` a1 + gfoldl k z (WpEvLam a1) = z WpEvLam `k` a1 + gfoldl k z (WpEvApp a1) = z WpEvApp `k` a1 + gfoldl k z (WpTyLam a1) = z WpTyLam `k` a1 + gfoldl k z (WpTyApp a1) = z WpTyApp `k` a1 + gfoldl k z (WpLet a1) = z WpLet `k` a1 + + gunfold k z c = case Data.constrIndex c of + 1 -> z WpHole + 2 -> k (k (z WpCompose)) + 3 -> k (k (k (z wpFunEmpty))) + 4 -> k (z WpCast) + 5 -> k (z WpEvLam) + 6 -> k (z WpEvApp) + 7 -> k (z WpTyLam) + 8 -> k (z WpTyApp) + _ -> k (z WpLet) + + toConstr WpHole = wpHole_constr + toConstr (WpCompose _ _) = wpCompose_constr + toConstr (WpFun _ _ _ _) = wpFun_constr + toConstr (WpCast _) = wpCast_constr + toConstr (WpEvLam _) = wpEvLam_constr + toConstr (WpEvApp _) = wpEvApp_constr + toConstr (WpTyLam _) = wpTyLam_constr + toConstr (WpTyApp _) = wpTyApp_constr + toConstr (WpLet _) = wpLet_constr + + dataTypeOf _ = hsWrapper_dataType + +hsWrapper_dataType :: Data.DataType +hsWrapper_dataType + = Data.mkDataType "HsWrapper" + [ wpHole_constr, wpCompose_constr, wpFun_constr, wpCast_constr + , wpEvLam_constr, wpEvApp_constr, wpTyLam_constr, wpTyApp_constr + , wpLet_constr] + +wpHole_constr, wpCompose_constr, wpFun_constr, wpCast_constr, wpEvLam_constr, + wpEvApp_constr, wpTyLam_constr, wpTyApp_constr, wpLet_constr :: Data.Constr +wpHole_constr = mkHsWrapperConstr "WpHole" +wpCompose_constr = mkHsWrapperConstr "WpCompose" +wpFun_constr = mkHsWrapperConstr "WpFun" +wpCast_constr = mkHsWrapperConstr "WpCast" +wpEvLam_constr = mkHsWrapperConstr "WpEvLam" +wpEvApp_constr = mkHsWrapperConstr "WpEvApp" +wpTyLam_constr = mkHsWrapperConstr "WpTyLam" +wpTyApp_constr = mkHsWrapperConstr "WpTyApp" +wpLet_constr = mkHsWrapperConstr "WpLet" + +mkHsWrapperConstr :: String -> Data.Constr +mkHsWrapperConstr name = Data.mkConstr hsWrapper_dataType name [] Data.Prefix + +wpFunEmpty :: HsWrapper -> HsWrapper -> TcType -> HsWrapper +wpFunEmpty c1 c2 t1 = WpFun c1 c2 t1 empty + +(<.>) :: HsWrapper -> HsWrapper -> HsWrapper +WpHole <.> c = c +c <.> WpHole = c +c1 <.> c2 = c1 `WpCompose` c2 + +mkWpFun :: HsWrapper -> HsWrapper + -> TcType -- the "from" type of the first wrapper + -> TcType -- either type of the second wrapper (used only when the + -- second wrapper is the identity) + -> SDoc -- what caused you to want a WpFun? Something like "When converting ..." + -> HsWrapper +mkWpFun WpHole WpHole _ _ _ = WpHole +mkWpFun WpHole (WpCast co2) t1 _ _ = WpCast (mkTcFunCo Representational (mkTcRepReflCo t1) co2) +mkWpFun (WpCast co1) WpHole _ t2 _ = WpCast (mkTcFunCo Representational (mkTcSymCo co1) (mkTcRepReflCo t2)) +mkWpFun (WpCast co1) (WpCast co2) _ _ _ = WpCast (mkTcFunCo Representational (mkTcSymCo co1) co2) +mkWpFun co1 co2 t1 _ d = WpFun co1 co2 t1 d + +-- | @mkWpFuns [(ty1, wrap1), (ty2, wrap2)] ty_res wrap_res@, +-- where @wrap1 :: ty1 "->" ty1'@ and @wrap2 :: ty2 "->" ty2'@, +-- @wrap3 :: ty3 "->" ty3'@ and @ty_res@ is /either/ @ty3@ or @ty3'@, +-- gives a wrapper @(ty1' -> ty2' -> ty3) "->" (ty1 -> ty2 -> ty3')@. +-- Notice that the result wrapper goes the other way round to all +-- the others. This is a result of sub-typing contravariance. +-- The SDoc is a description of what you were doing when you called mkWpFuns. +mkWpFuns :: [(TcType, HsWrapper)] -> TcType -> HsWrapper -> SDoc -> HsWrapper +mkWpFuns args res_ty res_wrap doc = snd $ go args res_ty res_wrap + where + go [] res_ty res_wrap = (res_ty, res_wrap) + go ((arg_ty, arg_wrap) : args) res_ty res_wrap + = let (tail_ty, tail_wrap) = go args res_ty res_wrap in + (arg_ty `mkVisFunTy` tail_ty, mkWpFun arg_wrap tail_wrap arg_ty tail_ty doc) + +mkWpCastR :: TcCoercionR -> HsWrapper +mkWpCastR co + | isTcReflCo co = WpHole + | otherwise = ASSERT2(tcCoercionRole co == Representational, ppr co) + WpCast co + +mkWpCastN :: TcCoercionN -> HsWrapper +mkWpCastN co + | isTcReflCo co = WpHole + | otherwise = ASSERT2(tcCoercionRole co == Nominal, ppr co) + WpCast (mkTcSubCo co) + -- The mkTcSubCo converts Nominal to Representational + +mkWpTyApps :: [Type] -> HsWrapper +mkWpTyApps tys = mk_co_app_fn WpTyApp tys + +mkWpEvApps :: [EvTerm] -> HsWrapper +mkWpEvApps args = mk_co_app_fn WpEvApp args + +mkWpEvVarApps :: [EvVar] -> HsWrapper +mkWpEvVarApps vs = mk_co_app_fn WpEvApp (map (EvExpr . evId) vs) + +mkWpTyLams :: [TyVar] -> HsWrapper +mkWpTyLams ids = mk_co_lam_fn WpTyLam ids + +mkWpLams :: [Var] -> HsWrapper +mkWpLams ids = mk_co_lam_fn WpEvLam ids + +mkWpLet :: TcEvBinds -> HsWrapper +-- This no-op is a quite a common case +mkWpLet (EvBinds b) | isEmptyBag b = WpHole +mkWpLet ev_binds = WpLet ev_binds + +mk_co_lam_fn :: (a -> HsWrapper) -> [a] -> HsWrapper +mk_co_lam_fn f as = foldr (\x wrap -> f x <.> wrap) WpHole as + +mk_co_app_fn :: (a -> HsWrapper) -> [a] -> HsWrapper +-- For applications, the *first* argument must +-- come *last* in the composition sequence +mk_co_app_fn f as = foldr (\x wrap -> wrap <.> f x) WpHole as + +idHsWrapper :: HsWrapper +idHsWrapper = WpHole + +isIdHsWrapper :: HsWrapper -> Bool +isIdHsWrapper WpHole = True +isIdHsWrapper _ = False + +collectHsWrapBinders :: HsWrapper -> ([Var], HsWrapper) +-- Collect the outer lambda binders of a HsWrapper, +-- stopping as soon as you get to a non-lambda binder +collectHsWrapBinders wrap = go wrap [] + where + -- go w ws = collectHsWrapBinders (w <.> w1 <.> ... <.> wn) + go :: HsWrapper -> [HsWrapper] -> ([Var], HsWrapper) + go (WpEvLam v) wraps = add_lam v (gos wraps) + go (WpTyLam v) wraps = add_lam v (gos wraps) + go (WpCompose w1 w2) wraps = go w1 (w2:wraps) + go wrap wraps = ([], foldl' (<.>) wrap wraps) + + gos [] = ([], WpHole) + gos (w:ws) = go w ws + + add_lam v (vs,w) = (v:vs, w) + +{- +************************************************************************ +* * + Evidence bindings +* * +************************************************************************ +-} + +data TcEvBinds + = TcEvBinds -- Mutable evidence bindings + EvBindsVar -- Mutable because they are updated "later" + -- when an implication constraint is solved + + | EvBinds -- Immutable after zonking + (Bag EvBind) + +data EvBindsVar + = EvBindsVar { + ebv_uniq :: Unique, + -- The Unique is for debug printing only + + ebv_binds :: IORef EvBindMap, + -- The main payload: the value-level evidence bindings + -- (dictionaries etc) + -- Some Given, some Wanted + + ebv_tcvs :: IORef CoVarSet + -- The free Given coercion vars needed by Wanted coercions that + -- are solved by filling in their HoleDest in-place. Since they + -- don't appear in ebv_binds, we keep track of their free + -- variables so that we can report unused given constraints + -- See Note [Tracking redundant constraints] in TcSimplify + } + + | CoEvBindsVar { -- See Note [Coercion evidence only] + + -- See above for comments on ebv_uniq, ebv_tcvs + ebv_uniq :: Unique, + ebv_tcvs :: IORef CoVarSet + } + +instance Data.Data TcEvBinds where + -- Placeholder; we can't travers into TcEvBinds + toConstr _ = abstractConstr "TcEvBinds" + gunfold _ _ = error "gunfold" + dataTypeOf _ = Data.mkNoRepType "TcEvBinds" + +{- Note [Coercion evidence only] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Class constraints etc give rise to /term/ bindings for evidence, and +we have nowhere to put term bindings in /types/. So in some places we +use CoEvBindsVar (see newCoTcEvBinds) to signal that no term-level +evidence bindings are allowed. Notebly (): + + - Places in types where we are solving kind constraints (all of which + are equalities); see solveEqualities, solveLocalEqualities, + checkTvConstraints + + - When unifying forall-types +-} + +isCoEvBindsVar :: EvBindsVar -> Bool +isCoEvBindsVar (CoEvBindsVar {}) = True +isCoEvBindsVar (EvBindsVar {}) = False + +----------------- +newtype EvBindMap + = EvBindMap { + ev_bind_varenv :: DVarEnv EvBind + } -- Map from evidence variables to evidence terms + -- We use @DVarEnv@ here to get deterministic ordering when we + -- turn it into a Bag. + -- If we don't do that, when we generate let bindings for + -- dictionaries in dsTcEvBinds they will be generated in random + -- order. + -- + -- For example: + -- + -- let $dEq = GHC.Classes.$fEqInt in + -- let $$dNum = GHC.Num.$fNumInt in ... + -- + -- vs + -- + -- let $dNum = GHC.Num.$fNumInt in + -- let $dEq = GHC.Classes.$fEqInt in ... + -- + -- See Note [Deterministic UniqFM] in UniqDFM for explanation why + -- @UniqFM@ can lead to nondeterministic order. + +emptyEvBindMap :: EvBindMap +emptyEvBindMap = EvBindMap { ev_bind_varenv = emptyDVarEnv } + +extendEvBinds :: EvBindMap -> EvBind -> EvBindMap +extendEvBinds bs ev_bind + = EvBindMap { ev_bind_varenv = extendDVarEnv (ev_bind_varenv bs) + (eb_lhs ev_bind) + ev_bind } + +isEmptyEvBindMap :: EvBindMap -> Bool +isEmptyEvBindMap (EvBindMap m) = isEmptyDVarEnv m + +lookupEvBind :: EvBindMap -> EvVar -> Maybe EvBind +lookupEvBind bs = lookupDVarEnv (ev_bind_varenv bs) + +evBindMapBinds :: EvBindMap -> Bag EvBind +evBindMapBinds = foldEvBindMap consBag emptyBag + +foldEvBindMap :: (EvBind -> a -> a) -> a -> EvBindMap -> a +foldEvBindMap k z bs = foldDVarEnv k z (ev_bind_varenv bs) + +filterEvBindMap :: (EvBind -> Bool) -> EvBindMap -> EvBindMap +filterEvBindMap k (EvBindMap { ev_bind_varenv = env }) + = EvBindMap { ev_bind_varenv = filterDVarEnv k env } + +instance Outputable EvBindMap where + ppr (EvBindMap m) = ppr m + +----------------- +-- All evidence is bound by EvBinds; no side effects +data EvBind + = EvBind { eb_lhs :: EvVar + , eb_rhs :: EvTerm + , eb_is_given :: Bool -- True <=> given + -- See Note [Tracking redundant constraints] in TcSimplify + } + +evBindVar :: EvBind -> EvVar +evBindVar = eb_lhs + +mkWantedEvBind :: EvVar -> EvTerm -> EvBind +mkWantedEvBind ev tm = EvBind { eb_is_given = False, eb_lhs = ev, eb_rhs = tm } + +-- EvTypeable are never given, so we can work with EvExpr here instead of EvTerm +mkGivenEvBind :: EvVar -> EvTerm -> EvBind +mkGivenEvBind ev tm = EvBind { eb_is_given = True, eb_lhs = ev, eb_rhs = tm } + + +-- An EvTerm is, conceptually, a CoreExpr that implements the constraint. +-- Unfortunately, we cannot just do +-- type EvTerm = CoreExpr +-- Because of staging problems issues around EvTypeable +data EvTerm + = EvExpr EvExpr + + | EvTypeable Type EvTypeable -- Dictionary for (Typeable ty) + + | EvFun -- /\as \ds. let binds in v + { et_tvs :: [TyVar] + , et_given :: [EvVar] + , et_binds :: TcEvBinds -- This field is why we need an EvFun + -- constructor, and can't just use EvExpr + , et_body :: EvVar } + + deriving Data.Data + +type EvExpr = CoreExpr + +-- An EvTerm is (usually) constructed by any of the constructors here +-- and those more complicates ones who were moved to module TcEvTerm + +-- | Any sort of evidence Id, including coercions +evId :: EvId -> EvExpr +evId = Var + +-- coercion bindings +-- See Note [Coercion evidence terms] +evCoercion :: TcCoercion -> EvTerm +evCoercion co = EvExpr (Coercion co) + +-- | d |> co +evCast :: EvExpr -> TcCoercion -> EvTerm +evCast et tc | isReflCo tc = EvExpr et + | otherwise = EvExpr (Cast et tc) + +-- Dictionary instance application +evDFunApp :: DFunId -> [Type] -> [EvExpr] -> EvTerm +evDFunApp df tys ets = EvExpr $ Var df `mkTyApps` tys `mkApps` ets + +evDataConApp :: DataCon -> [Type] -> [EvExpr] -> EvTerm +evDataConApp dc tys ets = evDFunApp (dataConWrapId dc) tys ets + +-- Selector id plus the types at which it +-- should be instantiated, used for HasField +-- dictionaries; see Note [HasField instances] +-- in TcInterface +evSelector :: Id -> [Type] -> [EvExpr] -> EvExpr +evSelector sel_id tys tms = Var sel_id `mkTyApps` tys `mkApps` tms + +-- Dictionary for (Typeable ty) +evTypeable :: Type -> EvTypeable -> EvTerm +evTypeable = EvTypeable + +-- | Instructions on how to make a 'Typeable' dictionary. +-- See Note [Typeable evidence terms] +data EvTypeable + = EvTypeableTyCon TyCon [EvTerm] + -- ^ Dictionary for @Typeable T@ where @T@ is a type constructor with all of + -- its kind variables saturated. The @[EvTerm]@ is @Typeable@ evidence for + -- the applied kinds.. + + | EvTypeableTyApp EvTerm EvTerm + -- ^ Dictionary for @Typeable (s t)@, + -- given a dictionaries for @s@ and @t@. + + | EvTypeableTrFun EvTerm EvTerm + -- ^ Dictionary for @Typeable (s -> t)@, + -- given a dictionaries for @s@ and @t@. + + | EvTypeableTyLit EvTerm + -- ^ Dictionary for a type literal, + -- e.g. @Typeable "foo"@ or @Typeable 3@ + -- The 'EvTerm' is evidence of, e.g., @KnownNat 3@ + -- (see #10348) + deriving Data.Data + +-- | Evidence for @CallStack@ implicit parameters. +data EvCallStack + -- See Note [Overview of implicit CallStacks] + = EvCsEmpty + | EvCsPushCall Name RealSrcSpan EvExpr + -- ^ @EvCsPushCall name loc stk@ represents a call to @name@, occurring at + -- @loc@, in a calling context @stk@. + deriving Data.Data + +{- +Note [Typeable evidence terms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The EvTypeable data type looks isomorphic to Type, but the EvTerms +inside can be EvIds. Eg + f :: forall a. Typeable a => a -> TypeRep + f x = typeRep (undefined :: Proxy [a]) +Here for the (Typeable [a]) dictionary passed to typeRep we make +evidence + dl :: Typeable [a] = EvTypeable [a] + (EvTypeableTyApp (EvTypeableTyCon []) (EvId d)) +where + d :: Typable a +is the lambda-bound dictionary passed into f. + +Note [Coercion evidence terms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A "coercion evidence term" takes one of these forms + co_tm ::= EvId v where v :: t1 ~# t2 + | EvCoercion co + | EvCast co_tm co + +We do quite often need to get a TcCoercion from an EvTerm; see +'evTermCoercion'. + +INVARIANT: The evidence for any constraint with type (t1 ~# t2) is +a coercion evidence term. Consider for example + [G] d :: F Int a +If we have + ax7 a :: F Int a ~ (a ~ Bool) +then we do NOT generate the constraint + [G] (d |> ax7 a) :: a ~ Bool +because that does not satisfy the invariant (d is not a coercion variable). +Instead we make a binding + g1 :: a~Bool = g |> ax7 a +and the constraint + [G] g1 :: a~Bool +See #7238 and Note [Bind new Givens immediately] in TcRnTypes + +Note [EvBinds/EvTerm] +~~~~~~~~~~~~~~~~~~~~~ +How evidence is created and updated. Bindings for dictionaries, +and coercions and implicit parameters are carried around in TcEvBinds +which during constraint generation and simplification is always of the +form (TcEvBinds ref). After constraint simplification is finished it +will be transformed to t an (EvBinds ev_bag). + +Evidence for coercions *SHOULD* be filled in using the TcEvBinds +However, all EvVars that correspond to *wanted* coercion terms in +an EvBind must be mutable variables so that they can be readily +inlined (by zonking) after constraint simplification is finished. + +Conclusion: a new wanted coercion variable should be made mutable. +[Notice though that evidence variables that bind coercion terms + from super classes will be "given" and hence rigid] + + +Note [Overview of implicit CallStacks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(See https://gitlab.haskell.org/ghc/ghc/wikis/explicit-call-stack/implicit-locations) + +The goal of CallStack evidence terms is to reify locations +in the program source as runtime values, without any support +from the RTS. We accomplish this by assigning a special meaning +to constraints of type GHC.Stack.Types.HasCallStack, an alias + + type HasCallStack = (?callStack :: CallStack) + +Implicit parameters of type GHC.Stack.Types.CallStack (the name is not +important) are solved in three steps: + +1. Occurrences of CallStack IPs are solved directly from the given IP, + just like a regular IP. For example, the occurrence of `?stk` in + + error :: (?stk :: CallStack) => String -> a + error s = raise (ErrorCall (s ++ prettyCallStack ?stk)) + + will be solved for the `?stk` in `error`s context as before. + +2. In a function call, instead of simply passing the given IP, we first + append the current call-site to it. For example, consider a + call to the callstack-aware `error` above. + + undefined :: (?stk :: CallStack) => a + undefined = error "undefined!" + + Here we want to take the given `?stk` and append the current + call-site, before passing it to `error`. In essence, we want to + rewrite `error "undefined!"` to + + let ?stk = pushCallStack ?stk + in error "undefined!" + + We achieve this effect by emitting a NEW wanted + + [W] d :: IP "stk" CallStack + + from which we build the evidence term + + EvCsPushCall "error" (EvId d) + + that we use to solve the call to `error`. The new wanted `d` will + then be solved per rule (1), ie as a regular IP. + + (see TcInteract.interactDict) + +3. We default any insoluble CallStacks to the empty CallStack. Suppose + `undefined` did not request a CallStack, ie + + undefinedNoStk :: a + undefinedNoStk = error "undefined!" + + Under the usual IP rules, the new wanted from rule (2) would be + insoluble as there's no given IP from which to solve it, so we + would get an "unbound implicit parameter" error. + + We don't ever want to emit an insoluble CallStack IP, so we add a + defaulting pass to default any remaining wanted CallStacks to the + empty CallStack with the evidence term + + EvCsEmpty + + (see TcSimplify.simpl_top and TcSimplify.defaultCallStacks) + +This provides a lightweight mechanism for building up call-stacks +explicitly, but is notably limited by the fact that the stack will +stop at the first function whose type does not include a CallStack IP. +For example, using the above definition of `undefined`: + + head :: [a] -> a + head [] = undefined + head (x:_) = x + + g = head [] + +the resulting CallStack will include the call to `undefined` in `head` +and the call to `error` in `undefined`, but *not* the call to `head` +in `g`, because `head` did not explicitly request a CallStack. + + +Important Details: +- GHC should NEVER report an insoluble CallStack constraint. + +- GHC should NEVER infer a CallStack constraint unless one was requested + with a partial type signature (See TcType.pickQuantifiablePreds). + +- A CallStack (defined in GHC.Stack.Types) is a [(String, SrcLoc)], + where the String is the name of the binder that is used at the + SrcLoc. SrcLoc is also defined in GHC.Stack.Types and contains the + package/module/file name, as well as the full source-span. Both + CallStack and SrcLoc are kept abstract so only GHC can construct new + values. + +- We will automatically solve any wanted CallStack regardless of the + name of the IP, i.e. + + f = show (?stk :: CallStack) + g = show (?loc :: CallStack) + + are both valid. However, we will only push new SrcLocs onto existing + CallStacks when the IP names match, e.g. in + + head :: (?loc :: CallStack) => [a] -> a + head [] = error (show (?stk :: CallStack)) + + the printed CallStack will NOT include head's call-site. This reflects the + standard scoping rules of implicit-parameters. + +- An EvCallStack term desugars to a CoreExpr of type `IP "some str" CallStack`. + The desugarer will need to unwrap the IP newtype before pushing a new + call-site onto a given stack (See DsBinds.dsEvCallStack) + +- When we emit a new wanted CallStack from rule (2) we set its origin to + `IPOccOrigin ip_name` instead of the original `OccurrenceOf func` + (see TcInteract.interactDict). + + This is a bit shady, but is how we ensure that the new wanted is + solved like a regular IP. + +-} + +mkEvCast :: EvExpr -> TcCoercion -> EvTerm +mkEvCast ev lco + | ASSERT2( tcCoercionRole lco == Representational + , (vcat [text "Coercion of wrong role passed to mkEvCast:", ppr ev, ppr lco])) + isTcReflCo lco = EvExpr ev + | otherwise = evCast ev lco + + +mkEvScSelectors -- Assume class (..., D ty, ...) => C a b + :: Class -> [TcType] -- C ty1 ty2 + -> [(TcPredType, -- D ty[ty1/a,ty2/b] + EvExpr) -- :: C ty1 ty2 -> D ty[ty1/a,ty2/b] + ] +mkEvScSelectors cls tys + = zipWith mk_pr (immSuperClasses cls tys) [0..] + where + mk_pr pred i = (pred, Var sc_sel_id `mkTyApps` tys) + where + sc_sel_id = classSCSelId cls i -- Zero-indexed + +emptyTcEvBinds :: TcEvBinds +emptyTcEvBinds = EvBinds emptyBag + +isEmptyTcEvBinds :: TcEvBinds -> Bool +isEmptyTcEvBinds (EvBinds b) = isEmptyBag b +isEmptyTcEvBinds (TcEvBinds {}) = panic "isEmptyTcEvBinds" + +evTermCoercion_maybe :: EvTerm -> Maybe TcCoercion +-- Applied only to EvTerms of type (s~t) +-- See Note [Coercion evidence terms] +evTermCoercion_maybe ev_term + | EvExpr e <- ev_term = go e + | otherwise = Nothing + where + go :: EvExpr -> Maybe TcCoercion + go (Var v) = return (mkCoVarCo v) + go (Coercion co) = return co + go (Cast tm co) = do { co' <- go tm + ; return (mkCoCast co' co) } + go _ = Nothing + +evTermCoercion :: EvTerm -> TcCoercion +evTermCoercion tm = case evTermCoercion_maybe tm of + Just co -> co + Nothing -> pprPanic "evTermCoercion" (ppr tm) + + +{- ********************************************************************* +* * + Free variables +* * +********************************************************************* -} + +findNeededEvVars :: EvBindMap -> VarSet -> VarSet +-- Find all the Given evidence needed by seeds, +-- looking transitively through binds +findNeededEvVars ev_binds seeds + = transCloVarSet also_needs seeds + where + also_needs :: VarSet -> VarSet + also_needs needs = nonDetFoldUniqSet add emptyVarSet needs + -- It's OK to use nonDetFoldUFM here because we immediately + -- forget about the ordering by creating a set + + add :: Var -> VarSet -> VarSet + add v needs + | Just ev_bind <- lookupEvBind ev_binds v + , EvBind { eb_is_given = is_given, eb_rhs = rhs } <- ev_bind + , is_given + = evVarsOfTerm rhs `unionVarSet` needs + | otherwise + = needs + +evVarsOfTerm :: EvTerm -> VarSet +evVarsOfTerm (EvExpr e) = exprSomeFreeVars isEvVar e +evVarsOfTerm (EvTypeable _ ev) = evVarsOfTypeable ev +evVarsOfTerm (EvFun {}) = emptyVarSet -- See Note [Free vars of EvFun] + +evVarsOfTerms :: [EvTerm] -> VarSet +evVarsOfTerms = mapUnionVarSet evVarsOfTerm + +evVarsOfTypeable :: EvTypeable -> VarSet +evVarsOfTypeable ev = + case ev of + EvTypeableTyCon _ e -> mapUnionVarSet evVarsOfTerm e + EvTypeableTyApp e1 e2 -> evVarsOfTerms [e1,e2] + EvTypeableTrFun e1 e2 -> evVarsOfTerms [e1,e2] + EvTypeableTyLit e -> evVarsOfTerm e + + +{- Note [Free vars of EvFun] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Finding the free vars of an EvFun is made tricky by the fact the +bindings et_binds may be a mutable variable. Fortunately, we +can just squeeze by. Here's how. + +* evVarsOfTerm is used only by TcSimplify.neededEvVars. +* Each EvBindsVar in an et_binds field of an EvFun is /also/ in the + ic_binds field of an Implication +* So we can track usage via the processing for that implication, + (see Note [Tracking redundant constraints] in TcSimplify). + We can ignore usage from the EvFun altogether. + +************************************************************************ +* * + Pretty printing +* * +************************************************************************ +-} + +instance Outputable HsWrapper where + ppr co_fn = pprHsWrapper co_fn (no_parens (text "<>")) + +pprHsWrapper :: HsWrapper -> (Bool -> SDoc) -> SDoc +-- With -fprint-typechecker-elaboration, print the wrapper +-- otherwise just print what's inside +-- The pp_thing_inside function takes Bool to say whether +-- it's in a position that needs parens for a non-atomic thing +pprHsWrapper wrap pp_thing_inside + = sdocWithDynFlags $ \ dflags -> + if gopt Opt_PrintTypecheckerElaboration dflags + then help pp_thing_inside wrap False + else pp_thing_inside False + where + help :: (Bool -> SDoc) -> HsWrapper -> Bool -> SDoc + -- True <=> appears in function application position + -- False <=> appears as body of let or lambda + help it WpHole = it + help it (WpCompose f1 f2) = help (help it f2) f1 + help it (WpFun f1 f2 t1 _) = add_parens $ text "\\(x" <> dcolon <> ppr t1 <> text ")." <+> + help (\_ -> it True <+> help (\_ -> text "x") f1 True) f2 False + help it (WpCast co) = add_parens $ sep [it False, nest 2 (text "|>" + <+> pprParendCo co)] + help it (WpEvApp id) = no_parens $ sep [it True, nest 2 (ppr id)] + help it (WpTyApp ty) = no_parens $ sep [it True, text "@" <+> pprParendType ty] + help it (WpEvLam id) = add_parens $ sep [ text "\\" <> pprLamBndr id <> dot, it False] + help it (WpTyLam tv) = add_parens $ sep [text "/\\" <> pprLamBndr tv <> dot, it False] + help it (WpLet binds) = add_parens $ sep [text "let" <+> braces (ppr binds), it False] + +pprLamBndr :: Id -> SDoc +pprLamBndr v = pprBndr LambdaBind v + +add_parens, no_parens :: SDoc -> Bool -> SDoc +add_parens d True = parens d +add_parens d False = d +no_parens d _ = d + +instance Outputable TcEvBinds where + ppr (TcEvBinds v) = ppr v + ppr (EvBinds bs) = text "EvBinds" <> braces (vcat (map ppr (bagToList bs))) + +instance Outputable EvBindsVar where + ppr (EvBindsVar { ebv_uniq = u }) + = text "EvBindsVar" <> angleBrackets (ppr u) + ppr (CoEvBindsVar { ebv_uniq = u }) + = text "CoEvBindsVar" <> angleBrackets (ppr u) + +instance Uniquable EvBindsVar where + getUnique = ebv_uniq + +instance Outputable EvBind where + ppr (EvBind { eb_lhs = v, eb_rhs = e, eb_is_given = is_given }) + = sep [ pp_gw <+> ppr v + , nest 2 $ equals <+> ppr e ] + where + pp_gw = brackets (if is_given then char 'G' else char 'W') + -- We cheat a bit and pretend EqVars are CoVars for the purposes of pretty printing + +instance Outputable EvTerm where + ppr (EvExpr e) = ppr e + ppr (EvTypeable ty ev) = ppr ev <+> dcolon <+> text "Typeable" <+> ppr ty + ppr (EvFun { et_tvs = tvs, et_given = gs, et_binds = bs, et_body = w }) + = hang (text "\\" <+> sep (map pprLamBndr (tvs ++ gs)) <+> arrow) + 2 (ppr bs $$ ppr w) -- Not very pretty + +instance Outputable EvCallStack where + ppr EvCsEmpty + = text "[]" + ppr (EvCsPushCall name loc tm) + = ppr (name,loc) <+> text ":" <+> ppr tm + +instance Outputable EvTypeable where + ppr (EvTypeableTyCon ts _) = text "TyCon" <+> ppr ts + ppr (EvTypeableTyApp t1 t2) = parens (ppr t1 <+> ppr t2) + ppr (EvTypeableTrFun t1 t2) = parens (ppr t1 <+> arrow <+> ppr t2) + ppr (EvTypeableTyLit t1) = text "TyLit" <> ppr t1 + + +---------------------------------------------------------------------- +-- Helper functions for dealing with IP newtype-dictionaries +---------------------------------------------------------------------- + +-- | Create a 'Coercion' that unwraps an implicit-parameter or +-- overloaded-label dictionary to expose the underlying value. We +-- expect the 'Type' to have the form `IP sym ty` or `IsLabel sym ty`, +-- and return a 'Coercion' `co :: IP sym ty ~ ty` or +-- `co :: IsLabel sym ty ~ Proxy# sym -> ty`. See also +-- Note [Type-checking overloaded labels] in TcExpr. +unwrapIP :: Type -> CoercionR +unwrapIP ty = + case unwrapNewTyCon_maybe tc of + Just (_,_,ax) -> mkUnbranchedAxInstCo Representational ax tys [] + Nothing -> pprPanic "unwrapIP" $ + text "The dictionary for" <+> quotes (ppr tc) + <+> text "is not a newtype!" + where + (tc, tys) = splitTyConApp ty + +-- | Create a 'Coercion' that wraps a value in an implicit-parameter +-- dictionary. See 'unwrapIP'. +wrapIP :: Type -> CoercionR +wrapIP ty = mkSymCo (unwrapIP ty) diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs new file mode 100644 --- /dev/null +++ b/compiler/typecheck/TcRnTypes.hs @@ -0,0 +1,3918 @@ +{- +(c) The University of Glasgow 2006-2012 +(c) The GRASP Project, Glasgow University, 1992-2002 + + +Various types used during typechecking, please see TcRnMonad as well for +operations on these types. You probably want to import it, instead of this +module. + +All the monads exported here are built on top of the same IOEnv monad. The +monad functions like a Reader monad in the way it passes the environment +around. This is done to allow the environment to be manipulated in a stack +like fashion when entering expressions... etc. + +For state that is global and should be returned at the end (e.g not part +of the stack mechanism), you should use a TcRef (= IORef) to store them. +-} + +{-# LANGUAGE CPP, ExistentialQuantification, GeneralizedNewtypeDeriving, + ViewPatterns #-} + +module TcRnTypes( + TcRnIf, TcRn, TcM, RnM, IfM, IfL, IfG, -- The monad is opaque outside this module + TcRef, + + -- The environment types + Env(..), + TcGblEnv(..), TcLclEnv(..), + IfGblEnv(..), IfLclEnv(..), + tcVisibleOrphanMods, + + -- Frontend types (shouldn't really be here) + FrontendResult(..), + + -- Renamer types + ErrCtxt, RecFieldEnv, + ImportAvails(..), emptyImportAvails, plusImportAvails, + WhereFrom(..), mkModDeps, modDepsElts, + + -- Typechecker types + TcTypeEnv, TcBinderStack, TcBinder(..), + TcTyThing(..), PromotionErr(..), + IdBindingInfo(..), ClosedTypeId, RhsNames, + IsGroupClosed(..), + SelfBootInfo(..), + pprTcTyThingCategory, pprPECategory, CompleteMatch(..), + + -- Desugaring types + DsM, DsLclEnv(..), DsGblEnv(..), + DsMetaEnv, DsMetaVal(..), CompleteMatchMap, + mkCompleteMatchMap, extendCompleteMatchMap, + + -- Template Haskell + ThStage(..), SpliceType(..), PendingStuff(..), + topStage, topAnnStage, topSpliceStage, + ThLevel, impLevel, outerLevel, thLevel, + ForeignSrcLang(..), + + -- Arrows + ArrowCtxt(..), + + -- TcSigInfo + TcSigFun, TcSigInfo(..), TcIdSigInfo(..), + TcIdSigInst(..), TcPatSynInfo(..), + isPartialSig, hasCompleteSig, + + -- QCInst + QCInst(..), isPendingScInst, + + -- Canonical constraints + Xi, Ct(..), Cts, emptyCts, andCts, andManyCts, pprCts, + singleCt, listToCts, ctsElts, consCts, snocCts, extendCtsList, + isEmptyCts, isCTyEqCan, isCFunEqCan, + isPendingScDict, superClassesMightHelp, getPendingWantedScs, + isCDictCan_Maybe, isCFunEqCan_maybe, + isCNonCanonical, isWantedCt, isDerivedCt, + isGivenCt, isHoleCt, isOutOfScopeCt, isExprHoleCt, isTypeHoleCt, + isUserTypeErrorCt, getUserTypeErrorMsg, + ctEvidence, ctLoc, setCtLoc, ctPred, ctFlavour, ctEqRel, ctOrigin, + ctEvId, mkTcEqPredLikeEv, + mkNonCanonical, mkNonCanonicalCt, mkGivens, + mkIrredCt, mkInsolubleCt, + ctEvPred, ctEvLoc, ctEvOrigin, ctEvEqRel, + ctEvExpr, ctEvTerm, ctEvCoercion, ctEvEvId, + tyCoVarsOfCt, tyCoVarsOfCts, + tyCoVarsOfCtList, tyCoVarsOfCtsList, + + WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC, + isSolvedWC, andWC, unionsWC, mkSimpleWC, mkImplicWC, + addInsols, insolublesOnly, addSimples, addImplics, + tyCoVarsOfWC, dropDerivedWC, dropDerivedSimples, + tyCoVarsOfWCList, insolubleCt, insolubleEqCt, + isDroppableCt, insolubleImplic, + arisesFromGivens, + + Implication(..), newImplication, implicationPrototype, + implicLclEnv, implicDynFlags, + ImplicStatus(..), isInsolubleStatus, isSolvedStatus, + SubGoalDepth, initialSubGoalDepth, maxSubGoalDepth, + bumpSubGoalDepth, subGoalDepthExceeded, + CtLoc(..), ctLocSpan, ctLocEnv, ctLocLevel, ctLocOrigin, + ctLocTypeOrKind_maybe, + ctLocDepth, bumpCtLocDepth, isGivenLoc, + setCtLocOrigin, updateCtLocOrigin, setCtLocEnv, setCtLocSpan, + CtOrigin(..), exprCtOrigin, lexprCtOrigin, matchesCtOrigin, grhssCtOrigin, + isVisibleOrigin, toInvisibleOrigin, + TypeOrKind(..), isTypeLevel, isKindLevel, + pprCtOrigin, pprCtLoc, + pushErrCtxt, pushErrCtxtSameOrigin, + + + SkolemInfo(..), pprSigSkolInfo, pprSkolInfo, + + CtEvidence(..), TcEvDest(..), + mkKindLoc, toKindLoc, mkGivenLoc, + isWanted, isGiven, isDerived, isGivenOrWDeriv, + ctEvRole, + + wrapType, wrapTypeWithImplication, + removeBindingShadowing, + + -- Constraint solver plugins + TcPlugin(..), TcPluginResult(..), TcPluginSolver, + TcPluginM, runTcPluginM, unsafeTcPluginTcM, + getEvBindsTcPluginM, + + CtFlavour(..), ShadowInfo(..), ctEvFlavour, + CtFlavourRole, ctEvFlavourRole, ctFlavourRole, + eqCanRewrite, eqCanRewriteFR, eqMayRewriteFR, + eqCanDischargeFR, + funEqCanDischarge, funEqCanDischargeF, + + -- Pretty printing + pprEvVarTheta, + pprEvVars, pprEvVarWithType, + + -- Misc other types + TcId, TcIdSet, + Hole(..), holeOcc, + NameShape(..), + + -- Role annotations + RoleAnnotEnv, emptyRoleAnnotEnv, mkRoleAnnotEnv, + lookupRoleAnnot, getRoleAnnots, + + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import HsSyn +import CoreSyn +import HscTypes +import TcEvidence +import Type +import Class ( Class ) +import TyCon ( TyCon, TyConFlavour, tyConKind ) +import TyCoRep ( coHoleCoVar ) +import Coercion ( Coercion, mkHoleCo ) +import ConLike ( ConLike(..) ) +import DataCon ( DataCon, dataConUserType, dataConOrigArgTys ) +import PatSyn ( PatSyn, pprPatSynType ) +import Id ( idType, idName ) +import FieldLabel ( FieldLabel ) +import TcType +import Annotations +import InstEnv +import FamInstEnv +import PmExpr +import IOEnv +import RdrName +import Name +import NameEnv +import NameSet +import Avail +import Var +import FV +import VarEnv +import Module +import SrcLoc +import VarSet +import ErrUtils +import UniqFM +import UniqSupply +import BasicTypes +import Bag +import DynFlags +import Outputable +import ListSetOps +import FastString +import qualified GHC.LanguageExtensions as LangExt +import Fingerprint +import Util +import PrelNames ( isUnboundName ) +import CostCentreState + +import Control.Monad (ap, liftM, msum) +import qualified Control.Monad.Fail as MonadFail +import Data.Set ( Set ) +import qualified Data.Set as S + +import Data.List ( sort ) +import Data.Map ( Map ) +import Data.Dynamic ( Dynamic ) +import Data.Typeable ( TypeRep ) +import Data.Maybe ( mapMaybe ) +import GHCi.Message +import GHCi.RemoteTypes + +import qualified Language.Haskell.TH as TH + +-- | A 'NameShape' is a substitution on 'Name's that can be used +-- to refine the identities of a hole while we are renaming interfaces +-- (see 'RnModIface'). Specifically, a 'NameShape' for +-- 'ns_module_name' @A@, defines a mapping from @{A.T}@ +-- (for some 'OccName' @T@) to some arbitrary other 'Name'. +-- +-- The most intruiging thing about a 'NameShape', however, is +-- how it's constructed. A 'NameShape' is *implied* by the +-- exported 'AvailInfo's of the implementor of an interface: +-- if an implementor of signature @@ exports @M.T@, you implicitly +-- define a substitution from @{H.T}@ to @M.T@. So a 'NameShape' +-- is computed from the list of 'AvailInfo's that are exported +-- by the implementation of a module, or successively merged +-- together by the export lists of signatures which are joining +-- together. +-- +-- It's not the most obvious way to go about doing this, but it +-- does seem to work! +-- +-- NB: Can't boot this and put it in NameShape because then we +-- start pulling in too many DynFlags things. +data NameShape = NameShape { + ns_mod_name :: ModuleName, + ns_exports :: [AvailInfo], + ns_map :: OccEnv Name + } + + +{- +************************************************************************ +* * + Standard monad definition for TcRn + All the combinators for the monad can be found in TcRnMonad +* * +************************************************************************ + +The monad itself has to be defined here, because it is mentioned by ErrCtxt +-} + +type TcRnIf a b = IOEnv (Env a b) +type TcRn = TcRnIf TcGblEnv TcLclEnv -- Type inference +type IfM lcl = TcRnIf IfGblEnv lcl -- Iface stuff +type IfG = IfM () -- Top level +type IfL = IfM IfLclEnv -- Nested +type DsM = TcRnIf DsGblEnv DsLclEnv -- Desugaring + +-- TcRn is the type-checking and renaming monad: the main monad that +-- most type-checking takes place in. The global environment is +-- 'TcGblEnv', which tracks all of the top-level type-checking +-- information we've accumulated while checking a module, while the +-- local environment is 'TcLclEnv', which tracks local information as +-- we move inside expressions. + +-- | Historical "renaming monad" (now it's just 'TcRn'). +type RnM = TcRn + +-- | Historical "type-checking monad" (now it's just 'TcRn'). +type TcM = TcRn + +-- We 'stack' these envs through the Reader like monad infrastructure +-- as we move into an expression (although the change is focused in +-- the lcl type). +data Env gbl lcl + = Env { + env_top :: !HscEnv, -- Top-level stuff that never changes + -- Includes all info about imported things + -- BangPattern is to fix leak, see #15111 + + env_us :: {-# UNPACK #-} !(IORef UniqSupply), + -- Unique supply for local variables + + env_gbl :: gbl, -- Info about things defined at the top level + -- of the module being compiled + + env_lcl :: lcl -- Nested stuff; changes as we go into + } + +instance ContainsDynFlags (Env gbl lcl) where + extractDynFlags env = hsc_dflags (env_top env) + +instance ContainsModule gbl => ContainsModule (Env gbl lcl) where + extractModule env = extractModule (env_gbl env) + + +{- +************************************************************************ +* * + The interface environments + Used when dealing with IfaceDecls +* * +************************************************************************ +-} + +data IfGblEnv + = IfGblEnv { + -- Some information about where this environment came from; + -- useful for debugging. + if_doc :: SDoc, + -- The type environment for the module being compiled, + -- in case the interface refers back to it via a reference that + -- was originally a hi-boot file. + -- We need the module name so we can test when it's appropriate + -- to look in this env. + -- See Note [Tying the knot] in TcIface + if_rec_types :: Maybe (Module, IfG TypeEnv) + -- Allows a read effect, so it can be in a mutable + -- variable; c.f. handling the external package type env + -- Nothing => interactive stuff, no loops possible + } + +data IfLclEnv + = IfLclEnv { + -- The module for the current IfaceDecl + -- So if we see f = \x -> x + -- it means M.f = \x -> x, where M is the if_mod + -- NB: This is a semantic module, see + -- Note [Identity versus semantic module] + if_mod :: Module, + + -- Whether or not the IfaceDecl came from a boot + -- file or not; we'll use this to choose between + -- NoUnfolding and BootUnfolding + if_boot :: Bool, + + -- The field is used only for error reporting + -- if (say) there's a Lint error in it + if_loc :: SDoc, + -- Where the interface came from: + -- .hi file, or GHCi state, or ext core + -- plus which bit is currently being examined + + if_nsubst :: Maybe NameShape, + + -- This field is used to make sure "implicit" declarations + -- (anything that cannot be exported in mi_exports) get + -- wired up correctly in typecheckIfacesForMerging. Most + -- of the time it's @Nothing@. See Note [Resolving never-exported Names in TcIface] + -- in TcIface. + if_implicits_env :: Maybe TypeEnv, + + if_tv_env :: FastStringEnv TyVar, -- Nested tyvar bindings + if_id_env :: FastStringEnv Id -- Nested id binding + } + +{- +************************************************************************ +* * + Desugarer monad +* * +************************************************************************ + +Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around +a @UniqueSupply@ and some annotations, which +presumably include source-file location information: +-} + +data DsGblEnv + = DsGblEnv + { ds_mod :: Module -- For SCC profiling + , ds_fam_inst_env :: FamInstEnv -- Like tcg_fam_inst_env + , ds_unqual :: PrintUnqualified + , ds_msgs :: IORef Messages -- Warning messages + , ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global, + -- possibly-imported things + , ds_complete_matches :: CompleteMatchMap + -- Additional complete pattern matches + , ds_cc_st :: IORef CostCentreState + -- Tracking indices for cost centre annotations + } + +instance ContainsModule DsGblEnv where + extractModule = ds_mod + +data DsLclEnv = DsLclEnv { + dsl_meta :: DsMetaEnv, -- Template Haskell bindings + dsl_loc :: RealSrcSpan, -- To put in pattern-matching error msgs + + -- See Note [Note [Type and Term Equality Propagation] in Check.hs + -- These two fields are augmented as we walk inwards, + -- through each patttern match in turn + dsl_dicts :: Bag EvVar, -- Constraints from GADT pattern-matching + dsl_tm_cs :: Bag SimpleEq, -- Constraints form term-level pattern matching + + dsl_pm_iter :: IORef Int -- Number of iterations for pmcheck so far + -- We fail if this gets too big + } + +-- Inside [| |] brackets, the desugarer looks +-- up variables in the DsMetaEnv +type DsMetaEnv = NameEnv DsMetaVal + +data DsMetaVal + = DsBound Id -- Bound by a pattern inside the [| |]. + -- Will be dynamically alpha renamed. + -- The Id has type THSyntax.Var + + | DsSplice (HsExpr GhcTc) -- These bindings are introduced by + -- the PendingSplices on a HsBracketOut + + +{- +************************************************************************ +* * + Global typechecker environment +* * +************************************************************************ +-} + +-- | 'FrontendResult' describes the result of running the +-- frontend of a Haskell module. Usually, you'll get +-- a 'FrontendTypecheck', since running the frontend involves +-- typechecking a program, but for an hs-boot merge you'll +-- just get a ModIface, since no actual typechecking occurred. +-- +-- This data type really should be in HscTypes, but it needs +-- to have a TcGblEnv which is only defined here. +data FrontendResult + = FrontendTypecheck TcGblEnv + +-- Note [Identity versus semantic module] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- When typechecking an hsig file, it is convenient to keep track +-- of two different "this module" identifiers: +-- +-- - The IDENTITY module is simply thisPackage + the module +-- name; i.e. it uniquely *identifies* the interface file +-- we're compiling. For example, p[A=]:A is an +-- identity module identifying the requirement named A +-- from library p. +-- +-- - The SEMANTIC module, which is the actual module that +-- this signature is intended to represent (e.g. if +-- we have a identity module p[A=base:Data.IORef]:A, +-- then the semantic module is base:Data.IORef) +-- +-- Which one should you use? +-- +-- - In the desugarer and later phases of compilation, +-- identity and semantic modules coincide, since we never compile +-- signatures (we just generate blank object files for +-- hsig files.) +-- +-- A corrolary of this is that the following invariant holds at any point +-- past desugaring, +-- +-- if I have a Module, this_mod, in hand representing the module +-- currently being compiled, +-- then moduleUnitId this_mod == thisPackage dflags +-- +-- - For any code involving Names, we want semantic modules. +-- See lookupIfaceTop in IfaceEnv, mkIface and addFingerprints +-- in MkIface, and tcLookupGlobal in TcEnv +-- +-- - When reading interfaces, we want the identity module to +-- identify the specific interface we want (such interfaces +-- should never be loaded into the EPS). However, if a +-- hole module is requested, we look for A.hi +-- in the home library we are compiling. (See LoadIface.) +-- Similarly, in RnNames we check for self-imports using +-- identity modules, to allow signatures to import their implementor. +-- +-- - For recompilation avoidance, you want the identity module, +-- since that will actually say the specific interface you +-- want to track (and recompile if it changes) + +-- | 'TcGblEnv' describes the top-level of the module at the +-- point at which the typechecker is finished work. +-- It is this structure that is handed on to the desugarer +-- For state that needs to be updated during the typechecking +-- phase and returned at end, use a 'TcRef' (= 'IORef'). +data TcGblEnv + = TcGblEnv { + tcg_mod :: Module, -- ^ Module being compiled + tcg_semantic_mod :: Module, -- ^ If a signature, the backing module + -- See also Note [Identity versus semantic module] + tcg_src :: HscSource, + -- ^ What kind of module (regular Haskell, hs-boot, hsig) + + tcg_rdr_env :: GlobalRdrEnv, -- ^ Top level envt; used during renaming + tcg_default :: Maybe [Type], + -- ^ Types used for defaulting. @Nothing@ => no @default@ decl + + tcg_fix_env :: FixityEnv, -- ^ Just for things in this module + tcg_field_env :: RecFieldEnv, -- ^ Just for things in this module + -- See Note [The interactive package] in HscTypes + + tcg_type_env :: TypeEnv, + -- ^ Global type env for the module we are compiling now. All + -- TyCons and Classes (for this module) end up in here right away, + -- along with their derived constructors, selectors. + -- + -- (Ids defined in this module start in the local envt, though they + -- move to the global envt during zonking) + -- + -- NB: for what "things in this module" means, see + -- Note [The interactive package] in HscTypes + + tcg_type_env_var :: TcRef TypeEnv, + -- Used only to initialise the interface-file + -- typechecker in initIfaceTcRn, so that it can see stuff + -- bound in this module when dealing with hi-boot recursions + -- Updated at intervals (e.g. after dealing with types and classes) + + tcg_inst_env :: !InstEnv, + -- ^ Instance envt for all /home-package/ modules; + -- Includes the dfuns in tcg_insts + -- NB. BangPattern is to fix a leak, see #15111 + tcg_fam_inst_env :: !FamInstEnv, -- ^ Ditto for family instances + -- NB. BangPattern is to fix a leak, see #15111 + tcg_ann_env :: AnnEnv, -- ^ And for annotations + + -- Now a bunch of things about this module that are simply + -- accumulated, but never consulted until the end. + -- Nevertheless, it's convenient to accumulate them along + -- with the rest of the info from this module. + tcg_exports :: [AvailInfo], -- ^ What is exported + tcg_imports :: ImportAvails, + -- ^ Information about what was imported from where, including + -- things bound in this module. Also store Safe Haskell info + -- here about transitive trusted package requirements. + -- + -- There are not many uses of this field, so you can grep for + -- all them. + -- + -- The ImportAvails records information about the following + -- things: + -- + -- 1. All of the modules you directly imported (tcRnImports) + -- 2. The orphans (only!) of all imported modules in a GHCi + -- session (runTcInteractive) + -- 3. The module that instantiated a signature + -- 4. Each of the signatures that merged in + -- + -- It is used in the following ways: + -- - imp_orphs is used to determine what orphan modules should be + -- visible in the context (tcVisibleOrphanMods) + -- - imp_finsts is used to determine what family instances should + -- be visible (tcExtendLocalFamInstEnv) + -- - To resolve the meaning of the export list of a module + -- (tcRnExports) + -- - imp_mods is used to compute usage info (mkIfaceTc, deSugar) + -- - imp_trust_own_pkg is used for Safe Haskell in interfaces + -- (mkIfaceTc, as well as in HscMain) + -- - To create the Dependencies field in interface (mkDependencies) + + tcg_dus :: DefUses, -- ^ What is defined in this module and what is used. + tcg_used_gres :: TcRef [GlobalRdrElt], -- ^ Records occurrences of imported entities + -- One entry for each occurrence; but may have different GREs for + -- the same Name See Note [Tracking unused binding and imports] + + tcg_keep :: TcRef NameSet, + -- ^ Locally-defined top-level names to keep alive. + -- + -- "Keep alive" means give them an Exported flag, so that the + -- simplifier does not discard them as dead code, and so that they + -- are exposed in the interface file (but not to export to the + -- user). + -- + -- Some things, like dict-fun Ids and default-method Ids are "born" + -- with the Exported flag on, for exactly the above reason, but some + -- we only discover as we go. Specifically: + -- + -- * The to/from functions for generic data types + -- + -- * Top-level variables appearing free in the RHS of an orphan + -- rule + -- + -- * Top-level variables appearing free in a TH bracket + + tcg_th_used :: TcRef Bool, + -- ^ @True@ <=> Template Haskell syntax used. + -- + -- We need this so that we can generate a dependency on the + -- Template Haskell package, because the desugarer is going + -- to emit loads of references to TH symbols. The reference + -- is implicit rather than explicit, so we have to zap a + -- mutable variable. + + tcg_th_splice_used :: TcRef Bool, + -- ^ @True@ <=> A Template Haskell splice was used. + -- + -- Splices disable recompilation avoidance (see #481) + + tcg_th_top_level_locs :: TcRef (Set RealSrcSpan), + -- ^ Locations of the top-level splices; used for providing details on + -- scope in error messages for out-of-scope variables + + tcg_dfun_n :: TcRef OccSet, + -- ^ Allows us to choose unique DFun names. + + tcg_merged :: [(Module, Fingerprint)], + -- ^ The requirements we merged with; we always have to recompile + -- if any of these changed. + + -- The next fields accumulate the payload of the module + -- The binds, rules and foreign-decl fields are collected + -- initially in un-zonked form and are finally zonked in tcRnSrcDecls + + tcg_rn_exports :: Maybe [(Located (IE GhcRn), Avails)], + -- Nothing <=> no explicit export list + -- Is always Nothing if we don't want to retain renamed + -- exports. + -- If present contains each renamed export list item + -- together with its exported names. + + tcg_rn_imports :: [LImportDecl GhcRn], + -- Keep the renamed imports regardless. They are not + -- voluminous and are needed if you want to report unused imports + + tcg_rn_decls :: Maybe (HsGroup GhcRn), + -- ^ Renamed decls, maybe. @Nothing@ <=> Don't retain renamed + -- decls. + + tcg_dependent_files :: TcRef [FilePath], -- ^ dependencies from addDependentFile + + tcg_th_topdecls :: TcRef [LHsDecl GhcPs], + -- ^ Top-level declarations from addTopDecls + + tcg_th_foreign_files :: TcRef [(ForeignSrcLang, FilePath)], + -- ^ Foreign files emitted from TH. + + tcg_th_topnames :: TcRef NameSet, + -- ^ Exact names bound in top-level declarations in tcg_th_topdecls + + tcg_th_modfinalizers :: TcRef [(TcLclEnv, ThModFinalizers)], + -- ^ Template Haskell module finalizers. + -- + -- They can use particular local environments. + + tcg_th_coreplugins :: TcRef [String], + -- ^ Core plugins added by Template Haskell code. + + tcg_th_state :: TcRef (Map TypeRep Dynamic), + tcg_th_remote_state :: TcRef (Maybe (ForeignRef (IORef QState))), + -- ^ Template Haskell state + + tcg_ev_binds :: Bag EvBind, -- Top-level evidence bindings + + -- Things defined in this module, or (in GHCi) + -- in the declarations for a single GHCi command. + -- For the latter, see Note [The interactive package] in HscTypes + tcg_tr_module :: Maybe Id, -- Id for $trModule :: GHC.Types.Module + -- for which every module has a top-level defn + -- except in GHCi in which case we have Nothing + tcg_binds :: LHsBinds GhcTc, -- Value bindings in this module + tcg_sigs :: NameSet, -- ...Top-level names that *lack* a signature + tcg_imp_specs :: [LTcSpecPrag], -- ...SPECIALISE prags for imported Ids + tcg_warns :: Warnings, -- ...Warnings and deprecations + tcg_anns :: [Annotation], -- ...Annotations + tcg_tcs :: [TyCon], -- ...TyCons and Classes + tcg_insts :: [ClsInst], -- ...Instances + tcg_fam_insts :: [FamInst], -- ...Family instances + tcg_rules :: [LRuleDecl GhcTc], -- ...Rules + tcg_fords :: [LForeignDecl GhcTc], -- ...Foreign import & exports + tcg_patsyns :: [PatSyn], -- ...Pattern synonyms + + tcg_doc_hdr :: Maybe LHsDocString, -- ^ Maybe Haddock header docs + tcg_hpc :: !AnyHpcUsage, -- ^ @True@ if any part of the + -- prog uses hpc instrumentation. + -- NB. BangPattern is to fix a leak, see #15111 + + tcg_self_boot :: SelfBootInfo, -- ^ Whether this module has a + -- corresponding hi-boot file + + tcg_main :: Maybe Name, -- ^ The Name of the main + -- function, if this module is + -- the main module. + + tcg_safeInfer :: TcRef (Bool, WarningMessages), + -- ^ Has the typechecker inferred this module as -XSafe (Safe Haskell) + -- See Note [Safe Haskell Overlapping Instances Implementation], + -- although this is used for more than just that failure case. + + tcg_tc_plugins :: [TcPluginSolver], + -- ^ A list of user-defined plugins for the constraint solver. + + tcg_top_loc :: RealSrcSpan, + -- ^ The RealSrcSpan this module came from + + tcg_static_wc :: TcRef WantedConstraints, + -- ^ Wanted constraints of static forms. + -- See Note [Constraints in static forms]. + tcg_complete_matches :: [CompleteMatch], + + -- ^ Tracking indices for cost centre annotations + tcg_cc_st :: TcRef CostCentreState + } + +-- NB: topModIdentity, not topModSemantic! +-- Definition sites of orphan identities will be identity modules, not semantic +-- modules. + +-- Note [Constraints in static forms] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- When a static form produces constraints like +-- +-- f :: StaticPtr (Bool -> String) +-- f = static show +-- +-- we collect them in tcg_static_wc and resolve them at the end +-- of type checking. They need to be resolved separately because +-- we don't want to resolve them in the context of the enclosing +-- expression. Consider +-- +-- g :: Show a => StaticPtr (a -> String) +-- g = static show +-- +-- If the @Show a0@ constraint that the body of the static form produces was +-- resolved in the context of the enclosing expression, then the body of the +-- static form wouldn't be closed because the Show dictionary would come from +-- g's context instead of coming from the top level. + +tcVisibleOrphanMods :: TcGblEnv -> ModuleSet +tcVisibleOrphanMods tcg_env + = mkModuleSet (tcg_mod tcg_env : imp_orphs (tcg_imports tcg_env)) + +instance ContainsModule TcGblEnv where + extractModule env = tcg_semantic_mod env + +type RecFieldEnv = NameEnv [FieldLabel] + -- Maps a constructor name *in this module* + -- to the fields for that constructor. + -- This is used when dealing with ".." notation in record + -- construction and pattern matching. + -- The FieldEnv deals *only* with constructors defined in *this* + -- module. For imported modules, we get the same info from the + -- TypeEnv + +data SelfBootInfo + = NoSelfBoot -- No corresponding hi-boot file + | SelfBoot + { sb_mds :: ModDetails -- There was a hi-boot file, + , sb_tcs :: NameSet } -- defining these TyCons, +-- What is sb_tcs used for? See Note [Extra dependencies from .hs-boot files] +-- in RnSource + + +{- Note [Tracking unused binding and imports] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We gather two sorts of usage information + + * tcg_dus (defs/uses) + Records *defined* Names (local, top-level) + and *used* Names (local or imported) + + Used (a) to report "defined but not used" + (see RnNames.reportUnusedNames) + (b) to generate version-tracking usage info in interface + files (see MkIface.mkUsedNames) + This usage info is mainly gathered by the renamer's + gathering of free-variables + + * tcg_used_gres + Used only to report unused import declarations + + Records each *occurrence* an *imported* (not locally-defined) entity. + The occurrence is recorded by keeping a GlobalRdrElt for it. + These is not the GRE that is in the GlobalRdrEnv; rather it + is recorded *after* the filtering done by pickGREs. So it reflect + /how that occurrence is in scope/. See Note [GRE filtering] in + RdrName. + + +************************************************************************ +* * + The local typechecker environment +* * +************************************************************************ + +Note [The Global-Env/Local-Env story] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +During type checking, we keep in the tcg_type_env + * All types and classes + * All Ids derived from types and classes (constructors, selectors) + +At the end of type checking, we zonk the local bindings, +and as we do so we add to the tcg_type_env + * Locally defined top-level Ids + +Why? Because they are now Ids not TcIds. This final GlobalEnv is + a) fed back (via the knot) to typechecking the + unfoldings of interface signatures + b) used in the ModDetails of this module +-} + +data TcLclEnv -- Changes as we move inside an expression + -- Discarded after typecheck/rename; not passed on to desugarer + = TcLclEnv { + tcl_loc :: RealSrcSpan, -- Source span + tcl_ctxt :: [ErrCtxt], -- Error context, innermost on top + tcl_tclvl :: TcLevel, -- Birthplace for new unification variables + + tcl_th_ctxt :: ThStage, -- Template Haskell context + tcl_th_bndrs :: ThBindEnv, -- and binder info + -- The ThBindEnv records the TH binding level of in-scope Names + -- defined in this module (not imported) + -- We can't put this info in the TypeEnv because it's needed + -- (and extended) in the renamer, for untyed splices + + tcl_arrow_ctxt :: ArrowCtxt, -- Arrow-notation context + + tcl_rdr :: LocalRdrEnv, -- Local name envt + -- Maintained during renaming, of course, but also during + -- type checking, solely so that when renaming a Template-Haskell + -- splice we have the right environment for the renamer. + -- + -- Does *not* include global name envt; may shadow it + -- Includes both ordinary variables and type variables; + -- they are kept distinct because tyvar have a different + -- occurrence constructor (Name.TvOcc) + -- We still need the unsullied global name env so that + -- we can look up record field names + + tcl_env :: TcTypeEnv, -- The local type environment: + -- Ids and TyVars defined in this module + + tcl_bndrs :: TcBinderStack, -- Used for reporting relevant bindings, + -- and for tidying types + + tcl_tyvars :: TcRef TcTyVarSet, -- The "global tyvars" + -- Namely, the in-scope TyVars bound in tcl_env, + -- plus the tyvars mentioned in the types of Ids bound + -- in tcl_lenv. + -- Why mutable? see notes with tcGetGlobalTyCoVars + + tcl_lie :: TcRef WantedConstraints, -- Place to accumulate type constraints + tcl_errs :: TcRef Messages -- Place to accumulate errors + } + +type ErrCtxt = (Bool, TidyEnv -> TcM (TidyEnv, MsgDoc)) + -- Monadic so that we have a chance + -- to deal with bound type variables just before error + -- message construction + + -- Bool: True <=> this is a landmark context; do not + -- discard it when trimming for display + +type TcTypeEnv = NameEnv TcTyThing + +type ThBindEnv = NameEnv (TopLevelFlag, ThLevel) + -- Domain = all Ids bound in this module (ie not imported) + -- The TopLevelFlag tells if the binding is syntactically top level. + -- We need to know this, because the cross-stage persistence story allows + -- cross-stage at arbitrary types if the Id is bound at top level. + -- + -- Nota bene: a ThLevel of 'outerLevel' is *not* the same as being + -- bound at top level! See Note [Template Haskell levels] in TcSplice + +{- Note [Given Insts] + ~~~~~~~~~~~~~~~~~~ +Because of GADTs, we have to pass inwards the Insts provided by type signatures +and existential contexts. Consider + data T a where { T1 :: b -> b -> T [b] } + f :: Eq a => T a -> Bool + f (T1 x y) = [x]==[y] + +The constructor T1 binds an existential variable 'b', and we need Eq [b]. +Well, we have it, because Eq a refines to Eq [b], but we can only spot that if we +pass it inwards. + +-} + +-- | Type alias for 'IORef'; the convention is we'll use this for mutable +-- bits of data in 'TcGblEnv' which are updated during typechecking and +-- returned at the end. +type TcRef a = IORef a +-- ToDo: when should I refer to it as a 'TcId' instead of an 'Id'? +type TcId = Id +type TcIdSet = IdSet + +--------------------------- +-- The TcBinderStack +--------------------------- + +type TcBinderStack = [TcBinder] + -- This is a stack of locally-bound ids and tyvars, + -- innermost on top + -- Used only in error reporting (relevantBindings in TcError), + -- and in tidying + -- We can't use the tcl_env type environment, because it doesn't + -- keep track of the nesting order + +data TcBinder + = TcIdBndr + TcId + TopLevelFlag -- Tells whether the binding is syntactically top-level + -- (The monomorphic Ids for a recursive group count + -- as not-top-level for this purpose.) + + | TcIdBndr_ExpType -- Variant that allows the type to be specified as + -- an ExpType + Name + ExpType + TopLevelFlag + + | TcTvBndr -- e.g. case x of P (y::a) -> blah + Name -- We bind the lexical name "a" to the type of y, + TyVar -- which might be an utterly different (perhaps + -- existential) tyvar + +instance Outputable TcBinder where + ppr (TcIdBndr id top_lvl) = ppr id <> brackets (ppr top_lvl) + ppr (TcIdBndr_ExpType id _ top_lvl) = ppr id <> brackets (ppr top_lvl) + ppr (TcTvBndr name tv) = ppr name <+> ppr tv + +instance HasOccName TcBinder where + occName (TcIdBndr id _) = occName (idName id) + occName (TcIdBndr_ExpType name _ _) = occName name + occName (TcTvBndr name _) = occName name + +-- fixes #12177 +-- Builds up a list of bindings whose OccName has not been seen before +-- i.e., If ys = removeBindingShadowing xs +-- then +-- - ys is obtained from xs by deleting some elements +-- - ys has no duplicate OccNames +-- - The first duplicated OccName in xs is retained in ys +-- Overloaded so that it can be used for both GlobalRdrElt in typed-hole +-- substitutions and TcBinder when looking for relevant bindings. +removeBindingShadowing :: HasOccName a => [a] -> [a] +removeBindingShadowing bindings = reverse $ fst $ foldl + (\(bindingAcc, seenNames) binding -> + if occName binding `elemOccSet` seenNames -- if we've seen it + then (bindingAcc, seenNames) -- skip it + else (binding:bindingAcc, extendOccSet seenNames (occName binding))) + ([], emptyOccSet) bindings + +--------------------------- +-- Template Haskell stages and levels +--------------------------- + +data SpliceType = Typed | Untyped + +data ThStage -- See Note [Template Haskell state diagram] in TcSplice + = Splice SpliceType -- Inside a top-level splice + -- This code will be run *at compile time*; + -- the result replaces the splice + -- Binding level = 0 + + | RunSplice (TcRef [ForeignRef (TH.Q ())]) + -- Set when running a splice, i.e. NOT when renaming or typechecking the + -- Haskell code for the splice. See Note [RunSplice ThLevel]. + -- + -- Contains a list of mod finalizers collected while executing the splice. + -- + -- 'addModFinalizer' inserts finalizers here, and from here they are taken + -- to construct an @HsSpliced@ annotation for untyped splices. See Note + -- [Delaying modFinalizers in untyped splices] in "RnSplice". + -- + -- For typed splices, the typechecker takes finalizers from here and + -- inserts them in the list of finalizers in the global environment. + -- + -- See Note [Collecting modFinalizers in typed splices] in "TcSplice". + + | Comp -- Ordinary Haskell code + -- Binding level = 1 + + | Brack -- Inside brackets + ThStage -- Enclosing stage + PendingStuff + +data PendingStuff + = RnPendingUntyped -- Renaming the inside of an *untyped* bracket + (TcRef [PendingRnSplice]) -- Pending splices in here + + | RnPendingTyped -- Renaming the inside of a *typed* bracket + + | TcPending -- Typechecking the inside of a typed bracket + (TcRef [PendingTcSplice]) -- Accumulate pending splices here + (TcRef WantedConstraints) -- and type constraints here + +topStage, topAnnStage, topSpliceStage :: ThStage +topStage = Comp +topAnnStage = Splice Untyped +topSpliceStage = Splice Untyped + +instance Outputable ThStage where + ppr (Splice _) = text "Splice" + ppr (RunSplice _) = text "RunSplice" + ppr Comp = text "Comp" + ppr (Brack s _) = text "Brack" <> parens (ppr s) + +type ThLevel = Int + -- NB: see Note [Template Haskell levels] in TcSplice + -- Incremented when going inside a bracket, + -- decremented when going inside a splice + -- NB: ThLevel is one greater than the 'n' in Fig 2 of the + -- original "Template meta-programming for Haskell" paper + +impLevel, outerLevel :: ThLevel +impLevel = 0 -- Imported things; they can be used inside a top level splice +outerLevel = 1 -- Things defined outside brackets + +thLevel :: ThStage -> ThLevel +thLevel (Splice _) = 0 +thLevel (RunSplice _) = + -- See Note [RunSplice ThLevel]. + panic "thLevel: called when running a splice" +thLevel Comp = 1 +thLevel (Brack s _) = thLevel s + 1 + +{- Node [RunSplice ThLevel] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The 'RunSplice' stage is set when executing a splice, and only when running a +splice. In particular it is not set when the splice is renamed or typechecked. + +'RunSplice' is needed to provide a reference where 'addModFinalizer' can insert +the finalizer (see Note [Delaying modFinalizers in untyped splices]), and +'addModFinalizer' runs when doing Q things. Therefore, It doesn't make sense to +set 'RunSplice' when renaming or typechecking the splice, where 'Splice', +'Brack' or 'Comp' are used instead. + +-} + +--------------------------- +-- Arrow-notation context +--------------------------- + +{- Note [Escaping the arrow scope] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In arrow notation, a variable bound by a proc (or enclosed let/kappa) +is not in scope to the left of an arrow tail (-<) or the head of (|..|). +For example + + proc x -> (e1 -< e2) + +Here, x is not in scope in e1, but it is in scope in e2. This can get +a bit complicated: + + let x = 3 in + proc y -> (proc z -> e1) -< e2 + +Here, x and z are in scope in e1, but y is not. + +We implement this by +recording the environment when passing a proc (using newArrowScope), +and returning to that (using escapeArrowScope) on the left of -< and the +head of (|..|). + +All this can be dealt with by the *renamer*. But the type checker needs +to be involved too. Example (arrowfail001) + class Foo a where foo :: a -> () + data Bar = forall a. Foo a => Bar a + get :: Bar -> () + get = proc x -> case x of Bar a -> foo -< a +Here the call of 'foo' gives rise to a (Foo a) constraint that should not +be captured by the pattern match on 'Bar'. Rather it should join the +constraints from further out. So we must capture the constraint bag +from further out in the ArrowCtxt that we push inwards. +-} + +data ArrowCtxt -- Note [Escaping the arrow scope] + = NoArrowCtxt + | ArrowCtxt LocalRdrEnv (TcRef WantedConstraints) + + +--------------------------- +-- TcTyThing +--------------------------- + +-- | A typecheckable thing available in a local context. Could be +-- 'AGlobal' 'TyThing', but also lexically scoped variables, etc. +-- See 'TcEnv' for how to retrieve a 'TyThing' given a 'Name'. +data TcTyThing + = AGlobal TyThing -- Used only in the return type of a lookup + + | ATcId -- Ids defined in this module; may not be fully zonked + { tct_id :: TcId + , tct_info :: IdBindingInfo -- See Note [Meaning of IdBindingInfo] + } + + | ATyVar Name TcTyVar -- See Note [Type variables in the type environment] + + | ATcTyCon TyCon -- Used temporarily, during kind checking, for the + -- tycons and clases in this recursive group + -- The TyCon is always a TcTyCon. Its kind + -- can be a mono-kind or a poly-kind; in TcTyClsDcls see + -- Note [Type checking recursive type and class declarations] + + | APromotionErr PromotionErr + +data PromotionErr + = TyConPE -- TyCon used in a kind before we are ready + -- data T :: T -> * where ... + | ClassPE -- Ditto Class + + | FamDataConPE -- Data constructor for a data family + -- See Note [AFamDataCon: not promoting data family constructors] + -- in TcEnv. + | ConstrainedDataConPE PredType + -- Data constructor with a non-equality context + -- See Note [Don't promote data constructors with + -- non-equality contexts] in TcHsType + | PatSynPE -- Pattern synonyms + -- See Note [Don't promote pattern synonyms] in TcEnv + + | RecDataConPE -- Data constructor in a recursive loop + -- See Note [Recursion and promoting data constructors] in TcTyClsDecls + | NoDataKindsTC -- -XDataKinds not enabled (for a tycon) + | NoDataKindsDC -- -XDataKinds not enabled (for a datacon) + +instance Outputable TcTyThing where -- Debugging only + ppr (AGlobal g) = ppr g + ppr elt@(ATcId {}) = text "Identifier" <> + brackets (ppr (tct_id elt) <> dcolon + <> ppr (varType (tct_id elt)) <> comma + <+> ppr (tct_info elt)) + ppr (ATyVar n tv) = text "Type variable" <+> quotes (ppr n) <+> equals <+> ppr tv + <+> dcolon <+> ppr (varType tv) + ppr (ATcTyCon tc) = text "ATcTyCon" <+> ppr tc <+> dcolon <+> ppr (tyConKind tc) + ppr (APromotionErr err) = text "APromotionErr" <+> ppr err + +-- | IdBindingInfo describes how an Id is bound. +-- +-- It is used for the following purposes: +-- a) for static forms in TcExpr.checkClosedInStaticForm and +-- b) to figure out when a nested binding can be generalised, +-- in TcBinds.decideGeneralisationPlan. +-- +data IdBindingInfo -- See Note [Meaning of IdBindingInfo and ClosedTypeId] + = NotLetBound + | ClosedLet + | NonClosedLet + RhsNames -- Used for (static e) checks only + ClosedTypeId -- Used for generalisation checks + -- and for (static e) checks + +-- | IsGroupClosed describes a group of mutually-recursive bindings +data IsGroupClosed + = IsGroupClosed + (NameEnv RhsNames) -- Free var info for the RHS of each binding in the goup + -- Used only for (static e) checks + + ClosedTypeId -- True <=> all the free vars of the group are + -- imported or ClosedLet or + -- NonClosedLet with ClosedTypeId=True. + -- In particular, no tyvars, no NotLetBound + +type RhsNames = NameSet -- Names of variables, mentioned on the RHS of + -- a definition, that are not Global or ClosedLet + +type ClosedTypeId = Bool + -- See Note [Meaning of IdBindingInfo and ClosedTypeId] + +{- Note [Meaning of IdBindingInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +NotLetBound means that + the Id is not let-bound (e.g. it is bound in a + lambda-abstraction or in a case pattern) + +ClosedLet means that + - The Id is let-bound, + - Any free term variables are also Global or ClosedLet + - Its type has no free variables (NB: a top-level binding subject + to the MR might have free vars in its type) + These ClosedLets can definitely be floated to top level; and we + may need to do so for static forms. + + Property: ClosedLet + is equivalent to + NonClosedLet emptyNameSet True + +(NonClosedLet (fvs::RhsNames) (cl::ClosedTypeId)) means that + - The Id is let-bound + + - The fvs::RhsNames contains the free names of the RHS, + excluding Global and ClosedLet ones. + + - For the ClosedTypeId field see Note [Bindings with closed types] + +For (static e) to be valid, we need for every 'x' free in 'e', +that x's binding is floatable to the top level. Specifically: + * x's RhsNames must be empty + * x's type has no free variables +See Note [Grand plan for static forms] in StaticPtrTable.hs. +This test is made in TcExpr.checkClosedInStaticForm. +Actually knowing x's RhsNames (rather than just its emptiness +or otherwise) is just so we can produce better error messages + +Note [Bindings with closed types: ClosedTypeId] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + f x = let g ys = map not ys + in ... + +Can we generalise 'g' under the OutsideIn algorithm? Yes, +because all g's free variables are top-level; that is they themselves +have no free type variables, and it is the type variables in the +environment that makes things tricky for OutsideIn generalisation. + +Here's the invariant: + If an Id has ClosedTypeId=True (in its IdBindingInfo), then + the Id's type is /definitely/ closed (has no free type variables). + Specifically, + a) The Id's acutal type is closed (has no free tyvars) + b) Either the Id has a (closed) user-supplied type signature + or all its free variables are Global/ClosedLet + or NonClosedLet with ClosedTypeId=True. + In particular, none are NotLetBound. + +Why is (b) needed? Consider + \x. (x :: Int, let y = x+1 in ...) +Initially x::alpha. If we happen to typecheck the 'let' before the +(x::Int), y's type will have a free tyvar; but if the other way round +it won't. So we treat any let-bound variable with a free +non-let-bound variable as not ClosedTypeId, regardless of what the +free vars of its type actually are. + +But if it has a signature, all is well: + \x. ...(let { y::Int; y = x+1 } in + let { v = y+2 } in ...)... +Here the signature on 'v' makes 'y' a ClosedTypeId, so we can +generalise 'v'. + +Note that: + + * A top-level binding may not have ClosedTypeId=True, if it suffers + from the MR + + * A nested binding may be closed (eg 'g' in the example we started + with). Indeed, that's the point; whether a function is defined at + top level or nested is orthogonal to the question of whether or + not it is closed. + + * A binding may be non-closed because it mentions a lexically scoped + *type variable* Eg + f :: forall a. blah + f x = let g y = ...(y::a)... + +Under OutsideIn we are free to generalise an Id all of whose free +variables have ClosedTypeId=True (or imported). This is an extension +compared to the JFP paper on OutsideIn, which used "top-level" as a +proxy for "closed". (It's not a good proxy anyway -- the MR can make +a top-level binding with a free type variable.) + +Note [Type variables in the type environment] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The type environment has a binding for each lexically-scoped +type variable that is in scope. For example + + f :: forall a. a -> a + f x = (x :: a) + + g1 :: [a] -> a + g1 (ys :: [b]) = head ys :: b + + g2 :: [Int] -> Int + g2 (ys :: [c]) = head ys :: c + +* The forall'd variable 'a' in the signature scopes over f's RHS. + +* The pattern-bound type variable 'b' in 'g1' scopes over g1's + RHS; note that it is bound to a skolem 'a' which is not itself + lexically in scope. + +* The pattern-bound type variable 'c' in 'g2' is bound to + Int; that is, pattern-bound type variables can stand for + arbitrary types. (see + GHC proposal #128 "Allow ScopedTypeVariables to refer to types" + https://github.com/ghc-proposals/ghc-proposals/pull/128, + and the paper + "Type variables in patterns", Haskell Symposium 2018. + + +This is implemented by the constructor + ATyVar Name TcTyVar +in the type environment. + +* The Name is the name of the original, lexically scoped type + variable + +* The TcTyVar is sometimes a skolem (like in 'f'), and sometimes + a unification variable (like in 'g1', 'g2'). We never zonk the + type environment so in the latter case it always stays as a + unification variable, although that variable may be later + unified with a type (such as Int in 'g2'). +-} + +instance Outputable IdBindingInfo where + ppr NotLetBound = text "NotLetBound" + ppr ClosedLet = text "TopLevelLet" + ppr (NonClosedLet fvs closed_type) = + text "TopLevelLet" <+> ppr fvs <+> ppr closed_type + +instance Outputable PromotionErr where + ppr ClassPE = text "ClassPE" + ppr TyConPE = text "TyConPE" + ppr PatSynPE = text "PatSynPE" + ppr FamDataConPE = text "FamDataConPE" + ppr (ConstrainedDataConPE pred) = text "ConstrainedDataConPE" + <+> parens (ppr pred) + ppr RecDataConPE = text "RecDataConPE" + ppr NoDataKindsTC = text "NoDataKindsTC" + ppr NoDataKindsDC = text "NoDataKindsDC" + +pprTcTyThingCategory :: TcTyThing -> SDoc +pprTcTyThingCategory (AGlobal thing) = pprTyThingCategory thing +pprTcTyThingCategory (ATyVar {}) = text "Type variable" +pprTcTyThingCategory (ATcId {}) = text "Local identifier" +pprTcTyThingCategory (ATcTyCon {}) = text "Local tycon" +pprTcTyThingCategory (APromotionErr pe) = pprPECategory pe + +pprPECategory :: PromotionErr -> SDoc +pprPECategory ClassPE = text "Class" +pprPECategory TyConPE = text "Type constructor" +pprPECategory PatSynPE = text "Pattern synonym" +pprPECategory FamDataConPE = text "Data constructor" +pprPECategory ConstrainedDataConPE{} = text "Data constructor" +pprPECategory RecDataConPE = text "Data constructor" +pprPECategory NoDataKindsTC = text "Type constructor" +pprPECategory NoDataKindsDC = text "Data constructor" + +{- +************************************************************************ +* * + Operations over ImportAvails +* * +************************************************************************ +-} + +-- | 'ImportAvails' summarises what was imported from where, irrespective of +-- whether the imported things are actually used or not. It is used: +-- +-- * when processing the export list, +-- +-- * when constructing usage info for the interface file, +-- +-- * to identify the list of directly imported modules for initialisation +-- purposes and for optimised overlap checking of family instances, +-- +-- * when figuring out what things are really unused +-- +data ImportAvails + = ImportAvails { + imp_mods :: ImportedMods, + -- = ModuleEnv [ImportedModsVal], + -- ^ Domain is all directly-imported modules + -- + -- See the documentation on ImportedModsVal in HscTypes for the + -- meaning of the fields. + -- + -- We need a full ModuleEnv rather than a ModuleNameEnv here, + -- because we might be importing modules of the same name from + -- different packages. (currently not the case, but might be in the + -- future). + + imp_dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface), + -- ^ Home-package modules needed by the module being compiled + -- + -- It doesn't matter whether any of these dependencies + -- are actually /used/ when compiling the module; they + -- are listed if they are below it at all. For + -- example, suppose M imports A which imports X. Then + -- compiling M might not need to consult X.hi, but X + -- is still listed in M's dependencies. + + imp_dep_pkgs :: Set InstalledUnitId, + -- ^ Packages needed by the module being compiled, whether directly, + -- or via other modules in this package, or via modules imported + -- from other packages. + + imp_trust_pkgs :: Set InstalledUnitId, + -- ^ This is strictly a subset of imp_dep_pkgs and records the + -- packages the current module needs to trust for Safe Haskell + -- compilation to succeed. A package is required to be trusted if + -- we are dependent on a trustworthy module in that package. + -- While perhaps making imp_dep_pkgs a tuple of (UnitId, Bool) + -- where True for the bool indicates the package is required to be + -- trusted is the more logical design, doing so complicates a lot + -- of code not concerned with Safe Haskell. + -- See Note [RnNames . Tracking Trust Transitively] + + imp_trust_own_pkg :: Bool, + -- ^ Do we require that our own package is trusted? + -- This is to handle efficiently the case where a Safe module imports + -- a Trustworthy module that resides in the same package as it. + -- See Note [RnNames . Trust Own Package] + + imp_orphs :: [Module], + -- ^ Orphan modules below us in the import tree (and maybe including + -- us for imported modules) + + imp_finsts :: [Module] + -- ^ Family instance modules below us in the import tree (and maybe + -- including us for imported modules) + } + +mkModDeps :: [(ModuleName, IsBootInterface)] + -> ModuleNameEnv (ModuleName, IsBootInterface) +mkModDeps deps = foldl' add emptyUFM deps + where + add env elt@(m,_) = addToUFM env m elt + +modDepsElts + :: ModuleNameEnv (ModuleName, IsBootInterface) + -> [(ModuleName, IsBootInterface)] +modDepsElts = sort . nonDetEltsUFM + -- It's OK to use nonDetEltsUFM here because sorting by module names + -- restores determinism + +emptyImportAvails :: ImportAvails +emptyImportAvails = ImportAvails { imp_mods = emptyModuleEnv, + imp_dep_mods = emptyUFM, + imp_dep_pkgs = S.empty, + imp_trust_pkgs = S.empty, + imp_trust_own_pkg = False, + imp_orphs = [], + imp_finsts = [] } + +-- | Union two ImportAvails +-- +-- This function is a key part of Import handling, basically +-- for each import we create a separate ImportAvails structure +-- and then union them all together with this function. +plusImportAvails :: ImportAvails -> ImportAvails -> ImportAvails +plusImportAvails + (ImportAvails { imp_mods = mods1, + imp_dep_mods = dmods1, imp_dep_pkgs = dpkgs1, + imp_trust_pkgs = tpkgs1, imp_trust_own_pkg = tself1, + imp_orphs = orphs1, imp_finsts = finsts1 }) + (ImportAvails { imp_mods = mods2, + imp_dep_mods = dmods2, imp_dep_pkgs = dpkgs2, + imp_trust_pkgs = tpkgs2, imp_trust_own_pkg = tself2, + imp_orphs = orphs2, imp_finsts = finsts2 }) + = ImportAvails { imp_mods = plusModuleEnv_C (++) mods1 mods2, + imp_dep_mods = plusUFM_C plus_mod_dep dmods1 dmods2, + imp_dep_pkgs = dpkgs1 `S.union` dpkgs2, + imp_trust_pkgs = tpkgs1 `S.union` tpkgs2, + imp_trust_own_pkg = tself1 || tself2, + imp_orphs = orphs1 `unionLists` orphs2, + imp_finsts = finsts1 `unionLists` finsts2 } + where + plus_mod_dep r1@(m1, boot1) r2@(m2, boot2) + | ASSERT2( m1 == m2, (ppr m1 <+> ppr m2) $$ (ppr boot1 <+> ppr boot2) ) + boot1 = r2 + | otherwise = r1 + -- If either side can "see" a non-hi-boot interface, use that + -- Reusing existing tuples saves 10% of allocations on test + -- perf/compiler/MultiLayerModules + +{- +************************************************************************ +* * +\subsection{Where from} +* * +************************************************************************ + +The @WhereFrom@ type controls where the renamer looks for an interface file +-} + +data WhereFrom + = ImportByUser IsBootInterface -- Ordinary user import (perhaps {-# SOURCE #-}) + | ImportBySystem -- Non user import. + | ImportByPlugin -- Importing a plugin; + -- See Note [Care with plugin imports] in LoadIface + +instance Outputable WhereFrom where + ppr (ImportByUser is_boot) | is_boot = text "{- SOURCE -}" + | otherwise = empty + ppr ImportBySystem = text "{- SYSTEM -}" + ppr ImportByPlugin = text "{- PLUGIN -}" + + +{- ********************************************************************* +* * + Type signatures +* * +********************************************************************* -} + +-- These data types need to be here only because +-- TcSimplify uses them, and TcSimplify is fairly +-- low down in the module hierarchy + +type TcSigFun = Name -> Maybe TcSigInfo + +data TcSigInfo = TcIdSig TcIdSigInfo + | TcPatSynSig TcPatSynInfo + +data TcIdSigInfo -- See Note [Complete and partial type signatures] + = CompleteSig -- A complete signature with no wildcards, + -- so the complete polymorphic type is known. + { sig_bndr :: TcId -- The polymorphic Id with that type + + , sig_ctxt :: UserTypeCtxt -- In the case of type-class default methods, + -- the Name in the FunSigCtxt is not the same + -- as the TcId; the former is 'op', while the + -- latter is '$dmop' or some such + + , sig_loc :: SrcSpan -- Location of the type signature + } + + | PartialSig -- A partial type signature (i.e. includes one or more + -- wildcards). In this case it doesn't make sense to give + -- the polymorphic Id, because we are going to /infer/ its + -- type, so we can't make the polymorphic Id ab-initio + { psig_name :: Name -- Name of the function; used when report wildcards + , psig_hs_ty :: LHsSigWcType GhcRn -- The original partial signature in + -- HsSyn form + , sig_ctxt :: UserTypeCtxt + , sig_loc :: SrcSpan -- Location of the type signature + } + + +{- Note [Complete and partial type signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A type signature is partial when it contains one or more wildcards +(= type holes). The wildcard can either be: +* A (type) wildcard occurring in sig_theta or sig_tau. These are + stored in sig_wcs. + f :: Bool -> _ + g :: Eq _a => _a -> _a -> Bool +* Or an extra-constraints wildcard, stored in sig_cts: + h :: (Num a, _) => a -> a + +A type signature is a complete type signature when there are no +wildcards in the type signature, i.e. iff sig_wcs is empty and +sig_extra_cts is Nothing. +-} + +data TcIdSigInst + = TISI { sig_inst_sig :: TcIdSigInfo + + , sig_inst_skols :: [(Name, TcTyVar)] + -- Instantiated type and kind variables, TyVarTvs + -- The Name is the Name that the renamer chose; + -- but the TcTyVar may come from instantiating + -- the type and hence have a different unique. + -- No need to keep track of whether they are truly lexically + -- scoped because the renamer has named them uniquely + -- See Note [Binding scoped type variables] in TcSigs + + , sig_inst_theta :: TcThetaType + -- Instantiated theta. In the case of a + -- PartialSig, sig_theta does not include + -- the extra-constraints wildcard + + , sig_inst_tau :: TcSigmaType -- Instantiated tau + -- See Note [sig_inst_tau may be polymorphic] + + -- Relevant for partial signature only + , sig_inst_wcs :: [(Name, TcTyVar)] + -- Like sig_inst_skols, but for wildcards. The named + -- wildcards scope over the binding, and hence their + -- Names may appear in type signatures in the binding + + , sig_inst_wcx :: Maybe TcType + -- Extra-constraints wildcard to fill in, if any + -- If this exists, it is surely of the form (meta_tv |> co) + -- (where the co might be reflexive). This is filled in + -- only from the return value of TcHsType.tcWildCardOcc + } + +{- Note [sig_inst_tau may be polymorphic] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note that "sig_inst_tau" might actually be a polymorphic type, +if the original function had a signature like + forall a. Eq a => forall b. Ord b => .... +But that's ok: tcMatchesFun (called by tcRhs) can deal with that +It happens, too! See Note [Polymorphic methods] in TcClassDcl. + +Note [Wildcards in partial signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The wildcards in psig_wcs may stand for a type mentioning +the universally-quantified tyvars of psig_ty + +E.g. f :: forall a. _ -> a + f x = x +We get sig_inst_skols = [a] + sig_inst_tau = _22 -> a + sig_inst_wcs = [_22] +and _22 in the end is unified with the type 'a' + +Moreover the kind of a wildcard in sig_inst_wcs may mention +the universally-quantified tyvars sig_inst_skols +e.g. f :: t a -> t _ +Here we get + sig_inst_skols = [k:*, (t::k ->*), (a::k)] + sig_inst_tau = t a -> t _22 + sig_inst_wcs = [ _22::k ] +-} + +data TcPatSynInfo + = TPSI { + patsig_name :: Name, + patsig_implicit_bndrs :: [TyVarBinder], -- Implicitly-bound kind vars (Inferred) and + -- implicitly-bound type vars (Specified) + -- See Note [The pattern-synonym signature splitting rule] in TcPatSyn + patsig_univ_bndrs :: [TyVar], -- Bound by explicit user forall + patsig_req :: TcThetaType, + patsig_ex_bndrs :: [TyVar], -- Bound by explicit user forall + patsig_prov :: TcThetaType, + patsig_body_ty :: TcSigmaType + } + +instance Outputable TcSigInfo where + ppr (TcIdSig idsi) = ppr idsi + ppr (TcPatSynSig tpsi) = text "TcPatSynInfo" <+> ppr tpsi + +instance Outputable TcIdSigInfo where + ppr (CompleteSig { sig_bndr = bndr }) + = ppr bndr <+> dcolon <+> ppr (idType bndr) + ppr (PartialSig { psig_name = name, psig_hs_ty = hs_ty }) + = text "psig" <+> ppr name <+> dcolon <+> ppr hs_ty + +instance Outputable TcIdSigInst where + ppr (TISI { sig_inst_sig = sig, sig_inst_skols = skols + , sig_inst_theta = theta, sig_inst_tau = tau }) + = hang (ppr sig) 2 (vcat [ ppr skols, ppr theta <+> darrow <+> ppr tau ]) + +instance Outputable TcPatSynInfo where + ppr (TPSI{ patsig_name = name}) = ppr name + +isPartialSig :: TcIdSigInst -> Bool +isPartialSig (TISI { sig_inst_sig = PartialSig {} }) = True +isPartialSig _ = False + +-- | No signature or a partial signature +hasCompleteSig :: TcSigFun -> Name -> Bool +hasCompleteSig sig_fn name + = case sig_fn name of + Just (TcIdSig (CompleteSig {})) -> True + _ -> False + + +{- +************************************************************************ +* * +* Canonical constraints * +* * +* These are the constraints the low-level simplifier works with * +* * +************************************************************************ +-} + +-- The syntax of xi (ξ) types: +-- xi ::= a | T xis | xis -> xis | ... | forall a. tau +-- Two important notes: +-- (i) No type families, unless we are under a ForAll +-- (ii) Note that xi types can contain unexpanded type synonyms; +-- however, the (transitive) expansions of those type synonyms +-- will not contain any type functions, unless we are under a ForAll. +-- We enforce the structure of Xi types when we flatten (TcCanonical) + +type Xi = Type -- In many comments, "xi" ranges over Xi + +type Cts = Bag Ct + +data Ct + -- Atomic canonical constraints + = CDictCan { -- e.g. Num xi + cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] + + cc_class :: Class, + cc_tyargs :: [Xi], -- cc_tyargs are function-free, hence Xi + + cc_pend_sc :: Bool -- See Note [The superclass story] in TcCanonical + -- True <=> (a) cc_class has superclasses + -- (b) we have not (yet) added those + -- superclasses as Givens + } + + | CIrredCan { -- These stand for yet-unusable predicates + cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] + cc_insol :: Bool -- True <=> definitely an error, can never be solved + -- False <=> might be soluble + + -- For the might-be-soluble case, the ctev_pred of the evidence is + -- of form (tv xi1 xi2 ... xin) with a tyvar at the head + -- or (tv1 ~ ty2) where the CTyEqCan kind invariant fails + -- or (F tys ~ ty) where the CFunEqCan kind invariant fails + -- See Note [CIrredCan constraints] + + -- The definitely-insoluble case is for things like + -- Int ~ Bool tycons don't match + -- a ~ [a] occurs check + } + + | CTyEqCan { -- tv ~ rhs + -- Invariants: + -- * See Note [Applying the inert substitution] in TcFlatten + -- * tv not in tvs(rhs) (occurs check) + -- * If tv is a TauTv, then rhs has no foralls + -- (this avoids substituting a forall for the tyvar in other types) + -- * tcTypeKind ty `tcEqKind` tcTypeKind tv; Note [Ct kind invariant] + -- * rhs may have at most one top-level cast + -- * rhs (perhaps under the one cast) is not necessarily function-free, + -- but it has no top-level function. + -- E.g. a ~ [F b] is fine + -- but a ~ F b is not + -- * If the equality is representational, rhs has no top-level newtype + -- See Note [No top-level newtypes on RHS of representational + -- equalities] in TcCanonical + -- * If rhs (perhaps under the cast) is also a tv, then it is oriented + -- to give best chance of + -- unification happening; eg if rhs is touchable then lhs is too + cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] + cc_tyvar :: TcTyVar, + cc_rhs :: TcType, -- Not necessarily function-free (hence not Xi) + -- See invariants above + + cc_eq_rel :: EqRel -- INVARIANT: cc_eq_rel = ctEvEqRel cc_ev + } + + | CFunEqCan { -- F xis ~ fsk + -- Invariants: + -- * isTypeFamilyTyCon cc_fun + -- * tcTypeKind (F xis) = tyVarKind fsk; Note [Ct kind invariant] + -- * always Nominal role + cc_ev :: CtEvidence, -- See Note [Ct/evidence invariant] + cc_fun :: TyCon, -- A type function + + cc_tyargs :: [Xi], -- cc_tyargs are function-free (hence Xi) + -- Either under-saturated or exactly saturated + -- *never* over-saturated (because if so + -- we should have decomposed) + + cc_fsk :: TcTyVar -- [G] always a FlatSkolTv + -- [W], [WD], or [D] always a FlatMetaTv + -- See Note [The flattening story] in TcFlatten + } + + | CNonCanonical { -- See Note [NonCanonical Semantics] in TcSMonad + cc_ev :: CtEvidence + } + + | CHoleCan { -- See Note [Hole constraints] + -- Treated as an "insoluble" constraint + -- See Note [Insoluble constraints] + cc_ev :: CtEvidence, + cc_hole :: Hole + } + + | CQuantCan QCInst -- A quantified constraint + -- NB: I expect to make more of the cases in Ct + -- look like this, with the payload in an + -- auxiliary type + +------------ +data QCInst -- A much simplified version of ClsInst + -- See Note [Quantified constraints] in TcCanonical + = QCI { qci_ev :: CtEvidence -- Always of type forall tvs. context => ty + -- Always Given + , qci_tvs :: [TcTyVar] -- The tvs + , qci_pred :: TcPredType -- The ty + , qci_pend_sc :: Bool -- Same as cc_pend_sc flag in CDictCan + -- Invariant: True => qci_pred is a ClassPred + } + +instance Outputable QCInst where + ppr (QCI { qci_ev = ev }) = ppr ev + +------------ +-- | An expression or type hole +data Hole = ExprHole UnboundVar + -- ^ Either an out-of-scope variable or a "true" hole in an + -- expression (TypedHoles) + | TypeHole OccName + -- ^ A hole in a type (PartialTypeSignatures) + +instance Outputable Hole where + ppr (ExprHole ub) = ppr ub + ppr (TypeHole occ) = text "TypeHole" <> parens (ppr occ) + +holeOcc :: Hole -> OccName +holeOcc (ExprHole uv) = unboundVarOcc uv +holeOcc (TypeHole occ) = occ + +{- Note [Hole constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +CHoleCan constraints are used for two kinds of holes, +distinguished by cc_hole: + + * For holes in expressions (including variables not in scope) + e.g. f x = g _ x + + * For holes in type signatures + e.g. f :: _ -> _ + f x = [x,True] + +Note [CIrredCan constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +CIrredCan constraints are used for constraints that are "stuck" + - we can't solve them (yet) + - we can't use them to solve other constraints + - but they may become soluble if we substitute for some + of the type variables in the constraint + +Example 1: (c Int), where c :: * -> Constraint. We can't do anything + with this yet, but if later c := Num, *then* we can solve it + +Example 2: a ~ b, where a :: *, b :: k, where k is a kind variable + We don't want to use this to substitute 'b' for 'a', in case + 'k' is subsequently unifed with (say) *->*, because then + we'd have ill-kinded types floating about. Rather we want + to defer using the equality altogether until 'k' get resolved. + +Note [Ct/evidence invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If ct :: Ct, then extra fields of 'ct' cache precisely the ctev_pred field +of (cc_ev ct), and is fully rewritten wrt the substitution. Eg for CDictCan, + ctev_pred (cc_ev ct) = (cc_class ct) (cc_tyargs ct) +This holds by construction; look at the unique place where CDictCan is +built (in TcCanonical). + +In contrast, the type of the evidence *term* (ctev_dest / ctev_evar) in +the evidence may *not* be fully zonked; we are careful not to look at it +during constraint solving. See Note [Evidence field of CtEvidence]. + +Note [Ct kind invariant] +~~~~~~~~~~~~~~~~~~~~~~~~ +CTyEqCan and CFunEqCan both require that the kind of the lhs matches the kind +of the rhs. This is necessary because both constraints are used for substitutions +during solving. If the kinds differed, then the substitution would take a well-kinded +type to an ill-kinded one. + +-} + +mkNonCanonical :: CtEvidence -> Ct +mkNonCanonical ev = CNonCanonical { cc_ev = ev } + +mkNonCanonicalCt :: Ct -> Ct +mkNonCanonicalCt ct = CNonCanonical { cc_ev = cc_ev ct } + +mkIrredCt :: CtEvidence -> Ct +mkIrredCt ev = CIrredCan { cc_ev = ev, cc_insol = False } + +mkInsolubleCt :: CtEvidence -> Ct +mkInsolubleCt ev = CIrredCan { cc_ev = ev, cc_insol = True } + +mkGivens :: CtLoc -> [EvId] -> [Ct] +mkGivens loc ev_ids + = map mk ev_ids + where + mk ev_id = mkNonCanonical (CtGiven { ctev_evar = ev_id + , ctev_pred = evVarPred ev_id + , ctev_loc = loc }) + +ctEvidence :: Ct -> CtEvidence +ctEvidence (CQuantCan (QCI { qci_ev = ev })) = ev +ctEvidence ct = cc_ev ct + +ctLoc :: Ct -> CtLoc +ctLoc = ctEvLoc . ctEvidence + +setCtLoc :: Ct -> CtLoc -> Ct +setCtLoc ct loc = ct { cc_ev = (cc_ev ct) { ctev_loc = loc } } + +ctOrigin :: Ct -> CtOrigin +ctOrigin = ctLocOrigin . ctLoc + +ctPred :: Ct -> PredType +-- See Note [Ct/evidence invariant] +ctPred ct = ctEvPred (ctEvidence ct) + +ctEvId :: Ct -> EvVar +-- The evidence Id for this Ct +ctEvId ct = ctEvEvId (ctEvidence ct) + +-- | Makes a new equality predicate with the same role as the given +-- evidence. +mkTcEqPredLikeEv :: CtEvidence -> TcType -> TcType -> TcType +mkTcEqPredLikeEv ev + = case predTypeEqRel pred of + NomEq -> mkPrimEqPred + ReprEq -> mkReprPrimEqPred + where + pred = ctEvPred ev + +-- | Get the flavour of the given 'Ct' +ctFlavour :: Ct -> CtFlavour +ctFlavour = ctEvFlavour . ctEvidence + +-- | Get the equality relation for the given 'Ct' +ctEqRel :: Ct -> EqRel +ctEqRel = ctEvEqRel . ctEvidence + +instance Outputable Ct where + ppr ct = ppr (ctEvidence ct) <+> parens pp_sort + where + pp_sort = case ct of + CTyEqCan {} -> text "CTyEqCan" + CFunEqCan {} -> text "CFunEqCan" + CNonCanonical {} -> text "CNonCanonical" + CDictCan { cc_pend_sc = pend_sc } + | pend_sc -> text "CDictCan(psc)" + | otherwise -> text "CDictCan" + CIrredCan { cc_insol = insol } + | insol -> text "CIrredCan(insol)" + | otherwise -> text "CIrredCan(sol)" + CHoleCan { cc_hole = hole } -> text "CHoleCan:" <+> ppr hole + CQuantCan (QCI { qci_pend_sc = pend_sc }) + | pend_sc -> text "CQuantCan(psc)" + | otherwise -> text "CQuantCan" + +{- +************************************************************************ +* * + Simple functions over evidence variables +* * +************************************************************************ +-} + +---------------- Getting free tyvars ------------------------- + +-- | Returns free variables of constraints as a non-deterministic set +tyCoVarsOfCt :: Ct -> TcTyCoVarSet +tyCoVarsOfCt = fvVarSet . tyCoFVsOfCt + +-- | Returns free variables of constraints as a deterministically ordered. +-- list. See Note [Deterministic FV] in FV. +tyCoVarsOfCtList :: Ct -> [TcTyCoVar] +tyCoVarsOfCtList = fvVarList . tyCoFVsOfCt + +-- | Returns free variables of constraints as a composable FV computation. +-- See Note [Deterministic FV] in FV. +tyCoFVsOfCt :: Ct -> FV +tyCoFVsOfCt (CTyEqCan { cc_tyvar = tv, cc_rhs = xi }) + = tyCoFVsOfType xi `unionFV` FV.unitFV tv + `unionFV` tyCoFVsOfType (tyVarKind tv) +tyCoFVsOfCt (CFunEqCan { cc_tyargs = tys, cc_fsk = fsk }) + = tyCoFVsOfTypes tys `unionFV` FV.unitFV fsk + `unionFV` tyCoFVsOfType (tyVarKind fsk) +tyCoFVsOfCt (CDictCan { cc_tyargs = tys }) = tyCoFVsOfTypes tys +tyCoFVsOfCt ct = tyCoFVsOfType (ctPred ct) + +-- | Returns free variables of a bag of constraints as a non-deterministic +-- set. See Note [Deterministic FV] in FV. +tyCoVarsOfCts :: Cts -> TcTyCoVarSet +tyCoVarsOfCts = fvVarSet . tyCoFVsOfCts + +-- | Returns free variables of a bag of constraints as a deterministically +-- odered list. See Note [Deterministic FV] in FV. +tyCoVarsOfCtsList :: Cts -> [TcTyCoVar] +tyCoVarsOfCtsList = fvVarList . tyCoFVsOfCts + +-- | Returns free variables of a bag of constraints as a composable FV +-- computation. See Note [Deterministic FV] in FV. +tyCoFVsOfCts :: Cts -> FV +tyCoFVsOfCts = foldrBag (unionFV . tyCoFVsOfCt) emptyFV + +-- | Returns free variables of WantedConstraints as a non-deterministic +-- set. See Note [Deterministic FV] in FV. +tyCoVarsOfWC :: WantedConstraints -> TyCoVarSet +-- Only called on *zonked* things, hence no need to worry about flatten-skolems +tyCoVarsOfWC = fvVarSet . tyCoFVsOfWC + +-- | Returns free variables of WantedConstraints as a deterministically +-- ordered list. See Note [Deterministic FV] in FV. +tyCoVarsOfWCList :: WantedConstraints -> [TyCoVar] +-- Only called on *zonked* things, hence no need to worry about flatten-skolems +tyCoVarsOfWCList = fvVarList . tyCoFVsOfWC + +-- | Returns free variables of WantedConstraints as a composable FV +-- computation. See Note [Deterministic FV] in FV. +tyCoFVsOfWC :: WantedConstraints -> FV +-- Only called on *zonked* things, hence no need to worry about flatten-skolems +tyCoFVsOfWC (WC { wc_simple = simple, wc_impl = implic }) + = tyCoFVsOfCts simple `unionFV` + tyCoFVsOfBag tyCoFVsOfImplic implic + +-- | Returns free variables of Implication as a composable FV computation. +-- See Note [Deterministic FV] in FV. +tyCoFVsOfImplic :: Implication -> FV +-- Only called on *zonked* things, hence no need to worry about flatten-skolems +tyCoFVsOfImplic (Implic { ic_skols = skols + , ic_given = givens + , ic_wanted = wanted }) + | isEmptyWC wanted + = emptyFV + | otherwise + = tyCoFVsVarBndrs skols $ + tyCoFVsVarBndrs givens $ + tyCoFVsOfWC wanted + +tyCoFVsOfBag :: (a -> FV) -> Bag a -> FV +tyCoFVsOfBag tvs_of = foldrBag (unionFV . tvs_of) emptyFV + +--------------------------- +dropDerivedWC :: WantedConstraints -> WantedConstraints +-- See Note [Dropping derived constraints] +dropDerivedWC wc@(WC { wc_simple = simples }) + = wc { wc_simple = dropDerivedSimples simples } + -- The wc_impl implications are already (recursively) filtered + +-------------------------- +dropDerivedSimples :: Cts -> Cts +-- Drop all Derived constraints, but make [W] back into [WD], +-- so that if we re-simplify these constraints we will get all +-- the right derived constraints re-generated. Forgetting this +-- step led to #12936 +dropDerivedSimples simples = mapMaybeBag dropDerivedCt simples + +dropDerivedCt :: Ct -> Maybe Ct +dropDerivedCt ct + = case ctEvFlavour ev of + Wanted WOnly -> Just (ct' { cc_ev = ev_wd }) + Wanted _ -> Just ct' + _ | isDroppableCt ct -> Nothing + | otherwise -> Just ct + where + ev = ctEvidence ct + ev_wd = ev { ctev_nosh = WDeriv } + ct' = setPendingScDict ct -- See Note [Resetting cc_pend_sc] + +{- Note [Resetting cc_pend_sc] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we discard Derived constraints, in dropDerivedSimples, we must +set the cc_pend_sc flag to True, so that if we re-process this +CDictCan we will re-generate its derived superclasses. Otherwise +we might miss some fundeps. #13662 showed this up. + +See Note [The superclass story] in TcCanonical. +-} + +isDroppableCt :: Ct -> Bool +isDroppableCt ct + = isDerived ev && not keep_deriv + -- Drop only derived constraints, and then only if they + -- obey Note [Dropping derived constraints] + where + ev = ctEvidence ct + loc = ctEvLoc ev + orig = ctLocOrigin loc + + keep_deriv + = case ct of + CHoleCan {} -> True + CIrredCan { cc_insol = insoluble } + -> keep_eq insoluble + _ -> keep_eq False + + keep_eq definitely_insoluble + | isGivenOrigin orig -- Arising only from givens + = definitely_insoluble -- Keep only definitely insoluble + | otherwise + = case orig of + KindEqOrigin {} -> True -- See Note [Dropping derived constraints] + + -- See Note [Dropping derived constraints] + -- For fundeps, drop wanted/wanted interactions + FunDepOrigin2 {} -> True -- Top-level/Wanted + FunDepOrigin1 _ loc1 _ loc2 + | g1 || g2 -> True -- Given/Wanted errors: keep all + | otherwise -> False -- Wanted/Wanted errors: discard + where + g1 = isGivenLoc loc1 + g2 = isGivenLoc loc2 + + _ -> False + +arisesFromGivens :: Ct -> Bool +arisesFromGivens ct + = case ctEvidence ct of + CtGiven {} -> True + CtWanted {} -> False + CtDerived { ctev_loc = loc } -> isGivenLoc loc + +isGivenLoc :: CtLoc -> Bool +isGivenLoc loc = isGivenOrigin (ctLocOrigin loc) + +isGivenOrigin :: CtOrigin -> Bool +isGivenOrigin (GivenOrigin {}) = True +isGivenOrigin (FunDepOrigin1 _ l1 _ l2) = isGivenLoc l1 && isGivenLoc l2 +isGivenOrigin (FunDepOrigin2 _ o1 _ _) = isGivenOrigin o1 +isGivenOrigin _ = False + +{- Note [Dropping derived constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general we discard derived constraints at the end of constraint solving; +see dropDerivedWC. For example + + * Superclasses: if we have an unsolved [W] (Ord a), we don't want to + complain about an unsolved [D] (Eq a) as well. + + * If we have [W] a ~ Int, [W] a ~ Bool, improvement will generate + [D] Int ~ Bool, and we don't want to report that because it's + incomprehensible. That is why we don't rewrite wanteds with wanteds! + +But (tiresomely) we do keep *some* Derived constraints: + + * Type holes are derived constraints, because they have no evidence + and we want to keep them, so we get the error report + + * Insoluble kind equalities (e.g. [D] * ~ (* -> *)), with + KindEqOrigin, may arise from a type equality a ~ Int#, say. See + Note [Equalities with incompatible kinds] in TcCanonical. + These need to be kept because the kind equalities might have different + source locations and hence different error messages. + E.g., test case dependent/should_fail/T11471 + + * We keep most derived equalities arising from functional dependencies + - Given/Given interactions (subset of FunDepOrigin1): + The definitely-insoluble ones reflect unreachable code. + + Others not-definitely-insoluble ones like [D] a ~ Int do not + reflect unreachable code; indeed if fundeps generated proofs, it'd + be a useful equality. See #14763. So we discard them. + + - Given/Wanted interacGiven or Wanted interacting with an + instance declaration (FunDepOrigin2) + + - Given/Wanted interactions (FunDepOrigin1); see #9612 + + - But for Wanted/Wanted interactions we do /not/ want to report an + error (#13506). Consider [W] C Int Int, [W] C Int Bool, with + a fundep on class C. We don't want to report an insoluble Int~Bool; + c.f. "wanteds do not rewrite wanteds". + +To distinguish these cases we use the CtOrigin. + +NB: we keep *all* derived insolubles under some circumstances: + + * They are looked at by simplifyInfer, to decide whether to + generalise. Example: [W] a ~ Int, [W] a ~ Bool + We get [D] Int ~ Bool, and indeed the constraints are insoluble, + and we want simplifyInfer to see that, even though we don't + ultimately want to generate an (inexplicable) error message from it + + +************************************************************************ +* * + CtEvidence + The "flavor" of a canonical constraint +* * +************************************************************************ +-} + +isWantedCt :: Ct -> Bool +isWantedCt = isWanted . ctEvidence + +isGivenCt :: Ct -> Bool +isGivenCt = isGiven . ctEvidence + +isDerivedCt :: Ct -> Bool +isDerivedCt = isDerived . ctEvidence + +isCTyEqCan :: Ct -> Bool +isCTyEqCan (CTyEqCan {}) = True +isCTyEqCan (CFunEqCan {}) = False +isCTyEqCan _ = False + +isCDictCan_Maybe :: Ct -> Maybe Class +isCDictCan_Maybe (CDictCan {cc_class = cls }) = Just cls +isCDictCan_Maybe _ = Nothing + +isCFunEqCan_maybe :: Ct -> Maybe (TyCon, [Type]) +isCFunEqCan_maybe (CFunEqCan { cc_fun = tc, cc_tyargs = xis }) = Just (tc, xis) +isCFunEqCan_maybe _ = Nothing + +isCFunEqCan :: Ct -> Bool +isCFunEqCan (CFunEqCan {}) = True +isCFunEqCan _ = False + +isCNonCanonical :: Ct -> Bool +isCNonCanonical (CNonCanonical {}) = True +isCNonCanonical _ = False + +isHoleCt:: Ct -> Bool +isHoleCt (CHoleCan {}) = True +isHoleCt _ = False + +isOutOfScopeCt :: Ct -> Bool +-- We treat expression holes representing out-of-scope variables a bit +-- differently when it comes to error reporting +isOutOfScopeCt (CHoleCan { cc_hole = ExprHole (OutOfScope {}) }) = True +isOutOfScopeCt _ = False + +isExprHoleCt :: Ct -> Bool +isExprHoleCt (CHoleCan { cc_hole = ExprHole {} }) = True +isExprHoleCt _ = False + +isTypeHoleCt :: Ct -> Bool +isTypeHoleCt (CHoleCan { cc_hole = TypeHole {} }) = True +isTypeHoleCt _ = False + + +{- Note [Custom type errors in constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +When GHC reports a type-error about an unsolved-constraint, we check +to see if the constraint contains any custom-type errors, and if so +we report them. Here are some examples of constraints containing type +errors: + +TypeError msg -- The actual constraint is a type error + +TypError msg ~ Int -- Some type was supposed to be Int, but ended up + -- being a type error instead + +Eq (TypeError msg) -- A class constraint is stuck due to a type error + +F (TypeError msg) ~ a -- A type function failed to evaluate due to a type err + +It is also possible to have constraints where the type error is nested deeper, +for example see #11990, and also: + +Eq (F (TypeError msg)) -- Here the type error is nested under a type-function + -- call, which failed to evaluate because of it, + -- and so the `Eq` constraint was unsolved. + -- This may happen when one function calls another + -- and the called function produced a custom type error. +-} + +-- | A constraint is considered to be a custom type error, if it contains +-- custom type errors anywhere in it. +-- See Note [Custom type errors in constraints] +getUserTypeErrorMsg :: Ct -> Maybe Type +getUserTypeErrorMsg ct = findUserTypeError (ctPred ct) + where + findUserTypeError t = msum ( userTypeError_maybe t + : map findUserTypeError (subTys t) + ) + + subTys t = case splitAppTys t of + (t,[]) -> + case splitTyConApp_maybe t of + Nothing -> [] + Just (_,ts) -> ts + (t,ts) -> t : ts + + + + +isUserTypeErrorCt :: Ct -> Bool +isUserTypeErrorCt ct = case getUserTypeErrorMsg ct of + Just _ -> True + _ -> False + +isPendingScDict :: Ct -> Maybe Ct +-- Says whether this is a CDictCan with cc_pend_sc is True, +-- AND if so flips the flag +isPendingScDict ct@(CDictCan { cc_pend_sc = True }) + = Just (ct { cc_pend_sc = False }) +isPendingScDict _ = Nothing + +isPendingScInst :: QCInst -> Maybe QCInst +-- Same as isPrendinScDict, but for QCInsts +isPendingScInst qci@(QCI { qci_pend_sc = True }) + = Just (qci { qci_pend_sc = False }) +isPendingScInst _ = Nothing + +setPendingScDict :: Ct -> Ct +-- Set the cc_pend_sc flag to True +setPendingScDict ct@(CDictCan { cc_pend_sc = False }) + = ct { cc_pend_sc = True } +setPendingScDict ct = ct + +superClassesMightHelp :: WantedConstraints -> Bool +-- ^ True if taking superclasses of givens, or of wanteds (to perhaps +-- expose more equalities or functional dependencies) might help to +-- solve this constraint. See Note [When superclasses help] +superClassesMightHelp (WC { wc_simple = simples, wc_impl = implics }) + = anyBag might_help_ct simples || anyBag might_help_implic implics + where + might_help_implic ic + | IC_Unsolved <- ic_status ic = superClassesMightHelp (ic_wanted ic) + | otherwise = False + + might_help_ct ct = isWantedCt ct && not (is_ip ct) + + is_ip (CDictCan { cc_class = cls }) = isIPClass cls + is_ip _ = False + +getPendingWantedScs :: Cts -> ([Ct], Cts) +getPendingWantedScs simples + = mapAccumBagL get [] simples + where + get acc ct | Just ct' <- isPendingScDict ct + = (ct':acc, ct') + | otherwise + = (acc, ct) + +{- Note [When superclasses help] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +First read Note [The superclass story] in TcCanonical. + +We expand superclasses and iterate only if there is at unsolved wanted +for which expansion of superclasses (e.g. from given constraints) +might actually help. The function superClassesMightHelp tells if +doing this superclass expansion might help solve this constraint. +Note that + + * We look inside implications; maybe it'll help to expand the Givens + at level 2 to help solve an unsolved Wanted buried inside an + implication. E.g. + forall a. Ord a => forall b. [W] Eq a + + * Superclasses help only for Wanted constraints. Derived constraints + are not really "unsolved" and we certainly don't want them to + trigger superclass expansion. This was a good part of the loop + in #11523 + + * Even for Wanted constraints, we say "no" for implicit parameters. + we have [W] ?x::ty, expanding superclasses won't help: + - Superclasses can't be implicit parameters + - If we have a [G] ?x:ty2, then we'll have another unsolved + [D] ty ~ ty2 (from the functional dependency) + which will trigger superclass expansion. + + It's a bit of a special case, but it's easy to do. The runtime cost + is low because the unsolved set is usually empty anyway (errors + aside), and the first non-imlicit-parameter will terminate the search. + + The special case is worth it (#11480, comment:2) because it + applies to CallStack constraints, which aren't type errors. If we have + f :: (C a) => blah + f x = ...undefined... + we'll get a CallStack constraint. If that's the only unsolved + constraint it'll eventually be solved by defaulting. So we don't + want to emit warnings about hitting the simplifier's iteration + limit. A CallStack constraint really isn't an unsolved + constraint; it can always be solved by defaulting. +-} + +singleCt :: Ct -> Cts +singleCt = unitBag + +andCts :: Cts -> Cts -> Cts +andCts = unionBags + +listToCts :: [Ct] -> Cts +listToCts = listToBag + +ctsElts :: Cts -> [Ct] +ctsElts = bagToList + +consCts :: Ct -> Cts -> Cts +consCts = consBag + +snocCts :: Cts -> Ct -> Cts +snocCts = snocBag + +extendCtsList :: Cts -> [Ct] -> Cts +extendCtsList cts xs | null xs = cts + | otherwise = cts `unionBags` listToBag xs + +andManyCts :: [Cts] -> Cts +andManyCts = unionManyBags + +emptyCts :: Cts +emptyCts = emptyBag + +isEmptyCts :: Cts -> Bool +isEmptyCts = isEmptyBag + +pprCts :: Cts -> SDoc +pprCts cts = vcat (map ppr (bagToList cts)) + +{- +************************************************************************ +* * + Wanted constraints + These are forced to be in TcRnTypes because + TcLclEnv mentions WantedConstraints + WantedConstraint mentions CtLoc + CtLoc mentions ErrCtxt + ErrCtxt mentions TcM +* * +v%************************************************************************ +-} + +data WantedConstraints + = WC { wc_simple :: Cts -- Unsolved constraints, all wanted + , wc_impl :: Bag Implication + } + +emptyWC :: WantedConstraints +emptyWC = WC { wc_simple = emptyBag, wc_impl = emptyBag } + +mkSimpleWC :: [CtEvidence] -> WantedConstraints +mkSimpleWC cts + = WC { wc_simple = listToBag (map mkNonCanonical cts) + , wc_impl = emptyBag } + +mkImplicWC :: Bag Implication -> WantedConstraints +mkImplicWC implic + = WC { wc_simple = emptyBag, wc_impl = implic } + +isEmptyWC :: WantedConstraints -> Bool +isEmptyWC (WC { wc_simple = f, wc_impl = i }) + = isEmptyBag f && isEmptyBag i + + +-- | Checks whether a the given wanted constraints are solved, i.e. +-- that there are no simple constraints left and all the implications +-- are solved. +isSolvedWC :: WantedConstraints -> Bool +isSolvedWC WC {wc_simple = wc_simple, wc_impl = wc_impl} = + isEmptyBag wc_simple && allBag (isSolvedStatus . ic_status) wc_impl + +andWC :: WantedConstraints -> WantedConstraints -> WantedConstraints +andWC (WC { wc_simple = f1, wc_impl = i1 }) + (WC { wc_simple = f2, wc_impl = i2 }) + = WC { wc_simple = f1 `unionBags` f2 + , wc_impl = i1 `unionBags` i2 } + +unionsWC :: [WantedConstraints] -> WantedConstraints +unionsWC = foldr andWC emptyWC + +addSimples :: WantedConstraints -> Bag Ct -> WantedConstraints +addSimples wc cts + = wc { wc_simple = wc_simple wc `unionBags` cts } + -- Consider: Put the new constraints at the front, so they get solved first + +addImplics :: WantedConstraints -> Bag Implication -> WantedConstraints +addImplics wc implic = wc { wc_impl = wc_impl wc `unionBags` implic } + +addInsols :: WantedConstraints -> Bag Ct -> WantedConstraints +addInsols wc cts + = wc { wc_simple = wc_simple wc `unionBags` cts } + +insolublesOnly :: WantedConstraints -> WantedConstraints +-- Keep only the definitely-insoluble constraints +insolublesOnly (WC { wc_simple = simples, wc_impl = implics }) + = WC { wc_simple = filterBag insolubleCt simples + , wc_impl = mapBag implic_insols_only implics } + where + implic_insols_only implic + = implic { ic_wanted = insolublesOnly (ic_wanted implic) } + +isSolvedStatus :: ImplicStatus -> Bool +isSolvedStatus (IC_Solved {}) = True +isSolvedStatus _ = False + +isInsolubleStatus :: ImplicStatus -> Bool +isInsolubleStatus IC_Insoluble = True +isInsolubleStatus IC_BadTelescope = True +isInsolubleStatus _ = False + +insolubleImplic :: Implication -> Bool +insolubleImplic ic = isInsolubleStatus (ic_status ic) + +insolubleWC :: WantedConstraints -> Bool +insolubleWC (WC { wc_impl = implics, wc_simple = simples }) + = anyBag insolubleCt simples + || anyBag insolubleImplic implics + +insolubleCt :: Ct -> Bool +-- Definitely insoluble, in particular /excluding/ type-hole constraints +-- Namely: a) an equality constraint +-- b) that is insoluble +-- c) and does not arise from a Given +insolubleCt ct + | isHoleCt ct = isOutOfScopeCt ct -- See Note [Insoluble holes] + | not (insolubleEqCt ct) = False + | arisesFromGivens ct = False -- See Note [Given insolubles] + | otherwise = True + +insolubleEqCt :: Ct -> Bool +-- Returns True of /equality/ constraints +-- that are /definitely/ insoluble +-- It won't detect some definite errors like +-- F a ~ T (F a) +-- where F is a type family, which actually has an occurs check +-- +-- The function is tuned for application /after/ constraint solving +-- i.e. assuming canonicalisation has been done +-- E.g. It'll reply True for a ~ [a] +-- but False for [a] ~ a +-- and +-- True for Int ~ F a Int +-- but False for Maybe Int ~ F a Int Int +-- (where F is an arity-1 type function) +insolubleEqCt (CIrredCan { cc_insol = insol }) = insol +insolubleEqCt _ = False + +instance Outputable WantedConstraints where + ppr (WC {wc_simple = s, wc_impl = i}) + = text "WC" <+> braces (vcat + [ ppr_bag (text "wc_simple") s + , ppr_bag (text "wc_impl") i ]) + +ppr_bag :: Outputable a => SDoc -> Bag a -> SDoc +ppr_bag doc bag + | isEmptyBag bag = empty + | otherwise = hang (doc <+> equals) + 2 (foldrBag (($$) . ppr) empty bag) + +{- Note [Given insolubles] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#14325, comment:) + class (a~b) => C a b + + foo :: C a c => a -> c + foo x = x + + hm3 :: C (f b) b => b -> f b + hm3 x = foo x + +In the RHS of hm3, from the [G] C (f b) b we get the insoluble +[G] f b ~# b. Then we also get an unsolved [W] C b (f b). +Residual implication looks like + forall b. C (f b) b => [G] f b ~# b + [W] C f (f b) + +We do /not/ want to set the implication status to IC_Insoluble, +because that'll suppress reports of [W] C b (f b). But we +may not report the insoluble [G] f b ~# b either (see Note [Given errors] +in TcErrors), so we may fail to report anything at all! Yikes. + +The same applies to Derived constraints that /arise from/ Givens. +E.g. f :: (C Int [a]) => blah +where a fundep means we get + [D] Int ~ [a] +By the same reasoning we must not suppress other errors (#15767) + +Bottom line: insolubleWC (called in TcSimplify.setImplicationStatus) + should ignore givens even if they are insoluble. + +Note [Insoluble holes] +~~~~~~~~~~~~~~~~~~~~~~ +Hole constraints that ARE NOT treated as truly insoluble: + a) type holes, arising from PartialTypeSignatures, + b) "true" expression holes arising from TypedHoles + +An "expression hole" or "type hole" constraint isn't really an error +at all; it's a report saying "_ :: Int" here. But an out-of-scope +variable masquerading as expression holes IS treated as truly +insoluble, so that it trumps other errors during error reporting. +Yuk! + +************************************************************************ +* * + Implication constraints +* * +************************************************************************ +-} + +data Implication + = Implic { -- Invariants for a tree of implications: + -- see TcType Note [TcLevel and untouchable type variables] + + ic_tclvl :: TcLevel, -- TcLevel of unification variables + -- allocated /inside/ this implication + + ic_skols :: [TcTyVar], -- Introduced skolems + ic_info :: SkolemInfo, -- See Note [Skolems in an implication] + -- See Note [Shadowing in a constraint] + ic_telescope :: Maybe SDoc, -- User-written telescope, if there is one + -- The list of skolems is order-checked + -- if and only if this is a Just. + -- See Note [Keeping scoped variables in order: Explicit] + -- in TcHsType + + ic_given :: [EvVar], -- Given evidence variables + -- (order does not matter) + -- See Invariant (GivenInv) in TcType + + ic_no_eqs :: Bool, -- True <=> ic_givens have no equalities, for sure + -- False <=> ic_givens might have equalities + + ic_env :: Env TcGblEnv TcLclEnv, + -- Records the Env at the time of creation. + -- + -- This is primarly needed for the enclosed + -- TcLclEnv, which gives the source location + -- and error context for the implication, and + -- hence for all the given evidence variables. + -- + -- The enclosed DynFlags also influences error + -- reporting. See Note [Avoid + -- -Winaccessible-code when deriving] in + -- TcInstDcls. + + ic_wanted :: WantedConstraints, -- The wanteds + -- See Invariang (WantedInf) in TcType + + ic_binds :: EvBindsVar, -- Points to the place to fill in the + -- abstraction and bindings. + + -- The ic_need fields keep track of which Given evidence + -- is used by this implication or its children + -- NB: including stuff used by nested implications that have since + -- been discarded + ic_need_inner :: VarSet, -- Includes all used Given evidence + ic_need_outer :: VarSet, -- Includes only the free Given evidence + -- i.e. ic_need_inner after deleting + -- (a) givens (b) binders of ic_binds + + ic_status :: ImplicStatus + } + +-- | Create a new 'Implication' with as many sensible defaults for its fields +-- as possible. Note that the 'ic_tclvl', 'ic_binds', and 'ic_info' fields do +-- /not/ have sensible defaults, so they are initialized with lazy thunks that +-- will 'panic' if forced, so one should take care to initialize these fields +-- after creation. +-- +-- This is monadic purely to look up the 'Env', which is used to initialize +-- 'ic_env'. +newImplication :: TcM Implication +newImplication + = do env <- getEnv + return (implicationPrototype { ic_env = env }) + +implicationPrototype :: Implication +implicationPrototype + = Implic { -- These fields must be initialised + ic_tclvl = panic "newImplic:tclvl" + , ic_binds = panic "newImplic:binds" + , ic_info = panic "newImplic:info" + , ic_env = panic "newImplic:env" + + -- The rest have sensible default values + , ic_skols = [] + , ic_telescope = Nothing + , ic_given = [] + , ic_wanted = emptyWC + , ic_no_eqs = False + , ic_status = IC_Unsolved + , ic_need_inner = emptyVarSet + , ic_need_outer = emptyVarSet } + +-- | Retrieve the enclosed 'TcLclEnv' from an 'Implication'. +implicLclEnv :: Implication -> TcLclEnv +implicLclEnv = env_lcl . ic_env + +-- | Retrieve the enclosed 'DynFlags' from an 'Implication'. +implicDynFlags :: Implication -> DynFlags +implicDynFlags = hsc_dflags . env_top . ic_env + +data ImplicStatus + = IC_Solved -- All wanteds in the tree are solved, all the way down + { ics_dead :: [EvVar] } -- Subset of ic_given that are not needed + -- See Note [Tracking redundant constraints] in TcSimplify + + | IC_Insoluble -- At least one insoluble constraint in the tree + + | IC_BadTelescope -- solved, but the skolems in the telescope are out of + -- dependency order + + | IC_Unsolved -- Neither of the above; might go either way + +instance Outputable Implication where + ppr (Implic { ic_tclvl = tclvl, ic_skols = skols + , ic_given = given, ic_no_eqs = no_eqs + , ic_wanted = wanted, ic_status = status + , ic_binds = binds + , ic_need_inner = need_in, ic_need_outer = need_out + , ic_info = info }) + = hang (text "Implic" <+> lbrace) + 2 (sep [ text "TcLevel =" <+> ppr tclvl + , text "Skolems =" <+> pprTyVars skols + , text "No-eqs =" <+> ppr no_eqs + , text "Status =" <+> ppr status + , hang (text "Given =") 2 (pprEvVars given) + , hang (text "Wanted =") 2 (ppr wanted) + , text "Binds =" <+> ppr binds + , whenPprDebug (text "Needed inner =" <+> ppr need_in) + , whenPprDebug (text "Needed outer =" <+> ppr need_out) + , pprSkolInfo info ] <+> rbrace) + +instance Outputable ImplicStatus where + ppr IC_Insoluble = text "Insoluble" + ppr IC_BadTelescope = text "Bad telescope" + ppr IC_Unsolved = text "Unsolved" + ppr (IC_Solved { ics_dead = dead }) + = text "Solved" <+> (braces (text "Dead givens =" <+> ppr dead)) + +{- +Note [Needed evidence variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Th ic_need_evs field holds the free vars of ic_binds, and all the +ic_binds in nested implications. + + * Main purpose: if one of the ic_givens is not mentioned in here, it + is redundant. + + * solveImplication may drop an implication altogether if it has no + remaining 'wanteds'. But we still track the free vars of its + evidence binds, even though it has now disappeared. + +Note [Shadowing in a constraint] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We assume NO SHADOWING in a constraint. Specifically + * The unification variables are all implicitly quantified at top + level, and are all unique + * The skolem variables bound in ic_skols are all freah when the + implication is created. +So we can safely substitute. For example, if we have + forall a. a~Int => ...(forall b. ...a...)... +we can push the (a~Int) constraint inwards in the "givens" without +worrying that 'b' might clash. + +Note [Skolems in an implication] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The skolems in an implication are not there to perform a skolem escape +check. That happens because all the environment variables are in the +untouchables, and therefore cannot be unified with anything at all, +let alone the skolems. + +Instead, ic_skols is used only when considering floating a constraint +outside the implication in TcSimplify.floatEqualities or +TcSimplify.approximateImplications + +Note [Insoluble constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Some of the errors that we get during canonicalization are best +reported when all constraints have been simplified as much as +possible. For instance, assume that during simplification the +following constraints arise: + + [Wanted] F alpha ~ uf1 + [Wanted] beta ~ uf1 beta + +When canonicalizing the wanted (beta ~ uf1 beta), if we eagerly fail +we will simply see a message: + 'Can't construct the infinite type beta ~ uf1 beta' +and the user has no idea what the uf1 variable is. + +Instead our plan is that we will NOT fail immediately, but: + (1) Record the "frozen" error in the ic_insols field + (2) Isolate the offending constraint from the rest of the inerts + (3) Keep on simplifying/canonicalizing + +At the end, we will hopefully have substituted uf1 := F alpha, and we +will be able to report a more informative error: + 'Can't construct the infinite type beta ~ F alpha beta' + +Insoluble constraints *do* include Derived constraints. For example, +a functional dependency might give rise to [D] Int ~ Bool, and we must +report that. If insolubles did not contain Deriveds, reportErrors would +never see it. + + +************************************************************************ +* * + Pretty printing +* * +************************************************************************ +-} + +pprEvVars :: [EvVar] -> SDoc -- Print with their types +pprEvVars ev_vars = vcat (map pprEvVarWithType ev_vars) + +pprEvVarTheta :: [EvVar] -> SDoc +pprEvVarTheta ev_vars = pprTheta (map evVarPred ev_vars) + +pprEvVarWithType :: EvVar -> SDoc +pprEvVarWithType v = ppr v <+> dcolon <+> pprType (evVarPred v) + + + +-- | Wraps the given type with the constraints (via ic_given) in the given +-- implication, according to the variables mentioned (via ic_skols) +-- in the implication, but taking care to only wrap those variables +-- that are mentioned in the type or the implication. +wrapTypeWithImplication :: Type -> Implication -> Type +wrapTypeWithImplication ty impl = wrapType ty mentioned_skols givens + where givens = map idType $ ic_given impl + skols = ic_skols impl + freeVars = fvVarSet $ tyCoFVsOfTypes (ty:givens) + mentioned_skols = filter (`elemVarSet` freeVars) skols + +wrapType :: Type -> [TyVar] -> [PredType] -> Type +wrapType ty skols givens = mkSpecForAllTys skols $ mkPhiTy givens ty + + +{- +************************************************************************ +* * + CtEvidence +* * +************************************************************************ + +Note [Evidence field of CtEvidence] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +During constraint solving we never look at the type of ctev_evar/ctev_dest; +instead we look at the ctev_pred field. The evtm/evar field +may be un-zonked. + +Note [Bind new Givens immediately] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For Givens we make new EvVars and bind them immediately. Two main reasons: + * Gain sharing. E.g. suppose we start with g :: C a b, where + class D a => C a b + class (E a, F a) => D a + If we generate all g's superclasses as separate EvTerms we might + get selD1 (selC1 g) :: E a + selD2 (selC1 g) :: F a + selC1 g :: D a + which we could do more economically as: + g1 :: D a = selC1 g + g2 :: E a = selD1 g1 + g3 :: F a = selD2 g1 + + * For *coercion* evidence we *must* bind each given: + class (a~b) => C a b where .... + f :: C a b => .... + Then in f's Givens we have g:(C a b) and the superclass sc(g,0):a~b. + But that superclass selector can't (yet) appear in a coercion + (see evTermCoercion), so the easy thing is to bind it to an Id. + +So a Given has EvVar inside it rather than (as previously) an EvTerm. + +-} + +-- | A place for type-checking evidence to go after it is generated. +-- Wanted equalities are always HoleDest; other wanteds are always +-- EvVarDest. +data TcEvDest + = EvVarDest EvVar -- ^ bind this var to the evidence + -- EvVarDest is always used for non-type-equalities + -- e.g. class constraints + + | HoleDest CoercionHole -- ^ fill in this hole with the evidence + -- HoleDest is always used for type-equalities + -- See Note [Coercion holes] in TyCoRep + +data CtEvidence + = CtGiven -- Truly given, not depending on subgoals + { ctev_pred :: TcPredType -- See Note [Ct/evidence invariant] + , ctev_evar :: EvVar -- See Note [Evidence field of CtEvidence] + , ctev_loc :: CtLoc } + + + | CtWanted -- Wanted goal + { ctev_pred :: TcPredType -- See Note [Ct/evidence invariant] + , ctev_dest :: TcEvDest + , ctev_nosh :: ShadowInfo -- See Note [Constraint flavours] + , ctev_loc :: CtLoc } + + | CtDerived -- A goal that we don't really have to solve and can't + -- immediately rewrite anything other than a derived + -- (there's no evidence!) but if we do manage to solve + -- it may help in solving other goals. + { ctev_pred :: TcPredType + , ctev_loc :: CtLoc } + +ctEvPred :: CtEvidence -> TcPredType +-- The predicate of a flavor +ctEvPred = ctev_pred + +ctEvLoc :: CtEvidence -> CtLoc +ctEvLoc = ctev_loc + +ctEvOrigin :: CtEvidence -> CtOrigin +ctEvOrigin = ctLocOrigin . ctEvLoc + +-- | Get the equality relation relevant for a 'CtEvidence' +ctEvEqRel :: CtEvidence -> EqRel +ctEvEqRel = predTypeEqRel . ctEvPred + +-- | Get the role relevant for a 'CtEvidence' +ctEvRole :: CtEvidence -> Role +ctEvRole = eqRelRole . ctEvEqRel + +ctEvTerm :: CtEvidence -> EvTerm +ctEvTerm ev = EvExpr (ctEvExpr ev) + +ctEvExpr :: CtEvidence -> EvExpr +ctEvExpr ev@(CtWanted { ctev_dest = HoleDest _ }) + = Coercion $ ctEvCoercion ev +ctEvExpr ev = evId (ctEvEvId ev) + +ctEvCoercion :: HasDebugCallStack => CtEvidence -> Coercion +ctEvCoercion (CtGiven { ctev_evar = ev_id }) + = mkTcCoVarCo ev_id +ctEvCoercion (CtWanted { ctev_dest = dest }) + | HoleDest hole <- dest + = -- ctEvCoercion is only called on type equalities + -- and they always have HoleDests + mkHoleCo hole +ctEvCoercion ev + = pprPanic "ctEvCoercion" (ppr ev) + +ctEvEvId :: CtEvidence -> EvVar +ctEvEvId (CtWanted { ctev_dest = EvVarDest ev }) = ev +ctEvEvId (CtWanted { ctev_dest = HoleDest h }) = coHoleCoVar h +ctEvEvId (CtGiven { ctev_evar = ev }) = ev +ctEvEvId ctev@(CtDerived {}) = pprPanic "ctEvId:" (ppr ctev) + +instance Outputable TcEvDest where + ppr (HoleDest h) = text "hole" <> ppr h + ppr (EvVarDest ev) = ppr ev + +instance Outputable CtEvidence where + ppr ev = ppr (ctEvFlavour ev) + <+> pp_ev + <+> braces (ppr (ctl_depth (ctEvLoc ev))) <> dcolon + -- Show the sub-goal depth too + <+> ppr (ctEvPred ev) + where + pp_ev = case ev of + CtGiven { ctev_evar = v } -> ppr v + CtWanted {ctev_dest = d } -> ppr d + CtDerived {} -> text "_" + +isWanted :: CtEvidence -> Bool +isWanted (CtWanted {}) = True +isWanted _ = False + +isGiven :: CtEvidence -> Bool +isGiven (CtGiven {}) = True +isGiven _ = False + +isDerived :: CtEvidence -> Bool +isDerived (CtDerived {}) = True +isDerived _ = False + +{- +%************************************************************************ +%* * + CtFlavour +%* * +%************************************************************************ + +Note [Constraint flavours] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Constraints come in four flavours: + +* [G] Given: we have evidence + +* [W] Wanted WOnly: we want evidence + +* [D] Derived: any solution must satisfy this constraint, but + we don't need evidence for it. Examples include: + - superclasses of [W] class constraints + - equalities arising from functional dependencies + or injectivity + +* [WD] Wanted WDeriv: a single constraint that represents + both [W] and [D] + We keep them paired as one both for efficiency, and because + when we have a finite map F tys -> CFunEqCan, it's inconvenient + to have two CFunEqCans in the range + +The ctev_nosh field of a Wanted distinguishes between [W] and [WD] + +Wanted constraints are born as [WD], but are split into [W] and its +"shadow" [D] in TcSMonad.maybeEmitShadow. + +See Note [The improvement story and derived shadows] in TcSMonad +-} + +data CtFlavour -- See Note [Constraint flavours] + = Given + | Wanted ShadowInfo + | Derived + deriving Eq + +data ShadowInfo + = WDeriv -- [WD] This Wanted constraint has no Derived shadow, + -- so it behaves like a pair of a Wanted and a Derived + | WOnly -- [W] It has a separate derived shadow + -- See Note [Derived shadows] + deriving( Eq ) + +isGivenOrWDeriv :: CtFlavour -> Bool +isGivenOrWDeriv Given = True +isGivenOrWDeriv (Wanted WDeriv) = True +isGivenOrWDeriv _ = False + +instance Outputable CtFlavour where + ppr Given = text "[G]" + ppr (Wanted WDeriv) = text "[WD]" + ppr (Wanted WOnly) = text "[W]" + ppr Derived = text "[D]" + +ctEvFlavour :: CtEvidence -> CtFlavour +ctEvFlavour (CtWanted { ctev_nosh = nosh }) = Wanted nosh +ctEvFlavour (CtGiven {}) = Given +ctEvFlavour (CtDerived {}) = Derived + +-- | Whether or not one 'Ct' can rewrite another is determined by its +-- flavour and its equality relation. See also +-- Note [Flavours with roles] in TcSMonad +type CtFlavourRole = (CtFlavour, EqRel) + +-- | Extract the flavour, role, and boxity from a 'CtEvidence' +ctEvFlavourRole :: CtEvidence -> CtFlavourRole +ctEvFlavourRole ev = (ctEvFlavour ev, ctEvEqRel ev) + +-- | Extract the flavour and role from a 'Ct' +ctFlavourRole :: Ct -> CtFlavourRole +-- Uses short-cuts to role for special cases +ctFlavourRole (CDictCan { cc_ev = ev }) + = (ctEvFlavour ev, NomEq) +ctFlavourRole (CTyEqCan { cc_ev = ev, cc_eq_rel = eq_rel }) + = (ctEvFlavour ev, eq_rel) +ctFlavourRole (CFunEqCan { cc_ev = ev }) + = (ctEvFlavour ev, NomEq) +ctFlavourRole (CHoleCan { cc_ev = ev }) + = (ctEvFlavour ev, NomEq) -- NomEq: CHoleCans can be rewritten by + -- by nominal equalities but empahatically + -- not by representational equalities +ctFlavourRole ct + = ctEvFlavourRole (ctEvidence ct) + +{- Note [eqCanRewrite] +~~~~~~~~~~~~~~~~~~~~~~ +(eqCanRewrite ct1 ct2) holds if the constraint ct1 (a CTyEqCan of form +tv ~ ty) can be used to rewrite ct2. It must satisfy the properties of +a can-rewrite relation, see Definition [Can-rewrite relation] in +TcSMonad. + +With the solver handling Coercible constraints like equality constraints, +the rewrite conditions must take role into account, never allowing +a representational equality to rewrite a nominal one. + +Note [Wanteds do not rewrite Wanteds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't allow Wanteds to rewrite Wanteds, because that can give rise +to very confusing type error messages. A good example is #8450. +Here's another + f :: a -> Bool + f x = ( [x,'c'], [x,True] ) `seq` True +Here we get + [W] a ~ Char + [W] a ~ Bool +but we do not want to complain about Bool ~ Char! + +Note [Deriveds do rewrite Deriveds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +However we DO allow Deriveds to rewrite Deriveds, because that's how +improvement works; see Note [The improvement story] in TcInteract. + +However, for now at least I'm only letting (Derived,NomEq) rewrite +(Derived,NomEq) and not doing anything for ReprEq. If we have + eqCanRewriteFR (Derived, NomEq) (Derived, _) = True +then we lose property R2 of Definition [Can-rewrite relation] +in TcSMonad + R2. If f1 >= f, and f2 >= f, + then either f1 >= f2 or f2 >= f1 +Consider f1 = (Given, ReprEq) + f2 = (Derived, NomEq) + f = (Derived, ReprEq) + +I thought maybe we could never get Derived ReprEq constraints, but +we can; straight from the Wanteds during improvement. And from a Derived +ReprEq we could conceivably get a Derived NomEq improvement (by decomposing +a type constructor with Nomninal role), and hence unify. +-} + +eqCanRewrite :: EqRel -> EqRel -> Bool +eqCanRewrite NomEq _ = True +eqCanRewrite ReprEq ReprEq = True +eqCanRewrite ReprEq NomEq = False + +eqCanRewriteFR :: CtFlavourRole -> CtFlavourRole -> Bool +-- Can fr1 actually rewrite fr2? +-- Very important function! +-- See Note [eqCanRewrite] +-- See Note [Wanteds do not rewrite Wanteds] +-- See Note [Deriveds do rewrite Deriveds] +eqCanRewriteFR (Given, r1) (_, r2) = eqCanRewrite r1 r2 +eqCanRewriteFR (Wanted WDeriv, NomEq) (Derived, NomEq) = True +eqCanRewriteFR (Derived, NomEq) (Derived, NomEq) = True +eqCanRewriteFR _ _ = False + +eqMayRewriteFR :: CtFlavourRole -> CtFlavourRole -> Bool +-- Is it /possible/ that fr1 can rewrite fr2? +-- This is used when deciding which inerts to kick out, +-- at which time a [WD] inert may be split into [W] and [D] +eqMayRewriteFR (Wanted WDeriv, NomEq) (Wanted WDeriv, NomEq) = True +eqMayRewriteFR (Derived, NomEq) (Wanted WDeriv, NomEq) = True +eqMayRewriteFR fr1 fr2 = eqCanRewriteFR fr1 fr2 + +----------------- +{- Note [funEqCanDischarge] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have two CFunEqCans with the same LHS: + (x1:F ts ~ f1) `funEqCanDischarge` (x2:F ts ~ f2) +Can we drop x2 in favour of x1, either unifying +f2 (if it's a flatten meta-var) or adding a new Given +(f1 ~ f2), if x2 is a Given? + +Answer: yes if funEqCanDischarge is true. +-} + +funEqCanDischarge + :: CtEvidence -> CtEvidence + -> ( SwapFlag -- NotSwapped => lhs can discharge rhs + -- Swapped => rhs can discharge lhs + , Bool) -- True <=> upgrade non-discharded one + -- from [W] to [WD] +-- See Note [funEqCanDischarge] +funEqCanDischarge ev1 ev2 + = ASSERT2( ctEvEqRel ev1 == NomEq, ppr ev1 ) + ASSERT2( ctEvEqRel ev2 == NomEq, ppr ev2 ) + -- CFunEqCans are all Nominal, hence asserts + funEqCanDischargeF (ctEvFlavour ev1) (ctEvFlavour ev2) + +funEqCanDischargeF :: CtFlavour -> CtFlavour -> (SwapFlag, Bool) +funEqCanDischargeF Given _ = (NotSwapped, False) +funEqCanDischargeF _ Given = (IsSwapped, False) +funEqCanDischargeF (Wanted WDeriv) _ = (NotSwapped, False) +funEqCanDischargeF _ (Wanted WDeriv) = (IsSwapped, True) +funEqCanDischargeF (Wanted WOnly) (Wanted WOnly) = (NotSwapped, False) +funEqCanDischargeF (Wanted WOnly) Derived = (NotSwapped, True) +funEqCanDischargeF Derived (Wanted WOnly) = (IsSwapped, True) +funEqCanDischargeF Derived Derived = (NotSwapped, False) + + +{- Note [eqCanDischarge] +~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have two identical CTyEqCan equality constraints +(i.e. both LHS and RHS are the same) + (x1:a~t) `eqCanDischarge` (xs:a~t) +Can we just drop x2 in favour of x1? + +Answer: yes if eqCanDischarge is true. + +Note that we do /not/ allow Wanted to discharge Derived. +We must keep both. Why? Because the Derived may rewrite +other Deriveds in the model whereas the Wanted cannot. + +However a Wanted can certainly discharge an identical Wanted. So +eqCanDischarge does /not/ define a can-rewrite relation in the +sense of Definition [Can-rewrite relation] in TcSMonad. + +We /do/ say that a [W] can discharge a [WD]. In evidence terms it +certainly can, and the /caller/ arranges that the otherwise-lost [D] +is spat out as a new Derived. -} + +eqCanDischargeFR :: CtFlavourRole -> CtFlavourRole -> Bool +-- See Note [eqCanDischarge] +eqCanDischargeFR (f1,r1) (f2, r2) = eqCanRewrite r1 r2 + && eqCanDischargeF f1 f2 + +eqCanDischargeF :: CtFlavour -> CtFlavour -> Bool +eqCanDischargeF Given _ = True +eqCanDischargeF (Wanted _) (Wanted _) = True +eqCanDischargeF (Wanted WDeriv) Derived = True +eqCanDischargeF Derived Derived = True +eqCanDischargeF _ _ = False + + +{- +************************************************************************ +* * + SubGoalDepth +* * +************************************************************************ + +Note [SubGoalDepth] +~~~~~~~~~~~~~~~~~~~ +The 'SubGoalDepth' takes care of stopping the constraint solver from looping. + +The counter starts at zero and increases. It includes dictionary constraints, +equality simplification, and type family reduction. (Why combine these? Because +it's actually quite easy to mistake one for another, in sufficiently involved +scenarios, like ConstraintKinds.) + +The flag -fcontext-stack=n (not very well named!) fixes the maximium +level. + +* The counter includes the depth of type class instance declarations. Example: + [W] d{7} : Eq [Int] + That is d's dictionary-constraint depth is 7. If we use the instance + $dfEqList :: Eq a => Eq [a] + to simplify it, we get + d{7} = $dfEqList d'{8} + where d'{8} : Eq Int, and d' has depth 8. + + For civilised (decidable) instance declarations, each increase of + depth removes a type constructor from the type, so the depth never + gets big; i.e. is bounded by the structural depth of the type. + +* The counter also increments when resolving +equalities involving type functions. Example: + Assume we have a wanted at depth 7: + [W] d{7} : F () ~ a + If there is a type function equation "F () = Int", this would be rewritten to + [W] d{8} : Int ~ a + and remembered as having depth 8. + + Again, without UndecidableInstances, this counter is bounded, but without it + can resolve things ad infinitum. Hence there is a maximum level. + +* Lastly, every time an equality is rewritten, the counter increases. Again, + rewriting an equality constraint normally makes progress, but it's possible + the "progress" is just the reduction of an infinitely-reducing type family. + Hence we need to track the rewrites. + +When compiling a program requires a greater depth, then GHC recommends turning +off this check entirely by setting -freduction-depth=0. This is because the +exact number that works is highly variable, and is likely to change even between +minor releases. Because this check is solely to prevent infinite compilation +times, it seems safe to disable it when a user has ascertained that their program +doesn't loop at the type level. + +-} + +-- | See Note [SubGoalDepth] +newtype SubGoalDepth = SubGoalDepth Int + deriving (Eq, Ord, Outputable) + +initialSubGoalDepth :: SubGoalDepth +initialSubGoalDepth = SubGoalDepth 0 + +bumpSubGoalDepth :: SubGoalDepth -> SubGoalDepth +bumpSubGoalDepth (SubGoalDepth n) = SubGoalDepth (n + 1) + +maxSubGoalDepth :: SubGoalDepth -> SubGoalDepth -> SubGoalDepth +maxSubGoalDepth (SubGoalDepth n) (SubGoalDepth m) = SubGoalDepth (n `max` m) + +subGoalDepthExceeded :: DynFlags -> SubGoalDepth -> Bool +subGoalDepthExceeded dflags (SubGoalDepth d) + = mkIntWithInf d > reductionDepth dflags + +{- +************************************************************************ +* * + CtLoc +* * +************************************************************************ + +The 'CtLoc' gives information about where a constraint came from. +This is important for decent error message reporting because +dictionaries don't appear in the original source code. +type will evolve... + +-} + +data CtLoc = CtLoc { ctl_origin :: CtOrigin + , ctl_env :: TcLclEnv + , ctl_t_or_k :: Maybe TypeOrKind -- OK if we're not sure + , ctl_depth :: !SubGoalDepth } + + -- The TcLclEnv includes particularly + -- source location: tcl_loc :: RealSrcSpan + -- context: tcl_ctxt :: [ErrCtxt] + -- binder stack: tcl_bndrs :: TcBinderStack + -- level: tcl_tclvl :: TcLevel + +mkKindLoc :: TcType -> TcType -- original *types* being compared + -> CtLoc -> CtLoc +mkKindLoc s1 s2 loc = setCtLocOrigin (toKindLoc loc) + (KindEqOrigin s1 (Just s2) (ctLocOrigin loc) + (ctLocTypeOrKind_maybe loc)) + +-- | Take a CtLoc and moves it to the kind level +toKindLoc :: CtLoc -> CtLoc +toKindLoc loc = loc { ctl_t_or_k = Just KindLevel } + +mkGivenLoc :: TcLevel -> SkolemInfo -> TcLclEnv -> CtLoc +mkGivenLoc tclvl skol_info env + = CtLoc { ctl_origin = GivenOrigin skol_info + , ctl_env = env { tcl_tclvl = tclvl } + , ctl_t_or_k = Nothing -- this only matters for error msgs + , ctl_depth = initialSubGoalDepth } + +ctLocEnv :: CtLoc -> TcLclEnv +ctLocEnv = ctl_env + +ctLocLevel :: CtLoc -> TcLevel +ctLocLevel loc = tcl_tclvl (ctLocEnv loc) + +ctLocDepth :: CtLoc -> SubGoalDepth +ctLocDepth = ctl_depth + +ctLocOrigin :: CtLoc -> CtOrigin +ctLocOrigin = ctl_origin + +ctLocSpan :: CtLoc -> RealSrcSpan +ctLocSpan (CtLoc { ctl_env = lcl}) = tcl_loc lcl + +ctLocTypeOrKind_maybe :: CtLoc -> Maybe TypeOrKind +ctLocTypeOrKind_maybe = ctl_t_or_k + +setCtLocSpan :: CtLoc -> RealSrcSpan -> CtLoc +setCtLocSpan ctl@(CtLoc { ctl_env = lcl }) loc = setCtLocEnv ctl (lcl { tcl_loc = loc }) + +bumpCtLocDepth :: CtLoc -> CtLoc +bumpCtLocDepth loc@(CtLoc { ctl_depth = d }) = loc { ctl_depth = bumpSubGoalDepth d } + +setCtLocOrigin :: CtLoc -> CtOrigin -> CtLoc +setCtLocOrigin ctl orig = ctl { ctl_origin = orig } + +updateCtLocOrigin :: CtLoc -> (CtOrigin -> CtOrigin) -> CtLoc +updateCtLocOrigin ctl@(CtLoc { ctl_origin = orig }) upd + = ctl { ctl_origin = upd orig } + +setCtLocEnv :: CtLoc -> TcLclEnv -> CtLoc +setCtLocEnv ctl env = ctl { ctl_env = env } + +pushErrCtxt :: CtOrigin -> ErrCtxt -> CtLoc -> CtLoc +pushErrCtxt o err loc@(CtLoc { ctl_env = lcl }) + = loc { ctl_origin = o, ctl_env = lcl { tcl_ctxt = err : tcl_ctxt lcl } } + +pushErrCtxtSameOrigin :: ErrCtxt -> CtLoc -> CtLoc +-- Just add information w/o updating the origin! +pushErrCtxtSameOrigin err loc@(CtLoc { ctl_env = lcl }) + = loc { ctl_env = lcl { tcl_ctxt = err : tcl_ctxt lcl } } + +{- +************************************************************************ +* * + SkolemInfo +* * +************************************************************************ +-} + +-- SkolemInfo gives the origin of *given* constraints +-- a) type variables are skolemised +-- b) an implication constraint is generated +data SkolemInfo + = SigSkol -- A skolem that is created by instantiating + -- a programmer-supplied type signature + -- Location of the binding site is on the TyVar + -- See Note [SigSkol SkolemInfo] + UserTypeCtxt -- What sort of signature + TcType -- Original type signature (before skolemisation) + [(Name,TcTyVar)] -- Maps the original name of the skolemised tyvar + -- to its instantiated version + + | SigTypeSkol UserTypeCtxt + -- like SigSkol, but when we're kind-checking the *type* + -- hence, we have less info + + | ForAllSkol SDoc -- Bound by a user-written "forall". + + | DerivSkol Type -- Bound by a 'deriving' clause; + -- the type is the instance we are trying to derive + + | InstSkol -- Bound at an instance decl + | InstSC TypeSize -- A "given" constraint obtained by superclass selection. + -- If (C ty1 .. tyn) is the largest class from + -- which we made a superclass selection in the chain, + -- then TypeSize = sizeTypes [ty1, .., tyn] + -- See Note [Solving superclass constraints] in TcInstDcls + + | FamInstSkol -- Bound at a family instance decl + | PatSkol -- An existential type variable bound by a pattern for + ConLike -- a data constructor with an existential type. + (HsMatchContext Name) + -- e.g. data T = forall a. Eq a => MkT a + -- f (MkT x) = ... + -- The pattern MkT x will allocate an existential type + -- variable for 'a'. + + | ArrowSkol -- An arrow form (see TcArrows) + + | IPSkol [HsIPName] -- Binding site of an implicit parameter + + | RuleSkol RuleName -- The LHS of a RULE + + | InferSkol [(Name,TcType)] + -- We have inferred a type for these (mutually-recursivive) + -- polymorphic Ids, and are now checking that their RHS + -- constraints are satisfied. + + | BracketSkol -- Template Haskell bracket + + | UnifyForAllSkol -- We are unifying two for-all types + TcType -- The instantiated type *inside* the forall + + | TyConSkol TyConFlavour Name -- bound in a type declaration of the given flavour + + | DataConSkol Name -- bound as an existential in a Haskell98 datacon decl or + -- as any variable in a GADT datacon decl + + | ReifySkol -- Bound during Template Haskell reification + + | QuantCtxtSkol -- Quantified context, e.g. + -- f :: forall c. (forall a. c a => c [a]) => blah + + | UnkSkol -- Unhelpful info (until I improve it) + +instance Outputable SkolemInfo where + ppr = pprSkolInfo + +pprSkolInfo :: SkolemInfo -> SDoc +-- Complete the sentence "is a rigid type variable bound by..." +pprSkolInfo (SigSkol cx ty _) = pprSigSkolInfo cx ty +pprSkolInfo (SigTypeSkol cx) = pprUserTypeCtxt cx +pprSkolInfo (ForAllSkol doc) = quotes doc +pprSkolInfo (IPSkol ips) = text "the implicit-parameter binding" <> plural ips <+> text "for" + <+> pprWithCommas ppr ips +pprSkolInfo (DerivSkol pred) = text "the deriving clause for" <+> quotes (ppr pred) +pprSkolInfo InstSkol = text "the instance declaration" +pprSkolInfo (InstSC n) = text "the instance declaration" <> whenPprDebug (parens (ppr n)) +pprSkolInfo FamInstSkol = text "a family instance declaration" +pprSkolInfo BracketSkol = text "a Template Haskell bracket" +pprSkolInfo (RuleSkol name) = text "the RULE" <+> pprRuleName name +pprSkolInfo ArrowSkol = text "an arrow form" +pprSkolInfo (PatSkol cl mc) = sep [ pprPatSkolInfo cl + , text "in" <+> pprMatchContext mc ] +pprSkolInfo (InferSkol ids) = hang (text "the inferred type" <> plural ids <+> text "of") + 2 (vcat [ ppr name <+> dcolon <+> ppr ty + | (name,ty) <- ids ]) +pprSkolInfo (UnifyForAllSkol ty) = text "the type" <+> ppr ty +pprSkolInfo (TyConSkol flav name) = text "the" <+> ppr flav <+> text "declaration for" <+> quotes (ppr name) +pprSkolInfo (DataConSkol name)= text "the data constructor" <+> quotes (ppr name) +pprSkolInfo ReifySkol = text "the type being reified" + +pprSkolInfo (QuantCtxtSkol {}) = text "a quantified context" + +-- UnkSkol +-- For type variables the others are dealt with by pprSkolTvBinding. +-- For Insts, these cases should not happen +pprSkolInfo UnkSkol = WARN( True, text "pprSkolInfo: UnkSkol" ) text "UnkSkol" + +pprSigSkolInfo :: UserTypeCtxt -> TcType -> SDoc +-- The type is already tidied +pprSigSkolInfo ctxt ty + = case ctxt of + FunSigCtxt f _ -> vcat [ text "the type signature for:" + , nest 2 (pprPrefixOcc f <+> dcolon <+> ppr ty) ] + PatSynCtxt {} -> pprUserTypeCtxt ctxt -- See Note [Skolem info for pattern synonyms] + _ -> vcat [ pprUserTypeCtxt ctxt <> colon + , nest 2 (ppr ty) ] + +pprPatSkolInfo :: ConLike -> SDoc +pprPatSkolInfo (RealDataCon dc) + = sep [ text "a pattern with constructor:" + , nest 2 $ ppr dc <+> dcolon + <+> pprType (dataConUserType dc) <> comma ] + -- pprType prints forall's regardless of -fprint-explicit-foralls + -- which is what we want here, since we might be saying + -- type variable 't' is bound by ... + +pprPatSkolInfo (PatSynCon ps) + = sep [ text "a pattern with pattern synonym:" + , nest 2 $ ppr ps <+> dcolon + <+> pprPatSynType ps <> comma ] + +{- Note [Skolem info for pattern synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For pattern synonym SkolemInfo we have + SigSkol (PatSynCtxt p) ty _ +but the type 'ty' is not very helpful. The full pattern-synonym type +has the provided and required pieces, which it is inconvenient to +record and display here. So we simply don't display the type at all, +contenting outselves with just the name of the pattern synonym, which +is fine. We could do more, but it doesn't seem worth it. + +Note [SigSkol SkolemInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we (deeply) skolemise a type + f :: forall a. a -> forall b. b -> a +Then we'll instantiate [a :-> a', b :-> b'], and with the instantiated + a' -> b' -> a. +But when, in an error message, we report that "b is a rigid type +variable bound by the type signature for f", we want to show the foralls +in the right place. So we proceed as follows: + +* In SigSkol we record + - the original signature forall a. a -> forall b. b -> a + - the instantiation mapping [a :-> a', b :-> b'] + +* Then when tidying in TcMType.tidySkolemInfo, we first tidy a' to + whatever it tidies to, say a''; and then we walk over the type + replacing the binder a by the tidied version a'', to give + forall a''. a'' -> forall b''. b'' -> a'' + We need to do this under function arrows, to match what deeplySkolemise + does. + +* Typically a'' will have a nice pretty name like "a", but the point is + that the foral-bound variables of the signature we report line up with + the instantiated skolems lying around in other types. + + +************************************************************************ +* * + CtOrigin +* * +************************************************************************ +-} + +data CtOrigin + = GivenOrigin SkolemInfo + + -- All the others are for *wanted* constraints + | OccurrenceOf Name -- Occurrence of an overloaded identifier + | OccurrenceOfRecSel RdrName -- Occurrence of a record selector + | AppOrigin -- An application of some kind + + | SpecPragOrigin UserTypeCtxt -- Specialisation pragma for + -- function or instance + + | TypeEqOrigin { uo_actual :: TcType + , uo_expected :: TcType + , uo_thing :: Maybe SDoc + -- ^ The thing that has type "actual" + , uo_visible :: Bool + -- ^ Is at least one of the three elements above visible? + -- (Errors from the polymorphic subsumption check are considered + -- visible.) Only used for prioritizing error messages. + } + + | KindEqOrigin -- See Note [Equalities with incompatible kinds] in TcCanonical. + TcType (Maybe TcType) -- A kind equality arising from unifying these two types + CtOrigin -- originally arising from this + (Maybe TypeOrKind) -- the level of the eq this arises from + + | IPOccOrigin HsIPName -- Occurrence of an implicit parameter + | OverLabelOrigin FastString -- Occurrence of an overloaded label + + | LiteralOrigin (HsOverLit GhcRn) -- Occurrence of a literal + | NegateOrigin -- Occurrence of syntactic negation + + | ArithSeqOrigin (ArithSeqInfo GhcRn) -- [x..], [x..y] etc + | AssocFamPatOrigin -- When matching the patterns of an associated + -- family instance with that of its parent class + | SectionOrigin + | TupleOrigin -- (..,..) + | ExprSigOrigin -- e :: ty + | PatSigOrigin -- p :: ty + | PatOrigin -- Instantiating a polytyped pattern at a constructor + | ProvCtxtOrigin -- The "provided" context of a pattern synonym signature + (PatSynBind GhcRn GhcRn) -- Information about the pattern synonym, in + -- particular the name and the right-hand side + | RecordUpdOrigin + | ViewPatOrigin + + | ScOrigin TypeSize -- Typechecking superclasses of an instance declaration + -- If the instance head is C ty1 .. tyn + -- then TypeSize = sizeTypes [ty1, .., tyn] + -- See Note [Solving superclass constraints] in TcInstDcls + + | DerivClauseOrigin -- Typechecking a deriving clause (as opposed to + -- standalone deriving). + | DerivOriginDC DataCon Int Bool + -- Checking constraints arising from this data con and field index. The + -- Bool argument in DerivOriginDC and DerivOriginCoerce is True if + -- standalong deriving (with a wildcard constraint) is being used. This + -- is used to inform error messages on how to recommended fixes (e.g., if + -- the argument is True, then don't recommend "use standalone deriving", + -- but rather "fill in the wildcard constraint yourself"). + -- See Note [Inferring the instance context] in TcDerivInfer + | DerivOriginCoerce Id Type Type Bool + -- DerivOriginCoerce id ty1 ty2: Trying to coerce class method `id` from + -- `ty1` to `ty2`. + | StandAloneDerivOrigin -- Typechecking stand-alone deriving. Useful for + -- constraints coming from a wildcard constraint, + -- e.g., deriving instance _ => Eq (Foo a) + -- See Note [Inferring the instance context] + -- in TcDerivInfer + | DefaultOrigin -- Typechecking a default decl + | DoOrigin -- Arising from a do expression + | DoPatOrigin (LPat GhcRn) -- Arising from a failable pattern in + -- a do expression + | MCompOrigin -- Arising from a monad comprehension + | MCompPatOrigin (LPat GhcRn) -- Arising from a failable pattern in a + -- monad comprehension + | IfOrigin -- Arising from an if statement + | ProcOrigin -- Arising from a proc expression + | AnnOrigin -- An annotation + + | FunDepOrigin1 -- A functional dependency from combining + PredType CtLoc -- This constraint arising from ... + PredType CtLoc -- and this constraint arising from ... + + | FunDepOrigin2 -- A functional dependency from combining + PredType CtOrigin -- This constraint arising from ... + PredType SrcSpan -- and this top-level instance + -- We only need a CtOrigin on the first, because the location + -- is pinned on the entire error message + + | HoleOrigin + | UnboundOccurrenceOf OccName + | ListOrigin -- An overloaded list + | StaticOrigin -- A static form + | FailablePattern (LPat GhcTcId) -- A failable pattern in do-notation for the + -- MonadFail Proposal (MFP). Obsolete when + -- actual desugaring to MonadFail.fail is + -- live. + | Shouldn'tHappenOrigin String + -- the user should never see this one, + -- unless ImpredicativeTypes is on, where all + -- bets are off + | InstProvidedOrigin Module ClsInst + -- Skolem variable arose when we were testing if an instance + -- is solvable or not. + +-- | Flag to see whether we're type-checking terms or kind-checking types +data TypeOrKind = TypeLevel | KindLevel + deriving Eq + +instance Outputable TypeOrKind where + ppr TypeLevel = text "TypeLevel" + ppr KindLevel = text "KindLevel" + +isTypeLevel :: TypeOrKind -> Bool +isTypeLevel TypeLevel = True +isTypeLevel KindLevel = False + +isKindLevel :: TypeOrKind -> Bool +isKindLevel TypeLevel = False +isKindLevel KindLevel = True + +-- An origin is visible if the place where the constraint arises is manifest +-- in user code. Currently, all origins are visible except for invisible +-- TypeEqOrigins. This is used when choosing which error of +-- several to report +isVisibleOrigin :: CtOrigin -> Bool +isVisibleOrigin (TypeEqOrigin { uo_visible = vis }) = vis +isVisibleOrigin (KindEqOrigin _ _ sub_orig _) = isVisibleOrigin sub_orig +isVisibleOrigin _ = True + +-- Converts a visible origin to an invisible one, if possible. Currently, +-- this works only for TypeEqOrigin +toInvisibleOrigin :: CtOrigin -> CtOrigin +toInvisibleOrigin orig@(TypeEqOrigin {}) = orig { uo_visible = False } +toInvisibleOrigin orig = orig + +instance Outputable CtOrigin where + ppr = pprCtOrigin + +ctoHerald :: SDoc +ctoHerald = text "arising from" + +-- | Extract a suitable CtOrigin from a HsExpr +lexprCtOrigin :: LHsExpr GhcRn -> CtOrigin +lexprCtOrigin (L _ e) = exprCtOrigin e + +exprCtOrigin :: HsExpr GhcRn -> CtOrigin +exprCtOrigin (HsVar _ (L _ name)) = OccurrenceOf name +exprCtOrigin (HsUnboundVar _ uv) = UnboundOccurrenceOf (unboundVarOcc uv) +exprCtOrigin (HsConLikeOut {}) = panic "exprCtOrigin HsConLikeOut" +exprCtOrigin (HsRecFld _ f) = OccurrenceOfRecSel (rdrNameAmbiguousFieldOcc f) +exprCtOrigin (HsOverLabel _ _ l) = OverLabelOrigin l +exprCtOrigin (HsIPVar _ ip) = IPOccOrigin ip +exprCtOrigin (HsOverLit _ lit) = LiteralOrigin lit +exprCtOrigin (HsLit {}) = Shouldn'tHappenOrigin "concrete literal" +exprCtOrigin (HsLam _ matches) = matchesCtOrigin matches +exprCtOrigin (HsLamCase _ ms) = matchesCtOrigin ms +exprCtOrigin (HsApp _ e1 _) = lexprCtOrigin e1 +exprCtOrigin (HsAppType _ e1 _) = lexprCtOrigin e1 +exprCtOrigin (OpApp _ _ op _) = lexprCtOrigin op +exprCtOrigin (NegApp _ e _) = lexprCtOrigin e +exprCtOrigin (HsPar _ e) = lexprCtOrigin e +exprCtOrigin (SectionL _ _ _) = SectionOrigin +exprCtOrigin (SectionR _ _ _) = SectionOrigin +exprCtOrigin (ExplicitTuple {}) = Shouldn'tHappenOrigin "explicit tuple" +exprCtOrigin ExplicitSum{} = Shouldn'tHappenOrigin "explicit sum" +exprCtOrigin (HsCase _ _ matches) = matchesCtOrigin matches +exprCtOrigin (HsIf _ (Just syn) _ _ _) = exprCtOrigin (syn_expr syn) +exprCtOrigin (HsIf {}) = Shouldn'tHappenOrigin "if expression" +exprCtOrigin (HsMultiIf _ rhs) = lGRHSCtOrigin rhs +exprCtOrigin (HsLet _ _ e) = lexprCtOrigin e +exprCtOrigin (HsDo {}) = DoOrigin +exprCtOrigin (ExplicitList {}) = Shouldn'tHappenOrigin "list" +exprCtOrigin (RecordCon {}) = Shouldn'tHappenOrigin "record construction" +exprCtOrigin (RecordUpd {}) = Shouldn'tHappenOrigin "record update" +exprCtOrigin (ExprWithTySig {}) = ExprSigOrigin +exprCtOrigin (ArithSeq {}) = Shouldn'tHappenOrigin "arithmetic sequence" +exprCtOrigin (HsSCC _ _ _ e) = lexprCtOrigin e +exprCtOrigin (HsCoreAnn _ _ _ e) = lexprCtOrigin e +exprCtOrigin (HsBracket {}) = Shouldn'tHappenOrigin "TH bracket" +exprCtOrigin (HsRnBracketOut {})= Shouldn'tHappenOrigin "HsRnBracketOut" +exprCtOrigin (HsTcBracketOut {})= panic "exprCtOrigin HsTcBracketOut" +exprCtOrigin (HsSpliceE {}) = Shouldn'tHappenOrigin "TH splice" +exprCtOrigin (HsProc {}) = Shouldn'tHappenOrigin "proc" +exprCtOrigin (HsStatic {}) = Shouldn'tHappenOrigin "static expression" +exprCtOrigin (HsTick _ _ e) = lexprCtOrigin e +exprCtOrigin (HsBinTick _ _ _ e) = lexprCtOrigin e +exprCtOrigin (HsTickPragma _ _ _ _ e) = lexprCtOrigin e +exprCtOrigin (EWildPat {}) = panic "exprCtOrigin EWildPat" +exprCtOrigin (EAsPat {}) = panic "exprCtOrigin EAsPat" +exprCtOrigin (EViewPat {}) = panic "exprCtOrigin EViewPat" +exprCtOrigin (ELazyPat {}) = panic "exprCtOrigin ELazyPat" +exprCtOrigin (HsWrap {}) = panic "exprCtOrigin HsWrap" +exprCtOrigin (XExpr {}) = panic "exprCtOrigin XExpr" + +-- | Extract a suitable CtOrigin from a MatchGroup +matchesCtOrigin :: MatchGroup GhcRn (LHsExpr GhcRn) -> CtOrigin +matchesCtOrigin (MG { mg_alts = alts }) + | L _ [L _ match] <- alts + , Match { m_grhss = grhss } <- match + = grhssCtOrigin grhss + + | otherwise + = Shouldn'tHappenOrigin "multi-way match" +matchesCtOrigin (XMatchGroup{}) = panic "matchesCtOrigin" + +-- | Extract a suitable CtOrigin from guarded RHSs +grhssCtOrigin :: GRHSs GhcRn (LHsExpr GhcRn) -> CtOrigin +grhssCtOrigin (GRHSs { grhssGRHSs = lgrhss }) = lGRHSCtOrigin lgrhss +grhssCtOrigin (XGRHSs _) = panic "grhssCtOrigin" + +-- | Extract a suitable CtOrigin from a list of guarded RHSs +lGRHSCtOrigin :: [LGRHS GhcRn (LHsExpr GhcRn)] -> CtOrigin +lGRHSCtOrigin [L _ (GRHS _ _ (L _ e))] = exprCtOrigin e +lGRHSCtOrigin [L _ (XGRHS _)] = panic "lGRHSCtOrigin" +lGRHSCtOrigin _ = Shouldn'tHappenOrigin "multi-way GRHS" + +pprCtLoc :: CtLoc -> SDoc +-- "arising from ... at ..." +-- Not an instance of Outputable because of the "arising from" prefix +pprCtLoc (CtLoc { ctl_origin = o, ctl_env = lcl}) + = sep [ pprCtOrigin o + , text "at" <+> ppr (tcl_loc lcl)] + +pprCtOrigin :: CtOrigin -> SDoc +-- "arising from ..." +-- Not an instance of Outputable because of the "arising from" prefix +pprCtOrigin (GivenOrigin sk) = ctoHerald <+> ppr sk + +pprCtOrigin (SpecPragOrigin ctxt) + = case ctxt of + FunSigCtxt n _ -> text "a SPECIALISE pragma for" <+> quotes (ppr n) + SpecInstCtxt -> text "a SPECIALISE INSTANCE pragma" + _ -> text "a SPECIALISE pragma" -- Never happens I think + +pprCtOrigin (FunDepOrigin1 pred1 loc1 pred2 loc2) + = hang (ctoHerald <+> text "a functional dependency between constraints:") + 2 (vcat [ hang (quotes (ppr pred1)) 2 (pprCtLoc loc1) + , hang (quotes (ppr pred2)) 2 (pprCtLoc loc2) ]) + +pprCtOrigin (FunDepOrigin2 pred1 orig1 pred2 loc2) + = hang (ctoHerald <+> text "a functional dependency between:") + 2 (vcat [ hang (text "constraint" <+> quotes (ppr pred1)) + 2 (pprCtOrigin orig1 ) + , hang (text "instance" <+> quotes (ppr pred2)) + 2 (text "at" <+> ppr loc2) ]) + +pprCtOrigin (KindEqOrigin t1 (Just t2) _ _) + = hang (ctoHerald <+> text "a kind equality arising from") + 2 (sep [ppr t1, char '~', ppr t2]) + +pprCtOrigin AssocFamPatOrigin + = text "when matching a family LHS with its class instance head" + +pprCtOrigin (KindEqOrigin t1 Nothing _ _) + = hang (ctoHerald <+> text "a kind equality when matching") + 2 (ppr t1) + +pprCtOrigin (UnboundOccurrenceOf name) + = ctoHerald <+> text "an undeclared identifier" <+> quotes (ppr name) + +pprCtOrigin (DerivOriginDC dc n _) + = hang (ctoHerald <+> text "the" <+> speakNth n + <+> text "field of" <+> quotes (ppr dc)) + 2 (parens (text "type" <+> quotes (ppr ty))) + where + ty = dataConOrigArgTys dc !! (n-1) + +pprCtOrigin (DerivOriginCoerce meth ty1 ty2 _) + = hang (ctoHerald <+> text "the coercion of the method" <+> quotes (ppr meth)) + 2 (sep [ text "from type" <+> quotes (ppr ty1) + , nest 2 $ text "to type" <+> quotes (ppr ty2) ]) + +pprCtOrigin (DoPatOrigin pat) + = ctoHerald <+> text "a do statement" + $$ + text "with the failable pattern" <+> quotes (ppr pat) + +pprCtOrigin (MCompPatOrigin pat) + = ctoHerald <+> hsep [ text "the failable pattern" + , quotes (ppr pat) + , text "in a statement in a monad comprehension" ] +pprCtOrigin (FailablePattern pat) + = ctoHerald <+> text "the failable pattern" <+> quotes (ppr pat) + $$ + text "(this will become an error in a future GHC release)" + +pprCtOrigin (Shouldn'tHappenOrigin note) + = sdocWithDynFlags $ \dflags -> + if xopt LangExt.ImpredicativeTypes dflags + then text "a situation created by impredicative types" + else + vcat [ text "<< This should not appear in error messages. If you see this" + , text "in an error message, please report a bug mentioning" <+> quotes (text note) <+> text "at" + , text "https://gitlab.haskell.org/ghc/ghc/wikis/report-a-bug >>" ] + +pprCtOrigin (ProvCtxtOrigin PSB{ psb_id = (L _ name) }) + = hang (ctoHerald <+> text "the \"provided\" constraints claimed by") + 2 (text "the signature of" <+> quotes (ppr name)) + +pprCtOrigin (InstProvidedOrigin mod cls_inst) + = vcat [ text "arising when attempting to show that" + , ppr cls_inst + , text "is provided by" <+> quotes (ppr mod)] + +pprCtOrigin simple_origin + = ctoHerald <+> pprCtO simple_origin + +-- | Short one-liners +pprCtO :: CtOrigin -> SDoc +pprCtO (OccurrenceOf name) = hsep [text "a use of", quotes (ppr name)] +pprCtO (OccurrenceOfRecSel name) = hsep [text "a use of", quotes (ppr name)] +pprCtO AppOrigin = text "an application" +pprCtO (IPOccOrigin name) = hsep [text "a use of implicit parameter", quotes (ppr name)] +pprCtO (OverLabelOrigin l) = hsep [text "the overloaded label" + ,quotes (char '#' <> ppr l)] +pprCtO RecordUpdOrigin = text "a record update" +pprCtO ExprSigOrigin = text "an expression type signature" +pprCtO PatSigOrigin = text "a pattern type signature" +pprCtO PatOrigin = text "a pattern" +pprCtO ViewPatOrigin = text "a view pattern" +pprCtO IfOrigin = text "an if expression" +pprCtO (LiteralOrigin lit) = hsep [text "the literal", quotes (ppr lit)] +pprCtO (ArithSeqOrigin seq) = hsep [text "the arithmetic sequence", quotes (ppr seq)] +pprCtO SectionOrigin = text "an operator section" +pprCtO AssocFamPatOrigin = text "the LHS of a famly instance" +pprCtO TupleOrigin = text "a tuple" +pprCtO NegateOrigin = text "a use of syntactic negation" +pprCtO (ScOrigin n) = text "the superclasses of an instance declaration" + <> whenPprDebug (parens (ppr n)) +pprCtO DerivClauseOrigin = text "the 'deriving' clause of a data type declaration" +pprCtO StandAloneDerivOrigin = text "a 'deriving' declaration" +pprCtO DefaultOrigin = text "a 'default' declaration" +pprCtO DoOrigin = text "a do statement" +pprCtO MCompOrigin = text "a statement in a monad comprehension" +pprCtO ProcOrigin = text "a proc expression" +pprCtO (TypeEqOrigin t1 t2 _ _)= text "a type equality" <+> sep [ppr t1, char '~', ppr t2] +pprCtO AnnOrigin = text "an annotation" +pprCtO HoleOrigin = text "a use of" <+> quotes (text "_") +pprCtO ListOrigin = text "an overloaded list" +pprCtO StaticOrigin = text "a static form" +pprCtO _ = panic "pprCtOrigin" + +{- +Constraint Solver Plugins +------------------------- +-} + +type TcPluginSolver = [Ct] -- given + -> [Ct] -- derived + -> [Ct] -- wanted + -> TcPluginM TcPluginResult + +newtype TcPluginM a = TcPluginM (EvBindsVar -> TcM a) + +instance Functor TcPluginM where + fmap = liftM + +instance Applicative TcPluginM where + pure x = TcPluginM (const $ pure x) + (<*>) = ap + +instance Monad TcPluginM where +#if !MIN_VERSION_base(4,13,0) + fail = MonadFail.fail +#endif + TcPluginM m >>= k = + TcPluginM (\ ev -> do a <- m ev + runTcPluginM (k a) ev) + +instance MonadFail.MonadFail TcPluginM where + fail x = TcPluginM (const $ fail x) + +runTcPluginM :: TcPluginM a -> EvBindsVar -> TcM a +runTcPluginM (TcPluginM m) = m + +-- | This function provides an escape for direct access to +-- the 'TcM` monad. It should not be used lightly, and +-- the provided 'TcPluginM' API should be favoured instead. +unsafeTcPluginTcM :: TcM a -> TcPluginM a +unsafeTcPluginTcM = TcPluginM . const + +-- | Access the 'EvBindsVar' carried by the 'TcPluginM' during +-- constraint solving. Returns 'Nothing' if invoked during +-- 'tcPluginInit' or 'tcPluginStop'. +getEvBindsTcPluginM :: TcPluginM EvBindsVar +getEvBindsTcPluginM = TcPluginM return + + +data TcPlugin = forall s. TcPlugin + { tcPluginInit :: TcPluginM s + -- ^ Initialize plugin, when entering type-checker. + + , tcPluginSolve :: s -> TcPluginSolver + -- ^ Solve some constraints. + -- TODO: WRITE MORE DETAILS ON HOW THIS WORKS. + + , tcPluginStop :: s -> TcPluginM () + -- ^ Clean up after the plugin, when exiting the type-checker. + } + +data TcPluginResult + = TcPluginContradiction [Ct] + -- ^ The plugin found a contradiction. + -- The returned constraints are removed from the inert set, + -- and recorded as insoluble. + + | TcPluginOk [(EvTerm,Ct)] [Ct] + -- ^ The first field is for constraints that were solved. + -- These are removed from the inert set, + -- and the evidence for them is recorded. + -- The second field contains new work, that should be processed by + -- the constraint solver. + +{- ********************************************************************* +* * + Role annotations +* * +********************************************************************* -} + +type RoleAnnotEnv = NameEnv (LRoleAnnotDecl GhcRn) + +mkRoleAnnotEnv :: [LRoleAnnotDecl GhcRn] -> RoleAnnotEnv +mkRoleAnnotEnv role_annot_decls + = mkNameEnv [ (name, ra_decl) + | ra_decl <- role_annot_decls + , let name = roleAnnotDeclName (unLoc ra_decl) + , not (isUnboundName name) ] + -- Some of the role annots will be unbound; + -- we don't wish to include these + +emptyRoleAnnotEnv :: RoleAnnotEnv +emptyRoleAnnotEnv = emptyNameEnv + +lookupRoleAnnot :: RoleAnnotEnv -> Name -> Maybe (LRoleAnnotDecl GhcRn) +lookupRoleAnnot = lookupNameEnv + +getRoleAnnots :: [Name] -> RoleAnnotEnv + -> ([LRoleAnnotDecl GhcRn], RoleAnnotEnv) +getRoleAnnots bndrs role_env + = ( mapMaybe (lookupRoleAnnot role_env) bndrs + , delListFromNameEnv role_env bndrs ) diff --git a/compiler/typecheck/TcRnTypes.hs-boot b/compiler/typecheck/TcRnTypes.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/typecheck/TcRnTypes.hs-boot @@ -0,0 +1,6 @@ +module TcRnTypes where + +-- Build ordering +import GHC.Base() + +data TcLclEnv diff --git a/compiler/typecheck/TcType.hs b/compiler/typecheck/TcType.hs new file mode 100644 --- /dev/null +++ b/compiler/typecheck/TcType.hs @@ -0,0 +1,2618 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[TcType]{Types used in the typechecker} + +This module provides the Type interface for front-end parts of the +compiler. These parts + + * treat "source types" as opaque: + newtypes, and predicates are meaningful. + * look through usage types + +The "tc" prefix is for "TypeChecker", because the type checker +is the principal client. +-} + +{-# LANGUAGE CPP, ScopedTypeVariables, MultiWayIf, FlexibleContexts #-} + +module TcType ( + -------------------------------- + -- Types + TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType, + TcTyVar, TcTyVarSet, TcDTyVarSet, TcTyCoVarSet, TcDTyCoVarSet, + TcKind, TcCoVar, TcTyCoVar, TcTyVarBinder, TcTyCon, + KnotTied, + + ExpType(..), InferResult(..), ExpSigmaType, ExpRhoType, mkCheckExpType, + + SyntaxOpType(..), synKnownType, mkSynFunTys, + + -- TcLevel + TcLevel(..), topTcLevel, pushTcLevel, isTopTcLevel, + strictlyDeeperThan, sameDepthAs, + tcTypeLevel, tcTyVarLevel, maxTcLevel, + promoteSkolem, promoteSkolemX, promoteSkolemsX, + -------------------------------- + -- MetaDetails + UserTypeCtxt(..), pprUserTypeCtxt, isSigMaybe, + TcTyVarDetails(..), pprTcTyVarDetails, vanillaSkolemTv, superSkolemTv, + MetaDetails(Flexi, Indirect), MetaInfo(..), + isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isMetaTyVarTy, isTyVarTy, + tcIsTcTyVar, isTyVarTyVar, isOverlappableTyVar, isTyConableTyVar, + isFskTyVar, isFmvTyVar, isFlattenTyVar, + isAmbiguousTyVar, metaTyVarRef, metaTyVarInfo, + isFlexi, isIndirect, isRuntimeUnkSkol, + metaTyVarTcLevel, setMetaTyVarTcLevel, metaTyVarTcLevel_maybe, + isTouchableMetaTyVar, + isFloatedTouchableMetaTyVar, + findDupTyVarTvs, mkTyVarNamePairs, + + -------------------------------- + -- Builders + mkPhiTy, mkInfSigmaTy, mkSpecSigmaTy, mkSigmaTy, + mkTcAppTy, mkTcAppTys, mkTcCastTy, + + -------------------------------- + -- Splitters + -- These are important because they do not look through newtypes + getTyVar, + tcSplitForAllTy_maybe, + tcSplitForAllTys, tcSplitForAllTysSameVis, + tcSplitPiTys, tcSplitPiTy_maybe, tcSplitForAllVarBndrs, + tcSplitPhiTy, tcSplitPredFunTy_maybe, + tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy, tcFunResultTyN, + tcSplitFunTysN, + tcSplitTyConApp, tcSplitTyConApp_maybe, + tcTyConAppTyCon, tcTyConAppTyCon_maybe, tcTyConAppArgs, + tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, tcRepSplitAppTy_maybe, + tcRepGetNumAppTys, + tcGetCastedTyVar_maybe, tcGetTyVar_maybe, tcGetTyVar, nextRole, + tcSplitSigmaTy, tcSplitNestedSigmaTys, tcDeepSplitSigmaTy_maybe, + + --------------------------------- + -- Predicates. + -- Again, newtypes are opaque + eqType, eqTypes, nonDetCmpType, nonDetCmpTypes, eqTypeX, + pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck, tcEqTypeVis, + isSigmaTy, isRhoTy, isRhoExpTy, isOverloadedTy, + isFloatingTy, isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy, + isIntegerTy, isBoolTy, isUnitTy, isCharTy, isCallStackTy, isCallStackPred, + hasIPPred, isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy, + isPredTy, isTyVarClassPred, isTyVarHead, isInsolubleOccursCheck, + checkValidClsArgs, hasTyVarHead, + isRigidTy, + + --------------------------------- + -- Misc type manipulators + + deNoteType, + orphNamesOfType, orphNamesOfCo, + orphNamesOfTypes, orphNamesOfCoCon, + getDFunTyKey, evVarPred, + + --------------------------------- + -- Predicate types + mkMinimalBySCs, transSuperClasses, + pickQuantifiablePreds, pickCapturedPreds, + immSuperClasses, boxEqPred, + isImprovementPred, + + -- * Finding type instances + tcTyFamInsts, tcTyFamInstsAndVis, tcTyConAppTyFamInstsAndVis, isTyFamFree, + + -- * Finding "exact" (non-dead) type variables + exactTyCoVarsOfType, exactTyCoVarsOfTypes, + anyRewritableTyVar, + + --------------------------------- + -- Foreign import and export + isFFIArgumentTy, -- :: DynFlags -> Safety -> Type -> Bool + isFFIImportResultTy, -- :: DynFlags -> Type -> Bool + isFFIExportResultTy, -- :: Type -> Bool + isFFIExternalTy, -- :: Type -> Bool + isFFIDynTy, -- :: Type -> Type -> Bool + isFFIPrimArgumentTy, -- :: DynFlags -> Type -> Bool + isFFIPrimResultTy, -- :: DynFlags -> Type -> Bool + isFFILabelTy, -- :: Type -> Bool + isFFITy, -- :: Type -> Bool + isFunPtrTy, -- :: Type -> Bool + tcSplitIOType_maybe, -- :: Type -> Maybe Type + + -------------------------------- + -- Rexported from Kind + Kind, tcTypeKind, + liftedTypeKind, + constraintKind, + isLiftedTypeKind, isUnliftedTypeKind, classifiesTypeWithValues, + + -------------------------------- + -- Rexported from Type + Type, PredType, ThetaType, TyCoBinder, + ArgFlag(..), AnonArgFlag(..), ForallVisFlag(..), + + mkForAllTy, mkForAllTys, mkTyCoInvForAllTys, mkSpecForAllTys, mkTyCoInvForAllTy, + mkInvForAllTy, mkInvForAllTys, + mkVisFunTy, mkVisFunTys, mkInvisFunTy, mkInvisFunTys, + mkTyConApp, mkAppTy, mkAppTys, + mkTyConTy, mkTyVarTy, mkTyVarTys, + mkTyCoVarTy, mkTyCoVarTys, + + isClassPred, isEqPrimPred, isIPPred, isEqPred, isEqPredClass, + mkClassPred, + isDictLikeTy, + tcSplitDFunTy, tcSplitDFunHead, tcSplitMethodTy, + isRuntimeRepVar, isKindLevPoly, + isVisibleBinder, isInvisibleBinder, + + -- Type substitutions + TCvSubst(..), -- Representation visible to a few friends + TvSubstEnv, emptyTCvSubst, mkEmptyTCvSubst, + zipTvSubst, + mkTvSubstPrs, notElemTCvSubst, unionTCvSubst, + getTvSubstEnv, setTvSubstEnv, getTCvInScope, extendTCvInScope, + extendTCvInScopeList, extendTCvInScopeSet, extendTvSubstAndInScope, + Type.lookupTyVar, Type.extendTCvSubst, Type.substTyVarBndr, + Type.extendTvSubst, + isInScope, mkTCvSubst, mkTvSubst, zipTyEnv, zipCoEnv, + Type.substTy, substTys, substTyWith, substTyWithCoVars, + substTyAddInScope, + substTyUnchecked, substTysUnchecked, substThetaUnchecked, + substTyWithUnchecked, + substCoUnchecked, substCoWithUnchecked, + substTheta, + + isUnliftedType, -- Source types are always lifted + isUnboxedTupleType, -- Ditto + isPrimitiveType, + + tcView, coreView, + + tyCoVarsOfType, tyCoVarsOfTypes, closeOverKinds, + tyCoFVsOfType, tyCoFVsOfTypes, + tyCoVarsOfTypeDSet, tyCoVarsOfTypesDSet, closeOverKindsDSet, + tyCoVarsOfTypeList, tyCoVarsOfTypesList, + noFreeVarsOfType, + + -------------------------------- + pprKind, pprParendKind, pprSigmaType, + pprType, pprParendType, pprTypeApp, pprTyThingCategory, tyThingCategory, + pprTheta, pprParendTheta, pprThetaArrowTy, pprClassPred, + pprTCvBndr, pprTCvBndrs, + + TypeSize, sizeType, sizeTypes, scopedSort, + + --------------------------------- + -- argument visibility + tcTyConVisibilities, isNextTyConArgVisible, isNextArgVisible + + ) where + +#include "HsVersions.h" + +-- friends: +import GhcPrelude + +import Kind +import TyCoRep +import Class +import Var +import ForeignCall +import VarSet +import Coercion +import Type +import RepType +import TyCon + +-- others: +import DynFlags +import CoreFVs +import Name -- hiding (varName) + -- We use this to make dictionaries for type literals. + -- Perhaps there's a better way to do this? +import NameSet +import VarEnv +import PrelNames +import TysWiredIn( coercibleClass, eqClass, heqClass, unitTyCon, unitTyConKey + , listTyCon, constraintKind ) +import BasicTypes +import Util +import Maybes +import ListSetOps ( getNth, findDupsEq ) +import Outputable +import FastString +import ErrUtils( Validity(..), MsgDoc, isValid ) +import qualified GHC.LanguageExtensions as LangExt + +import Data.List ( mapAccumL ) +-- import Data.Functor.Identity( Identity(..) ) +import Data.IORef +import Data.List.NonEmpty( NonEmpty(..) ) + +{- +************************************************************************ +* * + Types +* * +************************************************************************ + +The type checker divides the generic Type world into the +following more structured beasts: + +sigma ::= forall tyvars. phi + -- A sigma type is a qualified type + -- + -- Note that even if 'tyvars' is empty, theta + -- may not be: e.g. (?x::Int) => Int + + -- Note that 'sigma' is in prenex form: + -- all the foralls are at the front. + -- A 'phi' type has no foralls to the right of + -- an arrow + +phi :: theta => rho + +rho ::= sigma -> rho + | tau + +-- A 'tau' type has no quantification anywhere +-- Note that the args of a type constructor must be taus +tau ::= tyvar + | tycon tau_1 .. tau_n + | tau_1 tau_2 + | tau_1 -> tau_2 + +-- In all cases, a (saturated) type synonym application is legal, +-- provided it expands to the required form. + +Note [TcTyVars and TyVars in the typechecker] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The typechecker uses a lot of type variables with special properties, +notably being a unification variable with a mutable reference. These +use the 'TcTyVar' variant of Var.Var. + +Note, though, that a /bound/ type variable can (and probably should) +be a TyVar. E.g + forall a. a -> a +Here 'a' is really just a deBruijn-number; it certainly does not have +a signficant TcLevel (as every TcTyVar does). So a forall-bound type +variable should be TyVars; and hence a TyVar can appear free in a TcType. + +The type checker and constraint solver can also encounter /free/ type +variables that use the 'TyVar' variant of Var.Var, for a couple of +reasons: + + - When typechecking a class decl, say + class C (a :: k) where + foo :: T a -> Int + We have first kind-check the header; fix k and (a:k) to be + TyVars, bring 'k' and 'a' into scope, and kind check the + signature for 'foo'. In doing so we call solveEqualities to + solve any kind equalities in foo's signature. So the solver + may see free occurrences of 'k'. + + See calls to tcExtendTyVarEnv for other places that ordinary + TyVars are bought into scope, and hence may show up in the types + and kinds generated by TcHsType. + + - The pattern-match overlap checker calls the constraint solver, + long afer TcTyVars have been zonked away + +It's convenient to simply treat these TyVars as skolem constants, +which of course they are. We give them a level number of "outermost", +so they behave as global constants. Specifically: + +* Var.tcTyVarDetails succeeds on a TyVar, returning + vanillaSkolemTv, as well as on a TcTyVar. + +* tcIsTcTyVar returns True for both TyVar and TcTyVar variants + of Var.Var. The "tc" prefix means "a type variable that can be + encountered by the typechecker". + +This is a bit of a change from an earlier era when we remoselessly +insisted on real TcTyVars in the type checker. But that seems +unnecessary (for skolems, TyVars are fine) and it's now very hard +to guarantee, with the advent of kind equalities. + +Note [Coercion variables in free variable lists] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are several places in the GHC codebase where functions like +tyCoVarsOfType, tyCoVarsOfCt, et al. are used to compute the free type +variables of a type. The "Co" part of these functions' names shouldn't be +dismissed, as it is entirely possible that they will include coercion variables +in addition to type variables! As a result, there are some places in TcType +where we must take care to check that a variable is a _type_ variable (using +isTyVar) before calling tcTyVarDetails--a partial function that is not defined +for coercion variables--on the variable. Failing to do so led to +GHC #12785. +-} + +-- See Note [TcTyVars and TyVars in the typechecker] +type TcCoVar = CoVar -- Used only during type inference +type TcType = Type -- A TcType can have mutable type variables +type TcTyCoVar = Var -- Either a TcTyVar or a CoVar + -- Invariant on ForAllTy in TcTypes: + -- forall a. T + -- a cannot occur inside a MutTyVar in T; that is, + -- T is "flattened" before quantifying over a + +type TcTyVarBinder = TyVarBinder +type TcTyCon = TyCon -- these can be the TcTyCon constructor + +-- These types do not have boxy type variables in them +type TcPredType = PredType +type TcThetaType = ThetaType +type TcSigmaType = TcType +type TcRhoType = TcType -- Note [TcRhoType] +type TcTauType = TcType +type TcKind = Kind +type TcTyVarSet = TyVarSet +type TcTyCoVarSet = TyCoVarSet +type TcDTyVarSet = DTyVarSet +type TcDTyCoVarSet = DTyCoVarSet + +{- ********************************************************************* +* * + ExpType: an "expected type" in the type checker +* * +********************************************************************* -} + +-- | An expected type to check against during type-checking. +-- See Note [ExpType] in TcMType, where you'll also find manipulators. +data ExpType = Check TcType + | Infer !InferResult + +data InferResult + = IR { ir_uniq :: Unique -- For debugging only + + , ir_lvl :: TcLevel -- See Note [TcLevel of ExpType] in TcMType + + , ir_inst :: Bool + -- True <=> deeply instantiate before returning + -- i.e. return a RhoType + -- False <=> do not instantiate before returning + -- i.e. return a SigmaType + -- See Note [Deep instantiation of InferResult] in TcUnify + + , ir_ref :: IORef (Maybe TcType) } + -- The type that fills in this hole should be a Type, + -- that is, its kind should be (TYPE rr) for some rr + +type ExpSigmaType = ExpType +type ExpRhoType = ExpType + +instance Outputable ExpType where + ppr (Check ty) = text "Check" <> braces (ppr ty) + ppr (Infer ir) = ppr ir + +instance Outputable InferResult where + ppr (IR { ir_uniq = u, ir_lvl = lvl + , ir_inst = inst }) + = text "Infer" <> braces (ppr u <> comma <> ppr lvl <+> ppr inst) + +-- | Make an 'ExpType' suitable for checking. +mkCheckExpType :: TcType -> ExpType +mkCheckExpType = Check + + +{- ********************************************************************* +* * + SyntaxOpType +* * +********************************************************************* -} + +-- | What to expect for an argument to a rebindable-syntax operator. +-- Quite like 'Type', but allows for holes to be filled in by tcSyntaxOp. +-- The callback called from tcSyntaxOp gets a list of types; the meaning +-- of these types is determined by a left-to-right depth-first traversal +-- of the 'SyntaxOpType' tree. So if you pass in +-- +-- > SynAny `SynFun` (SynList `SynFun` SynType Int) `SynFun` SynAny +-- +-- you'll get three types back: one for the first 'SynAny', the /element/ +-- type of the list, and one for the last 'SynAny'. You don't get anything +-- for the 'SynType', because you've said positively that it should be an +-- Int, and so it shall be. +-- +-- This is defined here to avoid defining it in TcExpr.hs-boot. +data SyntaxOpType + = SynAny -- ^ Any type + | SynRho -- ^ A rho type, deeply skolemised or instantiated as appropriate + | SynList -- ^ A list type. You get back the element type of the list + | SynFun SyntaxOpType SyntaxOpType + -- ^ A function. + | SynType ExpType -- ^ A known type. +infixr 0 `SynFun` + +-- | Like 'SynType' but accepts a regular TcType +synKnownType :: TcType -> SyntaxOpType +synKnownType = SynType . mkCheckExpType + +-- | Like 'mkFunTys' but for 'SyntaxOpType' +mkSynFunTys :: [SyntaxOpType] -> ExpType -> SyntaxOpType +mkSynFunTys arg_tys res_ty = foldr SynFun (SynType res_ty) arg_tys + + +{- +Note [TcRhoType] +~~~~~~~~~~~~~~~~ +A TcRhoType has no foralls or contexts at the top, or to the right of an arrow + YES (forall a. a->a) -> Int + NO forall a. a -> Int + NO Eq a => a -> a + NO Int -> forall a. a -> Int + + +************************************************************************ +* * + TyVarDetails, MetaDetails, MetaInfo +* * +************************************************************************ + +TyVarDetails gives extra info about type variables, used during type +checking. It's attached to mutable type variables only. +It's knot-tied back to Var.hs. There is no reason in principle +why Var.hs shouldn't actually have the definition, but it "belongs" here. + +Note [Signature skolems] +~~~~~~~~~~~~~~~~~~~~~~~~ +A TyVarTv is a specialised variant of TauTv, with the following invarints: + + * A TyVarTv can be unified only with a TyVar, + not with any other type + + * Its MetaDetails, if filled in, will always be another TyVarTv + or a SkolemTv + +TyVarTvs are only distinguished to improve error messages. +Consider this + + data T (a:k1) = MkT (S a) + data S (b:k2) = MkS (T b) + +When doing kind inference on {S,T} we don't want *skolems* for k1,k2, +because they end up unifying; we want those TyVarTvs again. + + +Note [TyVars and TcTyVars during type checking] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The Var type has constructors TyVar and TcTyVar. They are used +as follows: + +* TcTyVar: used /only/ during type checking. Should never appear + afterwards. May contain a mutable field, in the MetaTv case. + +* TyVar: is never seen by the constraint solver, except locally + inside a type like (forall a. [a] ->[a]), where 'a' is a TyVar. + We instantiate these with TcTyVars before exposing the type + to the constraint solver. + +I have swithered about the latter invariant, excluding TyVars from the +constraint solver. It's not strictly essential, and indeed +(historically but still there) Var.tcTyVarDetails returns +vanillaSkolemTv for a TyVar. + +But ultimately I want to seeparate Type from TcType, and in that case +we would need to enforce the separation. +-} + +-- A TyVarDetails is inside a TyVar +-- See Note [TyVars and TcTyVars] +data TcTyVarDetails + = SkolemTv -- A skolem + TcLevel -- Level of the implication that binds it + -- See TcUnify Note [Deeper level on the left] for + -- how this level number is used + Bool -- True <=> this skolem type variable can be overlapped + -- when looking up instances + -- See Note [Binding when looking up instances] in InstEnv + + | RuntimeUnk -- Stands for an as-yet-unknown type in the GHCi + -- interactive context + + | MetaTv { mtv_info :: MetaInfo + , mtv_ref :: IORef MetaDetails + , mtv_tclvl :: TcLevel } -- See Note [TcLevel and untouchable type variables] + +vanillaSkolemTv, superSkolemTv :: TcTyVarDetails +-- See Note [Binding when looking up instances] in InstEnv +vanillaSkolemTv = SkolemTv topTcLevel False -- Might be instantiated +superSkolemTv = SkolemTv topTcLevel True -- Treat this as a completely distinct type + -- The choice of level number here is a bit dodgy, but + -- topTcLevel works in the places that vanillaSkolemTv is used + +----------------------------- +data MetaDetails + = Flexi -- Flexi type variables unify to become Indirects + | Indirect TcType + +data MetaInfo + = TauTv -- This MetaTv is an ordinary unification variable + -- A TauTv is always filled in with a tau-type, which + -- never contains any ForAlls. + + | TyVarTv -- A variant of TauTv, except that it should not be + -- unified with a type, only with a type variable + -- See Note [Signature skolems] + + | FlatMetaTv -- A flatten meta-tyvar + -- It is a meta-tyvar, but it is always untouchable, with level 0 + -- See Note [The flattening story] in TcFlatten + + | FlatSkolTv -- A flatten skolem tyvar + -- Just like FlatMetaTv, but is comletely "owned" by + -- its Given CFunEqCan. + -- It is filled in /only/ by unflattenGivens + -- See Note [The flattening story] in TcFlatten + +instance Outputable MetaDetails where + ppr Flexi = text "Flexi" + ppr (Indirect ty) = text "Indirect" <+> ppr ty + +pprTcTyVarDetails :: TcTyVarDetails -> SDoc +-- For debugging +pprTcTyVarDetails (RuntimeUnk {}) = text "rt" +pprTcTyVarDetails (SkolemTv lvl True) = text "ssk" <> colon <> ppr lvl +pprTcTyVarDetails (SkolemTv lvl False) = text "sk" <> colon <> ppr lvl +pprTcTyVarDetails (MetaTv { mtv_info = info, mtv_tclvl = tclvl }) + = pp_info <> colon <> ppr tclvl + where + pp_info = case info of + TauTv -> text "tau" + TyVarTv -> text "tyv" + FlatMetaTv -> text "fmv" + FlatSkolTv -> text "fsk" + + +{- ********************************************************************* +* * + UserTypeCtxt +* * +********************************************************************* -} + +------------------------------------- +-- UserTypeCtxt describes the origin of the polymorphic type +-- in the places where we need an expression to have that type + +data UserTypeCtxt + = FunSigCtxt -- Function type signature, when checking the type + -- Also used for types in SPECIALISE pragmas + Name -- Name of the function + Bool -- True <=> report redundant constraints + -- This is usually True, but False for + -- * Record selectors (not important here) + -- * Class and instance methods. Here + -- the code may legitimately be more + -- polymorphic than the signature + -- generated from the class + -- declaration + + | InfSigCtxt Name -- Inferred type for function + | ExprSigCtxt -- Expression type signature + | KindSigCtxt -- Kind signature + | TypeAppCtxt -- Visible type application + | ConArgCtxt Name -- Data constructor argument + | TySynCtxt Name -- RHS of a type synonym decl + | PatSynCtxt Name -- Type sig for a pattern synonym + | PatSigCtxt -- Type sig in pattern + -- eg f (x::t) = ... + -- or (x::t, y) = e + | RuleSigCtxt Name -- LHS of a RULE forall + -- RULE "foo" forall (x :: a -> a). f (Just x) = ... + | ResSigCtxt -- Result type sig + -- f x :: t = .... + | ForSigCtxt Name -- Foreign import or export signature + | DefaultDeclCtxt -- Types in a default declaration + | InstDeclCtxt Bool -- An instance declaration + -- True: stand-alone deriving + -- False: vanilla instance declaration + | SpecInstCtxt -- SPECIALISE instance pragma + | ThBrackCtxt -- Template Haskell type brackets [t| ... |] + | GenSigCtxt -- Higher-rank or impredicative situations + -- e.g. (f e) where f has a higher-rank type + -- We might want to elaborate this + | GhciCtxt Bool -- GHCi command :kind + -- The Bool indicates if we are checking the outermost + -- type application. + -- See Note [Unsaturated type synonyms in GHCi] in + -- TcValidity. + + | ClassSCCtxt Name -- Superclasses of a class + | SigmaCtxt -- Theta part of a normal for-all type + -- f :: => a -> a + | DataTyCtxt Name -- The "stupid theta" part of a data decl + -- data => T a = MkT a + | DerivClauseCtxt -- A 'deriving' clause + | TyVarBndrKindCtxt Name -- The kind of a type variable being bound + | DataKindCtxt Name -- The kind of a data/newtype (instance) + | TySynKindCtxt Name -- The kind of the RHS of a type synonym + | TyFamResKindCtxt Name -- The result kind of a type family + +{- +-- Notes re TySynCtxt +-- We allow type synonyms that aren't types; e.g. type List = [] +-- +-- If the RHS mentions tyvars that aren't in scope, we'll +-- quantify over them: +-- e.g. type T = a->a +-- will become type T = forall a. a->a +-- +-- With gla-exts that's right, but for H98 we should complain. +-} + + +pprUserTypeCtxt :: UserTypeCtxt -> SDoc +pprUserTypeCtxt (FunSigCtxt n _) = text "the type signature for" <+> quotes (ppr n) +pprUserTypeCtxt (InfSigCtxt n) = text "the inferred type for" <+> quotes (ppr n) +pprUserTypeCtxt (RuleSigCtxt n) = text "a RULE for" <+> quotes (ppr n) +pprUserTypeCtxt ExprSigCtxt = text "an expression type signature" +pprUserTypeCtxt KindSigCtxt = text "a kind signature" +pprUserTypeCtxt TypeAppCtxt = text "a type argument" +pprUserTypeCtxt (ConArgCtxt c) = text "the type of the constructor" <+> quotes (ppr c) +pprUserTypeCtxt (TySynCtxt c) = text "the RHS of the type synonym" <+> quotes (ppr c) +pprUserTypeCtxt ThBrackCtxt = text "a Template Haskell quotation [t|...|]" +pprUserTypeCtxt PatSigCtxt = text "a pattern type signature" +pprUserTypeCtxt ResSigCtxt = text "a result type signature" +pprUserTypeCtxt (ForSigCtxt n) = text "the foreign declaration for" <+> quotes (ppr n) +pprUserTypeCtxt DefaultDeclCtxt = text "a type in a `default' declaration" +pprUserTypeCtxt (InstDeclCtxt False) = text "an instance declaration" +pprUserTypeCtxt (InstDeclCtxt True) = text "a stand-alone deriving instance declaration" +pprUserTypeCtxt SpecInstCtxt = text "a SPECIALISE instance pragma" +pprUserTypeCtxt GenSigCtxt = text "a type expected by the context" +pprUserTypeCtxt (GhciCtxt {}) = text "a type in a GHCi command" +pprUserTypeCtxt (ClassSCCtxt c) = text "the super-classes of class" <+> quotes (ppr c) +pprUserTypeCtxt SigmaCtxt = text "the context of a polymorphic type" +pprUserTypeCtxt (DataTyCtxt tc) = text "the context of the data type declaration for" <+> quotes (ppr tc) +pprUserTypeCtxt (PatSynCtxt n) = text "the signature for pattern synonym" <+> quotes (ppr n) +pprUserTypeCtxt (DerivClauseCtxt) = text "a `deriving' clause" +pprUserTypeCtxt (TyVarBndrKindCtxt n) = text "the kind annotation on the type variable" <+> quotes (ppr n) +pprUserTypeCtxt (DataKindCtxt n) = text "the kind annotation on the declaration for" <+> quotes (ppr n) +pprUserTypeCtxt (TySynKindCtxt n) = text "the kind annotation on the declaration for" <+> quotes (ppr n) +pprUserTypeCtxt (TyFamResKindCtxt n) = text "the result kind for" <+> quotes (ppr n) + +isSigMaybe :: UserTypeCtxt -> Maybe Name +isSigMaybe (FunSigCtxt n _) = Just n +isSigMaybe (ConArgCtxt n) = Just n +isSigMaybe (ForSigCtxt n) = Just n +isSigMaybe (PatSynCtxt n) = Just n +isSigMaybe _ = Nothing + + +{- ********************************************************************* +* * + Untouchable type variables +* * +********************************************************************* -} + +newtype TcLevel = TcLevel Int deriving( Eq, Ord ) + -- See Note [TcLevel and untouchable type variables] for what this Int is + -- See also Note [TcLevel assignment] + +{- +Note [TcLevel and untouchable type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Each unification variable (MetaTv) + and each Implication + has a level number (of type TcLevel) + +* INVARIANTS. In a tree of Implications, + + (ImplicInv) The level number (ic_tclvl) of an Implication is + STRICTLY GREATER THAN that of its parent + + (SkolInv) The level number of the skolems (ic_skols) of an + Implication is equal to the level of the implication + itself (ic_tclvl) + + (GivenInv) The level number of a unification variable appearing + in the 'ic_given' of an implication I should be + STRICTLY LESS THAN the ic_tclvl of I + + (WantedInv) The level number of a unification variable appearing + in the 'ic_wanted' of an implication I should be + LESS THAN OR EQUAL TO the ic_tclvl of I + See Note [WantedInv] + +* A unification variable is *touchable* if its level number + is EQUAL TO that of its immediate parent implication, + and it is a TauTv or TyVarTv (but /not/ FlatMetaTv or FlatSkolTv) + +Note [WantedInv] +~~~~~~~~~~~~~~~~ +Why is WantedInv important? Consider this implication, where +the constraint (C alpha[3]) disobeys WantedInv: + + forall[2] a. blah => (C alpha[3]) + (forall[3] b. alpha[3] ~ b) + +We can unify alpha:=b in the inner implication, because 'alpha' is +touchable; but then 'b' has excaped its scope into the outer implication. + +Note [Skolem escape prevention] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We only unify touchable unification variables. Because of +(WantedInv), there can be no occurrences of the variable further out, +so the unification can't cause the skolems to escape. Example: + data T = forall a. MkT a (a->Int) + f x (MkT v f) = length [v,x] +We decide (x::alpha), and generate an implication like + [1]forall a. (a ~ alpha[0]) +But we must not unify alpha:=a, because the skolem would escape. + +For the cases where we DO want to unify, we rely on floating the +equality. Example (with same T) + g x (MkT v f) = x && True +We decide (x::alpha), and generate an implication like + [1]forall a. (Bool ~ alpha[0]) +We do NOT unify directly, bur rather float out (if the constraint +does not mention 'a') to get + (Bool ~ alpha[0]) /\ [1]forall a.() +and NOW we can unify alpha. + +The same idea of only unifying touchables solves another problem. +Suppose we had + (F Int ~ uf[0]) /\ [1](forall a. C a => F Int ~ beta[1]) +In this example, beta is touchable inside the implication. The +first solveSimpleWanteds step leaves 'uf' un-unified. Then we move inside +the implication where a new constraint + uf ~ beta +emerges. If we (wrongly) spontaneously solved it to get uf := beta, +the whole implication disappears but when we pop out again we are left with +(F Int ~ uf) which will be unified by our final zonking stage and +uf will get unified *once more* to (F Int). + +Note [TcLevel assignment] +~~~~~~~~~~~~~~~~~~~~~~~~~ +We arrange the TcLevels like this + + 0 Top level + 1 First-level implication constraints + 2 Second-level implication constraints + ...etc... +-} + +maxTcLevel :: TcLevel -> TcLevel -> TcLevel +maxTcLevel (TcLevel a) (TcLevel b) = TcLevel (a `max` b) + +topTcLevel :: TcLevel +-- See Note [TcLevel assignment] +topTcLevel = TcLevel 0 -- 0 = outermost level + +isTopTcLevel :: TcLevel -> Bool +isTopTcLevel (TcLevel 0) = True +isTopTcLevel _ = False + +pushTcLevel :: TcLevel -> TcLevel +-- See Note [TcLevel assignment] +pushTcLevel (TcLevel us) = TcLevel (us + 1) + +strictlyDeeperThan :: TcLevel -> TcLevel -> Bool +strictlyDeeperThan (TcLevel tv_tclvl) (TcLevel ctxt_tclvl) + = tv_tclvl > ctxt_tclvl + +sameDepthAs :: TcLevel -> TcLevel -> Bool +sameDepthAs (TcLevel ctxt_tclvl) (TcLevel tv_tclvl) + = ctxt_tclvl == tv_tclvl -- NB: invariant ctxt_tclvl >= tv_tclvl + -- So <= would be equivalent + +checkTcLevelInvariant :: TcLevel -> TcLevel -> Bool +-- Checks (WantedInv) from Note [TcLevel and untouchable type variables] +checkTcLevelInvariant (TcLevel ctxt_tclvl) (TcLevel tv_tclvl) + = ctxt_tclvl >= tv_tclvl + +tcTyVarLevel :: TcTyVar -> TcLevel +tcTyVarLevel tv + = ASSERT2( tcIsTcTyVar tv, ppr tv ) + case tcTyVarDetails tv of + MetaTv { mtv_tclvl = tv_lvl } -> tv_lvl + SkolemTv tv_lvl _ -> tv_lvl + RuntimeUnk -> topTcLevel + + +tcTypeLevel :: TcType -> TcLevel +-- Max level of any free var of the type +tcTypeLevel ty + = foldDVarSet add topTcLevel (tyCoVarsOfTypeDSet ty) + where + add v lvl + | isTcTyVar v = lvl `maxTcLevel` tcTyVarLevel v + | otherwise = lvl + +instance Outputable TcLevel where + ppr (TcLevel us) = ppr us + +promoteSkolem :: TcLevel -> TcTyVar -> TcTyVar +promoteSkolem tclvl skol + | tclvl < tcTyVarLevel skol + = ASSERT( isTcTyVar skol && isSkolemTyVar skol ) + setTcTyVarDetails skol (SkolemTv tclvl (isOverlappableTyVar skol)) + + | otherwise + = skol + +-- | Change the TcLevel in a skolem, extending a substitution +promoteSkolemX :: TcLevel -> TCvSubst -> TcTyVar -> (TCvSubst, TcTyVar) +promoteSkolemX tclvl subst skol + = ASSERT( isTcTyVar skol && isSkolemTyVar skol ) + (new_subst, new_skol) + where + new_skol + | tclvl < tcTyVarLevel skol + = setTcTyVarDetails (updateTyVarKind (substTy subst) skol) + (SkolemTv tclvl (isOverlappableTyVar skol)) + | otherwise + = updateTyVarKind (substTy subst) skol + new_subst = extendTvSubstWithClone subst skol new_skol + +promoteSkolemsX :: TcLevel -> TCvSubst -> [TcTyVar] -> (TCvSubst, [TcTyVar]) +promoteSkolemsX tclvl = mapAccumL (promoteSkolemX tclvl) + +{- ********************************************************************* +* * + Finding type family instances +* * +************************************************************************ +-} + +-- | Finds outermost type-family applications occurring in a type, +-- after expanding synonyms. In the list (F, tys) that is returned +-- we guarantee that tys matches F's arity. For example, given +-- type family F a :: * -> * (arity 1) +-- calling tcTyFamInsts on (Maybe (F Int Bool) will return +-- (F, [Int]), not (F, [Int,Bool]) +-- +-- This is important for its use in deciding termination of type +-- instances (see #11581). E.g. +-- type instance G [Int] = ...(F Int )... +-- we don't need to take into account when asking if +-- the calls on the RHS are smaller than the LHS +tcTyFamInsts :: Type -> [(TyCon, [Type])] +tcTyFamInsts = map (\(_,b,c) -> (b,c)) . tcTyFamInstsAndVis + +-- | Like 'tcTyFamInsts', except that the output records whether the +-- type family and its arguments occur as an /invisible/ argument in +-- some type application. This information is useful because it helps GHC know +-- when to turn on @-fprint-explicit-kinds@ during error reporting so that +-- users can actually see the type family being mentioned. +-- +-- As an example, consider: +-- +-- @ +-- class C a +-- data T (a :: k) +-- type family F a :: k +-- instance C (T @(F Int) (F Bool)) +-- @ +-- +-- There are two occurrences of the type family `F` in that `C` instance, so +-- @'tcTyFamInstsAndVis' (C (T \@(F Int) (F Bool)))@ will return: +-- +-- @ +-- [ ('True', F, [Int]) +-- , ('False', F, [Bool]) ] +-- @ +-- +-- @F Int@ is paired with 'True' since it appears as an /invisible/ argument +-- to @C@, whereas @F Bool@ is paired with 'False' since it appears an a +-- /visible/ argument to @C@. +-- +-- See also @Note [Kind arguments in error messages]@ in "TcErrors". +tcTyFamInstsAndVis :: Type -> [(Bool, TyCon, [Type])] +tcTyFamInstsAndVis = tcTyFamInstsAndVisX False + +tcTyFamInstsAndVisX + :: Bool -- ^ Is this an invisible argument to some type application? + -> Type -> [(Bool, TyCon, [Type])] +tcTyFamInstsAndVisX = go + where + go is_invis_arg ty + | Just exp_ty <- tcView ty = go is_invis_arg exp_ty + go _ (TyVarTy _) = [] + go is_invis_arg (TyConApp tc tys) + | isTypeFamilyTyCon tc + = [(is_invis_arg, tc, take (tyConArity tc) tys)] + | otherwise + = tcTyConAppTyFamInstsAndVisX is_invis_arg tc tys + go _ (LitTy {}) = [] + go is_invis_arg (ForAllTy bndr ty) = go is_invis_arg (binderType bndr) + ++ go is_invis_arg ty + go is_invis_arg (FunTy _ ty1 ty2) = go is_invis_arg ty1 + ++ go is_invis_arg ty2 + go is_invis_arg ty@(AppTy _ _) = + let (ty_head, ty_args) = splitAppTys ty + ty_arg_flags = appTyArgFlags ty_head ty_args + in go is_invis_arg ty_head + ++ concat (zipWith (\flag -> go (isInvisibleArgFlag flag)) + ty_arg_flags ty_args) + go is_invis_arg (CastTy ty _) = go is_invis_arg ty + go _ (CoercionTy _) = [] -- don't count tyfams in coercions, + -- as they never get normalized, + -- anyway + +-- | In an application of a 'TyCon' to some arguments, find the outermost +-- occurrences of type family applications within the arguments. This function +-- will not consider the 'TyCon' itself when checking for type family +-- applications. +-- +-- See 'tcTyFamInstsAndVis' for more details on how this works (as this +-- function is called inside of 'tcTyFamInstsAndVis'). +tcTyConAppTyFamInstsAndVis :: TyCon -> [Type] -> [(Bool, TyCon, [Type])] +tcTyConAppTyFamInstsAndVis = tcTyConAppTyFamInstsAndVisX False + +tcTyConAppTyFamInstsAndVisX + :: Bool -- ^ Is this an invisible argument to some type application? + -> TyCon -> [Type] -> [(Bool, TyCon, [Type])] +tcTyConAppTyFamInstsAndVisX is_invis_arg tc tys = + let (invis_tys, vis_tys) = partitionInvisibleTypes tc tys + in concat $ map (tcTyFamInstsAndVisX True) invis_tys + ++ map (tcTyFamInstsAndVisX is_invis_arg) vis_tys + +isTyFamFree :: Type -> Bool +-- ^ Check that a type does not contain any type family applications. +isTyFamFree = null . tcTyFamInsts + +{- +************************************************************************ +* * + The "exact" free variables of a type +* * +************************************************************************ + +Note [Silly type synonym] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + type T a = Int +What are the free tyvars of (T x)? Empty, of course! + +exactTyCoVarsOfType is used by the type checker to figure out exactly +which type variables are mentioned in a type. It only matters +occasionally -- see the calls to exactTyCoVarsOfType. + +Historical note: years and years ago this function was used during +generalisation -- see #1813. But that code has long since died. +-} + +exactTyCoVarsOfType :: Type -> TyCoVarSet +-- Find the free type variables (of any kind) +-- but *expand* type synonyms. See Note [Silly type synonym] above. +exactTyCoVarsOfType ty + = go ty + where + go ty | Just ty' <- tcView ty = go ty' -- This is the key line + go (TyVarTy tv) = goVar tv + go (TyConApp _ tys) = exactTyCoVarsOfTypes tys + go (LitTy {}) = emptyVarSet + go (AppTy fun arg) = go fun `unionVarSet` go arg + go (FunTy _ arg res) = go arg `unionVarSet` go res + go (ForAllTy bndr ty) = delBinderVar (go ty) bndr `unionVarSet` go (binderType bndr) + go (CastTy ty co) = go ty `unionVarSet` goCo co + go (CoercionTy co) = goCo co + + goMCo MRefl = emptyVarSet + goMCo (MCo co) = goCo co + + goCo (Refl ty) = go ty + goCo (GRefl _ ty mco) = go ty `unionVarSet` goMCo mco + goCo (TyConAppCo _ _ args)= goCos args + goCo (AppCo co arg) = goCo co `unionVarSet` goCo arg + goCo (ForAllCo tv k_co co) + = goCo co `delVarSet` tv `unionVarSet` goCo k_co + goCo (FunCo _ co1 co2) = goCo co1 `unionVarSet` goCo co2 + goCo (CoVarCo v) = goVar v + goCo (HoleCo h) = goVar (coHoleCoVar h) + goCo (AxiomInstCo _ _ args) = goCos args + goCo (UnivCo p _ t1 t2) = goProv p `unionVarSet` go t1 `unionVarSet` go t2 + goCo (SymCo co) = goCo co + goCo (TransCo co1 co2) = goCo co1 `unionVarSet` goCo co2 + goCo (NthCo _ _ co) = goCo co + goCo (LRCo _ co) = goCo co + goCo (InstCo co arg) = goCo co `unionVarSet` goCo arg + goCo (KindCo co) = goCo co + goCo (SubCo co) = goCo co + goCo (AxiomRuleCo _ c) = goCos c + + goCos cos = foldr (unionVarSet . goCo) emptyVarSet cos + + goProv UnsafeCoerceProv = emptyVarSet + goProv (PhantomProv kco) = goCo kco + goProv (ProofIrrelProv kco) = goCo kco + goProv (PluginProv _) = emptyVarSet + + goVar v = unitVarSet v `unionVarSet` go (varType v) + +exactTyCoVarsOfTypes :: [Type] -> TyVarSet +exactTyCoVarsOfTypes tys = mapUnionVarSet exactTyCoVarsOfType tys + +anyRewritableTyVar :: Bool -- Ignore casts and coercions + -> EqRel -- Ambient role + -> (EqRel -> TcTyVar -> Bool) + -> TcType -> Bool +-- (anyRewritableTyVar ignore_cos pred ty) returns True +-- if the 'pred' returns True of any free TyVar in 'ty' +-- Do not look inside casts and coercions if 'ignore_cos' is True +-- See Note [anyRewritableTyVar must be role-aware] +anyRewritableTyVar ignore_cos role pred ty + = go role emptyVarSet ty + where + go_tv rl bvs tv | tv `elemVarSet` bvs = False + | otherwise = pred rl tv + + go rl bvs (TyVarTy tv) = go_tv rl bvs tv + go _ _ (LitTy {}) = False + go rl bvs (TyConApp tc tys) = go_tc rl bvs tc tys + go rl bvs (AppTy fun arg) = go rl bvs fun || go NomEq bvs arg + go rl bvs (FunTy _ arg res) = go rl bvs arg || go rl bvs res + go rl bvs (ForAllTy tv ty) = go rl (bvs `extendVarSet` binderVar tv) ty + go rl bvs (CastTy ty co) = go rl bvs ty || go_co rl bvs co + go rl bvs (CoercionTy co) = go_co rl bvs co -- ToDo: check + + go_tc NomEq bvs _ tys = any (go NomEq bvs) tys + go_tc ReprEq bvs tc tys = any (go_arg bvs) + (tyConRolesRepresentational tc `zip` tys) + + go_arg bvs (Nominal, ty) = go NomEq bvs ty + go_arg bvs (Representational, ty) = go ReprEq bvs ty + go_arg _ (Phantom, _) = False -- We never rewrite with phantoms + + go_co rl bvs co + | ignore_cos = False + | otherwise = anyVarSet (go_tv rl bvs) (tyCoVarsOfCo co) + -- We don't have an equivalent of anyRewritableTyVar for coercions + -- (at least not yet) so take the free vars and test them + +{- Note [anyRewritableTyVar must be role-aware] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +anyRewritableTyVar is used during kick-out from the inert set, +to decide if, given a new equality (a ~ ty), we should kick out +a constraint C. Rather than gather free variables and see if 'a' +is among them, we instead pass in a predicate; this is just efficiency. + +Moreover, consider + work item: [G] a ~R f b + inert item: [G] b ~R f a +We use anyRewritableTyVar to decide whether to kick out the inert item, +on the grounds that the work item might rewrite it. Well, 'a' is certainly +free in [G] b ~R f a. But because the role of a type variable ('f' in +this case) is nominal, the work item can't actually rewrite the inert item. +Moreover, if we were to kick out the inert item the exact same situation +would re-occur and we end up with an infinite loop in which each kicks +out the other (#14363). +-} + +{- +************************************************************************ +* * + Predicates +* * +************************************************************************ +-} + +tcIsTcTyVar :: TcTyVar -> Bool +-- See Note [TcTyVars and TyVars in the typechecker] +tcIsTcTyVar tv = isTyVar tv + +isTouchableMetaTyVar :: TcLevel -> TcTyVar -> Bool +isTouchableMetaTyVar ctxt_tclvl tv + | isTyVar tv -- See Note [Coercion variables in free variable lists] + , MetaTv { mtv_tclvl = tv_tclvl, mtv_info = info } <- tcTyVarDetails tv + , not (isFlattenInfo info) + = ASSERT2( checkTcLevelInvariant ctxt_tclvl tv_tclvl, + ppr tv $$ ppr tv_tclvl $$ ppr ctxt_tclvl ) + tv_tclvl `sameDepthAs` ctxt_tclvl + + | otherwise = False + +isFloatedTouchableMetaTyVar :: TcLevel -> TcTyVar -> Bool +isFloatedTouchableMetaTyVar ctxt_tclvl tv + | isTyVar tv -- See Note [Coercion variables in free variable lists] + , MetaTv { mtv_tclvl = tv_tclvl, mtv_info = info } <- tcTyVarDetails tv + , not (isFlattenInfo info) + = tv_tclvl `strictlyDeeperThan` ctxt_tclvl + + | otherwise = False + +isImmutableTyVar :: TyVar -> Bool +isImmutableTyVar tv = isSkolemTyVar tv + +isTyConableTyVar, isSkolemTyVar, isOverlappableTyVar, + isMetaTyVar, isAmbiguousTyVar, + isFmvTyVar, isFskTyVar, isFlattenTyVar :: TcTyVar -> Bool + +isTyConableTyVar tv + -- True of a meta-type variable that can be filled in + -- with a type constructor application; in particular, + -- not a TyVarTv + | isTyVar tv -- See Note [Coercion variables in free variable lists] + = case tcTyVarDetails tv of + MetaTv { mtv_info = TyVarTv } -> False + _ -> True + | otherwise = True + +isFmvTyVar tv + = ASSERT2( tcIsTcTyVar tv, ppr tv ) + case tcTyVarDetails tv of + MetaTv { mtv_info = FlatMetaTv } -> True + _ -> False + +isFskTyVar tv + = ASSERT2( tcIsTcTyVar tv, ppr tv ) + case tcTyVarDetails tv of + MetaTv { mtv_info = FlatSkolTv } -> True + _ -> False + +-- | True of both given and wanted flatten-skolems (fmv and fsk) +isFlattenTyVar tv + = ASSERT2( tcIsTcTyVar tv, ppr tv ) + case tcTyVarDetails tv of + MetaTv { mtv_info = info } -> isFlattenInfo info + _ -> False + +isSkolemTyVar tv + = ASSERT2( tcIsTcTyVar tv, ppr tv ) + case tcTyVarDetails tv of + MetaTv {} -> False + _other -> True + +isOverlappableTyVar tv + | isTyVar tv -- See Note [Coercion variables in free variable lists] + = case tcTyVarDetails tv of + SkolemTv _ overlappable -> overlappable + _ -> False + | otherwise = False + +isMetaTyVar tv + | isTyVar tv -- See Note [Coercion variables in free variable lists] + = case tcTyVarDetails tv of + MetaTv {} -> True + _ -> False + | otherwise = False + +-- isAmbiguousTyVar is used only when reporting type errors +-- It picks out variables that are unbound, namely meta +-- type variables and the RuntimUnk variables created by +-- RtClosureInspect.zonkRTTIType. These are "ambiguous" in +-- the sense that they stand for an as-yet-unknown type +isAmbiguousTyVar tv + | isTyVar tv -- See Note [Coercion variables in free variable lists] + = case tcTyVarDetails tv of + MetaTv {} -> True + RuntimeUnk {} -> True + _ -> False + | otherwise = False + +isMetaTyVarTy :: TcType -> Bool +isMetaTyVarTy (TyVarTy tv) = isMetaTyVar tv +isMetaTyVarTy _ = False + +metaTyVarInfo :: TcTyVar -> MetaInfo +metaTyVarInfo tv + = case tcTyVarDetails tv of + MetaTv { mtv_info = info } -> info + _ -> pprPanic "metaTyVarInfo" (ppr tv) + +isFlattenInfo :: MetaInfo -> Bool +isFlattenInfo FlatMetaTv = True +isFlattenInfo FlatSkolTv = True +isFlattenInfo _ = False + +metaTyVarTcLevel :: TcTyVar -> TcLevel +metaTyVarTcLevel tv + = case tcTyVarDetails tv of + MetaTv { mtv_tclvl = tclvl } -> tclvl + _ -> pprPanic "metaTyVarTcLevel" (ppr tv) + +metaTyVarTcLevel_maybe :: TcTyVar -> Maybe TcLevel +metaTyVarTcLevel_maybe tv + = case tcTyVarDetails tv of + MetaTv { mtv_tclvl = tclvl } -> Just tclvl + _ -> Nothing + +metaTyVarRef :: TyVar -> IORef MetaDetails +metaTyVarRef tv + = case tcTyVarDetails tv of + MetaTv { mtv_ref = ref } -> ref + _ -> pprPanic "metaTyVarRef" (ppr tv) + +setMetaTyVarTcLevel :: TcTyVar -> TcLevel -> TcTyVar +setMetaTyVarTcLevel tv tclvl + = case tcTyVarDetails tv of + details@(MetaTv {}) -> setTcTyVarDetails tv (details { mtv_tclvl = tclvl }) + _ -> pprPanic "metaTyVarTcLevel" (ppr tv) + +isTyVarTyVar :: Var -> Bool +isTyVarTyVar tv + = case tcTyVarDetails tv of + MetaTv { mtv_info = TyVarTv } -> True + _ -> False + +isFlexi, isIndirect :: MetaDetails -> Bool +isFlexi Flexi = True +isFlexi _ = False + +isIndirect (Indirect _) = True +isIndirect _ = False + +isRuntimeUnkSkol :: TyVar -> Bool +-- Called only in TcErrors; see Note [Runtime skolems] there +isRuntimeUnkSkol x + | RuntimeUnk <- tcTyVarDetails x = True + | otherwise = False + +mkTyVarNamePairs :: [TyVar] -> [(Name,TyVar)] +-- Just pair each TyVar with its own name +mkTyVarNamePairs tvs = [(tyVarName tv, tv) | tv <- tvs] + +findDupTyVarTvs :: [(Name,TcTyVar)] -> [(Name,Name)] +-- If we have [...(x1,tv)...(x2,tv)...] +-- return (x1,x2) in the result list +findDupTyVarTvs prs + = concatMap mk_result_prs $ + findDupsEq eq_snd prs + where + eq_snd (_,tv1) (_,tv2) = tv1 == tv2 + mk_result_prs ((n1,_) :| xs) = map (\(n2,_) -> (n1,n2)) xs + +{- +************************************************************************ +* * +\subsection{Tau, sigma and rho} +* * +************************************************************************ +-} + +mkSigmaTy :: [TyCoVarBinder] -> [PredType] -> Type -> Type +mkSigmaTy bndrs theta tau = mkForAllTys bndrs (mkPhiTy theta tau) + +-- | Make a sigma ty where all type variables are 'Inferred'. That is, +-- they cannot be used with visible type application. +mkInfSigmaTy :: [TyCoVar] -> [PredType] -> Type -> Type +mkInfSigmaTy tyvars theta ty = mkSigmaTy (mkTyCoVarBinders Inferred tyvars) theta ty + +-- | Make a sigma ty where all type variables are "specified". That is, +-- they can be used with visible type application +mkSpecSigmaTy :: [TyVar] -> [PredType] -> Type -> Type +mkSpecSigmaTy tyvars preds ty = mkSigmaTy (mkTyCoVarBinders Specified tyvars) preds ty + +mkPhiTy :: [PredType] -> Type -> Type +mkPhiTy = mkInvisFunTys + +--------------- +getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to + -- construct a dictionary function name +getDFunTyKey ty | Just ty' <- coreView ty = getDFunTyKey ty' +getDFunTyKey (TyVarTy tv) = getOccName tv +getDFunTyKey (TyConApp tc _) = getOccName tc +getDFunTyKey (LitTy x) = getDFunTyLitKey x +getDFunTyKey (AppTy fun _) = getDFunTyKey fun +getDFunTyKey (FunTy {}) = getOccName funTyCon +getDFunTyKey (ForAllTy _ t) = getDFunTyKey t +getDFunTyKey (CastTy ty _) = getDFunTyKey ty +getDFunTyKey t@(CoercionTy _) = pprPanic "getDFunTyKey" (ppr t) + +getDFunTyLitKey :: TyLit -> OccName +getDFunTyLitKey (NumTyLit n) = mkOccName Name.varName (show n) +getDFunTyLitKey (StrTyLit n) = mkOccName Name.varName (show n) -- hm + +{- ********************************************************************* +* * + Building types +* * +********************************************************************* -} + +-- ToDo: I think we need Tc versions of these +-- Reason: mkCastTy checks isReflexiveCastTy, which checks +-- for equality; and that has a different answer +-- depending on whether or not Type = Constraint + +mkTcAppTys :: Type -> [Type] -> Type +mkTcAppTys = mkAppTys + +mkTcAppTy :: Type -> Type -> Type +mkTcAppTy = mkAppTy + +mkTcCastTy :: Type -> Coercion -> Type +mkTcCastTy = mkCastTy -- Do we need a tc version of mkCastTy? + +{- +************************************************************************ +* * +\subsection{Expanding and splitting} +* * +************************************************************************ + +These tcSplit functions are like their non-Tc analogues, but + *) they do not look through newtypes + +However, they are non-monadic and do not follow through mutable type +variables. It's up to you to make sure this doesn't matter. +-} + +-- | Splits a forall type into a list of 'TyBinder's and the inner type. +-- Always succeeds, even if it returns an empty list. +tcSplitPiTys :: Type -> ([TyBinder], Type) +tcSplitPiTys ty + = ASSERT( all isTyBinder (fst sty) ) sty + where sty = splitPiTys ty + +-- | Splits a type into a TyBinder and a body, if possible. Panics otherwise +tcSplitPiTy_maybe :: Type -> Maybe (TyBinder, Type) +tcSplitPiTy_maybe ty + = ASSERT( isMaybeTyBinder sty ) sty + where + sty = splitPiTy_maybe ty + isMaybeTyBinder (Just (t,_)) = isTyBinder t + isMaybeTyBinder _ = True + +tcSplitForAllTy_maybe :: Type -> Maybe (TyVarBinder, Type) +tcSplitForAllTy_maybe ty | Just ty' <- tcView ty = tcSplitForAllTy_maybe ty' +tcSplitForAllTy_maybe (ForAllTy tv ty) = ASSERT( isTyVarBinder tv ) Just (tv, ty) +tcSplitForAllTy_maybe _ = Nothing + +-- | Like 'tcSplitPiTys', but splits off only named binders, +-- returning just the tycovars. +tcSplitForAllTys :: Type -> ([TyVar], Type) +tcSplitForAllTys ty + = ASSERT( all isTyVar (fst sty) ) sty + where sty = splitForAllTys ty + +-- | Like 'tcSplitForAllTys', but only splits a 'ForAllTy' if +-- @'sameVis' argf supplied_argf@ is 'True', where @argf@ is the visibility +-- of the @ForAllTy@'s binder and @supplied_argf@ is the visibility provided +-- as an argument to this function. +tcSplitForAllTysSameVis :: ArgFlag -> Type -> ([TyVar], Type) +tcSplitForAllTysSameVis supplied_argf ty = ASSERT( all isTyVar (fst sty) ) sty + where sty = splitForAllTysSameVis supplied_argf ty + +-- | Like 'tcSplitForAllTys', but splits off only named binders. +tcSplitForAllVarBndrs :: Type -> ([TyVarBinder], Type) +tcSplitForAllVarBndrs ty = ASSERT( all isTyVarBinder (fst sty)) sty + where sty = splitForAllVarBndrs ty + +-- | Is this a ForAllTy with a named binder? +tcIsForAllTy :: Type -> Bool +tcIsForAllTy ty | Just ty' <- tcView ty = tcIsForAllTy ty' +tcIsForAllTy (ForAllTy {}) = True +tcIsForAllTy _ = False + +tcSplitPredFunTy_maybe :: Type -> Maybe (PredType, Type) +-- Split off the first predicate argument from a type +tcSplitPredFunTy_maybe ty + | Just ty' <- tcView ty = tcSplitPredFunTy_maybe ty' +tcSplitPredFunTy_maybe (FunTy { ft_af = InvisArg + , ft_arg = arg, ft_res = res }) + = Just (arg, res) +tcSplitPredFunTy_maybe _ + = Nothing + +tcSplitPhiTy :: Type -> (ThetaType, Type) +tcSplitPhiTy ty + = split ty [] + where + split ty ts + = case tcSplitPredFunTy_maybe ty of + Just (pred, ty) -> split ty (pred:ts) + Nothing -> (reverse ts, ty) + +-- | Split a sigma type into its parts. +tcSplitSigmaTy :: Type -> ([TyVar], ThetaType, Type) +tcSplitSigmaTy ty = case tcSplitForAllTys ty of + (tvs, rho) -> case tcSplitPhiTy rho of + (theta, tau) -> (tvs, theta, tau) + +-- | Split a sigma type into its parts, going underneath as many @ForAllTy@s +-- as possible. For example, given this type synonym: +-- +-- @ +-- type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t +-- @ +-- +-- if you called @tcSplitSigmaTy@ on this type: +-- +-- @ +-- forall s t a b. Each s t a b => Traversal s t a b +-- @ +-- +-- then it would return @([s,t,a,b], [Each s t a b], Traversal s t a b)@. But +-- if you instead called @tcSplitNestedSigmaTys@ on the type, it would return +-- @([s,t,a,b,f], [Each s t a b, Applicative f], (a -> f b) -> s -> f t)@. +tcSplitNestedSigmaTys :: Type -> ([TyVar], ThetaType, Type) +-- NB: This is basically a pure version of deeplyInstantiate (from Inst) that +-- doesn't compute an HsWrapper. +tcSplitNestedSigmaTys ty + -- If there's a forall, split it apart and try splitting the rho type + -- underneath it. + | Just (arg_tys, tvs1, theta1, rho1) <- tcDeepSplitSigmaTy_maybe ty + = let (tvs2, theta2, rho2) = tcSplitNestedSigmaTys rho1 + in (tvs1 ++ tvs2, theta1 ++ theta2, mkVisFunTys arg_tys rho2) + -- If there's no forall, we're done. + | otherwise = ([], [], ty) + +----------------------- +tcDeepSplitSigmaTy_maybe + :: TcSigmaType -> Maybe ([TcType], [TyVar], ThetaType, TcSigmaType) +-- Looks for a *non-trivial* quantified type, under zero or more function arrows +-- By "non-trivial" we mean either tyvars or constraints are non-empty + +tcDeepSplitSigmaTy_maybe ty + | Just (arg_ty, res_ty) <- tcSplitFunTy_maybe ty + , Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe res_ty + = Just (arg_ty:arg_tys, tvs, theta, rho) + + | (tvs, theta, rho) <- tcSplitSigmaTy ty + , not (null tvs && null theta) + = Just ([], tvs, theta, rho) + + | otherwise = Nothing + +----------------------- +tcTyConAppTyCon :: Type -> TyCon +tcTyConAppTyCon ty + = case tcTyConAppTyCon_maybe ty of + Just tc -> tc + Nothing -> pprPanic "tcTyConAppTyCon" (pprType ty) + +-- | Like 'tcRepSplitTyConApp_maybe', but only returns the 'TyCon'. +tcTyConAppTyCon_maybe :: Type -> Maybe TyCon +tcTyConAppTyCon_maybe ty + | Just ty' <- tcView ty = tcTyConAppTyCon_maybe ty' +tcTyConAppTyCon_maybe (TyConApp tc _) + = Just tc +tcTyConAppTyCon_maybe (FunTy { ft_af = VisArg }) + = Just funTyCon -- (=>) is /not/ a TyCon in its own right + -- C.f. tcRepSplitAppTy_maybe +tcTyConAppTyCon_maybe _ + = Nothing + +tcTyConAppArgs :: Type -> [Type] +tcTyConAppArgs ty = case tcSplitTyConApp_maybe ty of + Just (_, args) -> args + Nothing -> pprPanic "tcTyConAppArgs" (pprType ty) + +tcSplitTyConApp :: Type -> (TyCon, [Type]) +tcSplitTyConApp ty = case tcSplitTyConApp_maybe ty of + Just stuff -> stuff + Nothing -> pprPanic "tcSplitTyConApp" (pprType ty) + +----------------------- +tcSplitFunTys :: Type -> ([Type], Type) +tcSplitFunTys ty = case tcSplitFunTy_maybe ty of + Nothing -> ([], ty) + Just (arg,res) -> (arg:args, res') + where + (args,res') = tcSplitFunTys res + +tcSplitFunTy_maybe :: Type -> Maybe (Type, Type) +tcSplitFunTy_maybe ty + | Just ty' <- tcView ty = tcSplitFunTy_maybe ty' +tcSplitFunTy_maybe (FunTy { ft_af = af, ft_arg = arg, ft_res = res }) + | VisArg <- af = Just (arg, res) +tcSplitFunTy_maybe _ = Nothing + -- Note the VisArg guard + -- Consider (?x::Int) => Bool + -- We don't want to treat this as a function type! + -- A concrete example is test tc230: + -- f :: () -> (?p :: ()) => () -> () + -- + -- g = f () () + +tcSplitFunTysN :: Arity -- n: Number of desired args + -> TcRhoType + -> Either Arity -- Number of missing arrows + ([TcSigmaType], -- Arg types (always N types) + TcSigmaType) -- The rest of the type +-- ^ Split off exactly the specified number argument types +-- Returns +-- (Left m) if there are 'm' missing arrows in the type +-- (Right (tys,res)) if the type looks like t1 -> ... -> tn -> res +tcSplitFunTysN n ty + | n == 0 + = Right ([], ty) + | Just (arg,res) <- tcSplitFunTy_maybe ty + = case tcSplitFunTysN (n-1) res of + Left m -> Left m + Right (args,body) -> Right (arg:args, body) + | otherwise + = Left n + +tcSplitFunTy :: Type -> (Type, Type) +tcSplitFunTy ty = expectJust "tcSplitFunTy" (tcSplitFunTy_maybe ty) + +tcFunArgTy :: Type -> Type +tcFunArgTy ty = fst (tcSplitFunTy ty) + +tcFunResultTy :: Type -> Type +tcFunResultTy ty = snd (tcSplitFunTy ty) + +-- | Strips off n *visible* arguments and returns the resulting type +tcFunResultTyN :: HasDebugCallStack => Arity -> Type -> Type +tcFunResultTyN n ty + | Right (_, res_ty) <- tcSplitFunTysN n ty + = res_ty + | otherwise + = pprPanic "tcFunResultTyN" (ppr n <+> ppr ty) + +----------------------- +tcSplitAppTy_maybe :: Type -> Maybe (Type, Type) +tcSplitAppTy_maybe ty | Just ty' <- tcView ty = tcSplitAppTy_maybe ty' +tcSplitAppTy_maybe ty = tcRepSplitAppTy_maybe ty + +tcSplitAppTy :: Type -> (Type, Type) +tcSplitAppTy ty = case tcSplitAppTy_maybe ty of + Just stuff -> stuff + Nothing -> pprPanic "tcSplitAppTy" (pprType ty) + +tcSplitAppTys :: Type -> (Type, [Type]) +tcSplitAppTys ty + = go ty [] + where + go ty args = case tcSplitAppTy_maybe ty of + Just (ty', arg) -> go ty' (arg:args) + Nothing -> (ty,args) + +-- | Returns the number of arguments in the given type, without +-- looking through synonyms. This is used only for error reporting. +-- We don't look through synonyms because of #11313. +tcRepGetNumAppTys :: Type -> Arity +tcRepGetNumAppTys = length . snd . repSplitAppTys + +----------------------- +-- | If the type is a tyvar, possibly under a cast, returns it, along +-- with the coercion. Thus, the co is :: kind tv ~N kind type +tcGetCastedTyVar_maybe :: Type -> Maybe (TyVar, CoercionN) +tcGetCastedTyVar_maybe ty | Just ty' <- tcView ty = tcGetCastedTyVar_maybe ty' +tcGetCastedTyVar_maybe (CastTy (TyVarTy tv) co) = Just (tv, co) +tcGetCastedTyVar_maybe (TyVarTy tv) = Just (tv, mkNomReflCo (tyVarKind tv)) +tcGetCastedTyVar_maybe _ = Nothing + +tcGetTyVar_maybe :: Type -> Maybe TyVar +tcGetTyVar_maybe ty | Just ty' <- tcView ty = tcGetTyVar_maybe ty' +tcGetTyVar_maybe (TyVarTy tv) = Just tv +tcGetTyVar_maybe _ = Nothing + +tcGetTyVar :: String -> Type -> TyVar +tcGetTyVar msg ty + = case tcGetTyVar_maybe ty of + Just tv -> tv + Nothing -> pprPanic msg (ppr ty) + +tcIsTyVarTy :: Type -> Bool +tcIsTyVarTy ty | Just ty' <- tcView ty = tcIsTyVarTy ty' +tcIsTyVarTy (CastTy ty _) = tcIsTyVarTy ty -- look through casts, as + -- this is only used for + -- e.g., FlexibleContexts +tcIsTyVarTy (TyVarTy _) = True +tcIsTyVarTy _ = False + +----------------------- +tcSplitDFunTy :: Type -> ([TyVar], [Type], Class, [Type]) +-- Split the type of a dictionary function +-- We don't use tcSplitSigmaTy, because a DFun may (with NDP) +-- have non-Pred arguments, such as +-- df :: forall m. (forall b. Eq b => Eq (m b)) -> C m +-- +-- Also NB splitFunTys, not tcSplitFunTys; +-- the latter specifically stops at PredTy arguments, +-- and we don't want to do that here +tcSplitDFunTy ty + = case tcSplitForAllTys ty of { (tvs, rho) -> + case splitFunTys rho of { (theta, tau) -> + case tcSplitDFunHead tau of { (clas, tys) -> + (tvs, theta, clas, tys) }}} + +tcSplitDFunHead :: Type -> (Class, [Type]) +tcSplitDFunHead = getClassPredTys + +tcSplitMethodTy :: Type -> ([TyVar], PredType, Type) +-- A class method (selector) always has a type like +-- forall as. C as => blah +-- So if the class looks like +-- class C a where +-- op :: forall b. (Eq a, Ix b) => a -> b +-- the class method type looks like +-- op :: forall a. C a => forall b. (Eq a, Ix b) => a -> b +-- +-- tcSplitMethodTy just peels off the outer forall and +-- that first predicate +tcSplitMethodTy ty + | (sel_tyvars,sel_rho) <- tcSplitForAllTys ty + , Just (first_pred, local_meth_ty) <- tcSplitPredFunTy_maybe sel_rho + = (sel_tyvars, first_pred, local_meth_ty) + | otherwise + = pprPanic "tcSplitMethodTy" (ppr ty) + + +{- ********************************************************************* +* * + Type equalities +* * +********************************************************************* -} + +tcEqKind :: HasDebugCallStack => TcKind -> TcKind -> Bool +tcEqKind = tcEqType + +tcEqType :: HasDebugCallStack => TcType -> TcType -> Bool +-- tcEqType is a proper implements the same Note [Non-trivial definitional +-- equality] (in TyCoRep) as `eqType`, but Type.eqType believes (* == +-- Constraint), and that is NOT what we want in the type checker! +tcEqType ty1 ty2 + = tc_eq_type False False ki1 ki2 + && tc_eq_type False False ty1 ty2 + where + ki1 = tcTypeKind ty1 + ki2 = tcTypeKind ty2 + +-- | Just like 'tcEqType', but will return True for types of different kinds +-- as long as their non-coercion structure is identical. +tcEqTypeNoKindCheck :: TcType -> TcType -> Bool +tcEqTypeNoKindCheck ty1 ty2 + = tc_eq_type False False ty1 ty2 + +-- | Like 'tcEqType', but returns True if the /visible/ part of the types +-- are equal, even if they are really unequal (in the invisible bits) +tcEqTypeVis :: TcType -> TcType -> Bool +tcEqTypeVis ty1 ty2 = tc_eq_type False True ty1 ty2 + +-- | Like 'pickyEqTypeVis', but returns a Bool for convenience +pickyEqType :: TcType -> TcType -> Bool +-- Check when two types _look_ the same, _including_ synonyms. +-- So (pickyEqType String [Char]) returns False +-- This ignores kinds and coercions, because this is used only for printing. +pickyEqType ty1 ty2 = tc_eq_type True False ty1 ty2 + + + +-- | Real worker for 'tcEqType'. No kind check! +tc_eq_type :: Bool -- ^ True <=> do not expand type synonyms + -> Bool -- ^ True <=> compare visible args only + -> Type -> Type + -> Bool +-- Flags False, False is the usual setting for tc_eq_type +tc_eq_type keep_syns vis_only orig_ty1 orig_ty2 + = go orig_env orig_ty1 orig_ty2 + where + go :: RnEnv2 -> Type -> Type -> Bool + go env t1 t2 | not keep_syns, Just t1' <- tcView t1 = go env t1' t2 + go env t1 t2 | not keep_syns, Just t2' <- tcView t2 = go env t1 t2' + + go env (TyVarTy tv1) (TyVarTy tv2) + = rnOccL env tv1 == rnOccR env tv2 + + go _ (LitTy lit1) (LitTy lit2) + = lit1 == lit2 + + go env (ForAllTy (Bndr tv1 vis1) ty1) + (ForAllTy (Bndr tv2 vis2) ty2) + = vis1 == vis2 + && (vis_only || go env (varType tv1) (varType tv2)) + && go (rnBndr2 env tv1 tv2) ty1 ty2 + + -- Make sure we handle all FunTy cases since falling through to the + -- AppTy case means that tcRepSplitAppTy_maybe may see an unzonked + -- kind variable, which causes things to blow up. + go env (FunTy _ arg1 res1) (FunTy _ arg2 res2) + = go env arg1 arg2 && go env res1 res2 + go env ty (FunTy _ arg res) = eqFunTy env arg res ty + go env (FunTy _ arg res) ty = eqFunTy env arg res ty + + -- See Note [Equality on AppTys] in Type + go env (AppTy s1 t1) ty2 + | Just (s2, t2) <- tcRepSplitAppTy_maybe ty2 + = go env s1 s2 && go env t1 t2 + go env ty1 (AppTy s2 t2) + | Just (s1, t1) <- tcRepSplitAppTy_maybe ty1 + = go env s1 s2 && go env t1 t2 + + go env (TyConApp tc1 ts1) (TyConApp tc2 ts2) + = tc1 == tc2 && gos env (tc_vis tc1) ts1 ts2 + + go env (CastTy t1 _) t2 = go env t1 t2 + go env t1 (CastTy t2 _) = go env t1 t2 + go _ (CoercionTy {}) (CoercionTy {}) = True + + go _ _ _ = False + + gos _ _ [] [] = True + gos env (ig:igs) (t1:ts1) (t2:ts2) = (ig || go env t1 t2) + && gos env igs ts1 ts2 + gos _ _ _ _ = False + + tc_vis :: TyCon -> [Bool] -- True for the fields we should ignore + tc_vis tc | vis_only = inviss ++ repeat False -- Ignore invisibles + | otherwise = repeat False -- Ignore nothing + -- The repeat False is necessary because tycons + -- can legitimately be oversaturated + where + bndrs = tyConBinders tc + inviss = map isInvisibleTyConBinder bndrs + + orig_env = mkRnEnv2 $ mkInScopeSet $ tyCoVarsOfTypes [orig_ty1, orig_ty2] + + -- @eqFunTy arg res ty@ is True when @ty@ equals @FunTy arg res@. This is + -- sometimes hard to know directly because @ty@ might have some casts + -- obscuring the FunTy. And 'splitAppTy' is difficult because we can't + -- always extract a RuntimeRep (see Note [xyz]) if the kind of the arg or + -- res is unzonked/unflattened. Thus this function, which handles this + -- corner case. + eqFunTy :: RnEnv2 -> Type -> Type -> Type -> Bool + -- Last arg is /not/ FunTy + eqFunTy env arg res ty@(AppTy{}) = get_args ty [] + where + get_args :: Type -> [Type] -> Bool + get_args (AppTy f x) args = get_args f (x:args) + get_args (CastTy t _) args = get_args t args + get_args (TyConApp tc tys) args + | tc == funTyCon + , [_, _, arg', res'] <- tys ++ args + = go env arg arg' && go env res res' + get_args _ _ = False + eqFunTy _ _ _ _ = False + +{- ********************************************************************* +* * + Predicate types +* * +************************************************************************ + +Deconstructors and tests on predicate types + +Note [Kind polymorphic type classes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + class C f where... -- C :: forall k. k -> Constraint + g :: forall (f::*). C f => f -> f + +Here the (C f) in the signature is really (C * f), and we +don't want to complain that the * isn't a type variable! +-} + +isTyVarClassPred :: PredType -> Bool +isTyVarClassPred ty = case getClassPredTys_maybe ty of + Just (_, tys) -> all isTyVarTy tys + _ -> False + +------------------------- +checkValidClsArgs :: Bool -> Class -> [KindOrType] -> Bool +-- If the Bool is True (flexible contexts), return True (i.e. ok) +-- Otherwise, check that the type (not kind) args are all headed by a tyvar +-- E.g. (Eq a) accepted, (Eq (f a)) accepted, but (Eq Int) rejected +-- This function is here rather than in TcValidity because it is +-- called from TcSimplify, which itself is imported by TcValidity +checkValidClsArgs flexible_contexts cls kts + | flexible_contexts = True + | otherwise = all hasTyVarHead tys + where + tys = filterOutInvisibleTypes (classTyCon cls) kts + +hasTyVarHead :: Type -> Bool +-- Returns true of (a t1 .. tn), where 'a' is a type variable +hasTyVarHead ty -- Haskell 98 allows predicates of form + | tcIsTyVarTy ty = True -- C (a ty1 .. tyn) + | otherwise -- where a is a type variable + = case tcSplitAppTy_maybe ty of + Just (ty, _) -> hasTyVarHead ty + Nothing -> False + +evVarPred :: EvVar -> PredType +evVarPred var + = ASSERT2( isEvVarType var_ty, ppr var <+> dcolon <+> ppr var_ty ) + var_ty + where + var_ty = varType var + +------------------ +-- | When inferring types, should we quantify over a given predicate? +-- Generally true of classes; generally false of equality constraints. +-- Equality constraints that mention quantified type variables and +-- implicit variables complicate the story. See Notes +-- [Inheriting implicit parameters] and [Quantifying over equality constraints] +pickQuantifiablePreds + :: TyVarSet -- Quantifying over these + -> TcThetaType -- Proposed constraints to quantify + -> TcThetaType -- A subset that we can actually quantify +-- This function decides whether a particular constraint should be +-- quantified over, given the type variables that are being quantified +pickQuantifiablePreds qtvs theta + = let flex_ctxt = True in -- Quantify over non-tyvar constraints, even without + -- -XFlexibleContexts: see #10608, #10351 + -- flex_ctxt <- xoptM Opt_FlexibleContexts + mapMaybe (pick_me flex_ctxt) theta + where + pick_me flex_ctxt pred + = case classifyPredType pred of + + ClassPred cls tys + | Just {} <- isCallStackPred cls tys + -- NEVER infer a CallStack constraint. Otherwise we let + -- the constraints bubble up to be solved from the outer + -- context, or be defaulted when we reach the top-level. + -- See Note [Overview of implicit CallStacks] + -> Nothing + + | isIPClass cls + -> Just pred -- See note [Inheriting implicit parameters] + + | pick_cls_pred flex_ctxt cls tys + -> Just pred + + EqPred eq_rel ty1 ty2 + | quantify_equality eq_rel ty1 ty2 + , Just (cls, tys) <- boxEqPred eq_rel ty1 ty2 + -- boxEqPred: See Note [Lift equality constaints when quantifying] + , pick_cls_pred flex_ctxt cls tys + -> Just (mkClassPred cls tys) + + IrredPred ty + | tyCoVarsOfType ty `intersectsVarSet` qtvs + -> Just pred + + _ -> Nothing + + + pick_cls_pred flex_ctxt cls tys + = tyCoVarsOfTypes tys `intersectsVarSet` qtvs + && (checkValidClsArgs flex_ctxt cls tys) + -- Only quantify over predicates that checkValidType + -- will pass! See #10351. + + -- See Note [Quantifying over equality constraints] + quantify_equality NomEq ty1 ty2 = quant_fun ty1 || quant_fun ty2 + quantify_equality ReprEq _ _ = True + + quant_fun ty + = case tcSplitTyConApp_maybe ty of + Just (tc, tys) | isTypeFamilyTyCon tc + -> tyCoVarsOfTypes tys `intersectsVarSet` qtvs + _ -> False + +boxEqPred :: EqRel -> Type -> Type -> Maybe (Class, [Type]) +-- Given (t1 ~# t2) or (t1 ~R# t2) return the boxed version +-- (t1 ~ t2) or (t1 `Coercible` t2) +boxEqPred eq_rel ty1 ty2 + = case eq_rel of + NomEq | homo_kind -> Just (eqClass, [k1, ty1, ty2]) + | otherwise -> Just (heqClass, [k1, k2, ty1, ty2]) + ReprEq | homo_kind -> Just (coercibleClass, [k1, ty1, ty2]) + | otherwise -> Nothing -- Sigh: we do not have hererogeneous Coercible + -- so we can't abstract over it + -- Nothing fundamental: we could add it + where + k1 = tcTypeKind ty1 + k2 = tcTypeKind ty2 + homo_kind = k1 `tcEqType` k2 + +pickCapturedPreds + :: TyVarSet -- Quantifying over these + -> TcThetaType -- Proposed constraints to quantify + -> TcThetaType -- A subset that we can actually quantify +-- A simpler version of pickQuantifiablePreds, used to winnow down +-- the inferred constraints of a group of bindings, into those for +-- one particular identifier +pickCapturedPreds qtvs theta + = filter captured theta + where + captured pred = isIPPred pred || (tyCoVarsOfType pred `intersectsVarSet` qtvs) + + +-- Superclasses + +type PredWithSCs a = (PredType, [PredType], a) + +mkMinimalBySCs :: forall a. (a -> PredType) -> [a] -> [a] +-- Remove predicates that +-- +-- - are the same as another predicate +-- +-- - can be deduced from another by superclasses, +-- +-- - are a reflexive equality (e.g * ~ *) +-- (see Note [Remove redundant provided dicts] in TcPatSyn) +-- +-- The result is a subset of the input. +-- The 'a' is just paired up with the PredType; +-- typically it might be a dictionary Id +mkMinimalBySCs get_pred xs = go preds_with_scs [] + where + preds_with_scs :: [PredWithSCs a] + preds_with_scs = [ (pred, pred : transSuperClasses pred, x) + | x <- xs + , let pred = get_pred x ] + + go :: [PredWithSCs a] -- Work list + -> [PredWithSCs a] -- Accumulating result + -> [a] + go [] min_preds + = reverse (map thdOf3 min_preds) + -- The 'reverse' isn't strictly necessary, but it + -- means that the results are returned in the same + -- order as the input, which is generally saner + go (work_item@(p,_,_) : work_list) min_preds + | EqPred _ t1 t2 <- classifyPredType p + , t1 `tcEqType` t2 -- See TcPatSyn + -- Note [Remove redundant provided dicts] + = go work_list min_preds + | p `in_cloud` work_list || p `in_cloud` min_preds + = go work_list min_preds + | otherwise + = go work_list (work_item : min_preds) + + in_cloud :: PredType -> [PredWithSCs a] -> Bool + in_cloud p ps = or [ p `tcEqType` p' | (_, scs, _) <- ps, p' <- scs ] + +transSuperClasses :: PredType -> [PredType] +-- (transSuperClasses p) returns (p's superclasses) not including p +-- Stop if you encounter the same class again +-- See Note [Expanding superclasses] +transSuperClasses p + = go emptyNameSet p + where + go :: NameSet -> PredType -> [PredType] + go rec_clss p + | ClassPred cls tys <- classifyPredType p + , let cls_nm = className cls + , not (cls_nm `elemNameSet` rec_clss) + , let rec_clss' | isCTupleClass cls = rec_clss + | otherwise = rec_clss `extendNameSet` cls_nm + = [ p' | sc <- immSuperClasses cls tys + , p' <- sc : go rec_clss' sc ] + | otherwise + = [] + +immSuperClasses :: Class -> [Type] -> [PredType] +immSuperClasses cls tys + = substTheta (zipTvSubst tyvars tys) sc_theta + where + (tyvars,sc_theta,_,_) = classBigSig cls + +isImprovementPred :: PredType -> Bool +-- Either it's an equality, or has some functional dependency +isImprovementPred ty + = case classifyPredType ty of + EqPred NomEq t1 t2 -> not (t1 `tcEqType` t2) + EqPred ReprEq _ _ -> False + ClassPred cls _ -> classHasFds cls + IrredPred {} -> True -- Might have equalities after reduction? + ForAllPred {} -> False + +-- | Is the equality +-- a ~r ...a.... +-- definitely insoluble or not? +-- a ~r Maybe a -- Definitely insoluble +-- a ~N ...(F a)... -- Not definitely insoluble +-- -- Perhaps (F a) reduces to Int +-- a ~R ...(N a)... -- Not definitely insoluble +-- -- Perhaps newtype N a = MkN Int +-- See Note [Occurs check error] in +-- TcCanonical for the motivation for this function. +isInsolubleOccursCheck :: EqRel -> TcTyVar -> TcType -> Bool +isInsolubleOccursCheck eq_rel tv ty + = go ty + where + go ty | Just ty' <- tcView ty = go ty' + go (TyVarTy tv') = tv == tv' || go (tyVarKind tv') + go (LitTy {}) = False + go (AppTy t1 t2) = case eq_rel of -- See Note [AppTy and ReprEq] + NomEq -> go t1 || go t2 + ReprEq -> go t1 + go (FunTy _ t1 t2) = go t1 || go t2 + go (ForAllTy (Bndr tv' _) inner_ty) + | tv' == tv = False + | otherwise = go (varType tv') || go inner_ty + go (CastTy ty _) = go ty -- ToDo: what about the coercion + go (CoercionTy _) = False -- ToDo: what about the coercion + go (TyConApp tc tys) + | isGenerativeTyCon tc role = any go tys + | otherwise = any go (drop (tyConArity tc) tys) + -- (a ~ F b a), where F has arity 1, + -- has an insoluble occurs check + + role = eqRelRole eq_rel + +{- Note [Expanding superclasses] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we expand superclasses, we use the following algorithm: + +transSuperClasses( C tys ) returns the transitive superclasses + of (C tys), not including C itself + +For example + class C a b => D a b + class D b a => C a b + +Then + transSuperClasses( Ord ty ) = [Eq ty] + transSuperClasses( C ta tb ) = [D tb ta, C tb ta] + +Notice that in the recursive-superclass case we include C again at +the end of the chain. One could exclude C in this case, but +the code is more awkward and there seems no good reason to do so. +(However C.f. TcCanonical.mk_strict_superclasses, which /does/ +appear to do so.) + +The algorithm is expand( so_far, pred ): + + 1. If pred is not a class constraint, return empty set + Otherwise pred = C ts + 2. If C is in so_far, return empty set (breaks loops) + 3. Find the immediate superclasses constraints of (C ts) + 4. For each such sc_pred, return (sc_pred : expand( so_far+C, D ss ) + +Notice that + + * With normal Haskell-98 classes, the loop-detector will never bite, + so we'll get all the superclasses. + + * We need the loop-breaker in case we have UndecidableSuperClasses on + + * Since there is only a finite number of distinct classes, expansion + must terminate. + + * The loop breaking is a bit conservative. Notably, a tuple class + could contain many times without threatening termination: + (Eq a, (Ord a, Ix a)) + And this is try of any class that we can statically guarantee + as non-recursive (in some sense). For now, we just make a special + case for tuples. Something better would be cool. + +See also TcTyDecls.checkClassCycles. + +Note [Lift equality constaints when quantifying] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We can't quantify over a constraint (t1 ~# t2) because that isn't a +predicate type; see Note [Types for coercions, predicates, and evidence] +in Type.hs. + +So we have to 'lift' it to (t1 ~ t2). Similarly (~R#) must be lifted +to Coercible. + +This tiresome lifting is the reason that pick_me (in +pickQuantifiablePreds) returns a Maybe rather than a Bool. + +Note [Quantifying over equality constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Should we quantify over an equality constraint (s ~ t)? In general, we don't. +Doing so may simply postpone a type error from the function definition site to +its call site. (At worst, imagine (Int ~ Bool)). + +However, consider this + forall a. (F [a] ~ Int) => blah +Should we quantify over the (F [a] ~ Int)? Perhaps yes, because at the call +site we will know 'a', and perhaps we have instance F [Bool] = Int. +So we *do* quantify over a type-family equality where the arguments mention +the quantified variables. + +Note [Inheriting implicit parameters] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + + f x = (x::Int) + ?y + +where f is *not* a top-level binding. +From the RHS of f we'll get the constraint (?y::Int). +There are two types we might infer for f: + + f :: Int -> Int + +(so we get ?y from the context of f's definition), or + + f :: (?y::Int) => Int -> Int + +At first you might think the first was better, because then +?y behaves like a free variable of the definition, rather than +having to be passed at each call site. But of course, the WHOLE +IDEA is that ?y should be passed at each call site (that's what +dynamic binding means) so we'd better infer the second. + +BOTTOM LINE: when *inferring types* you must quantify over implicit +parameters, *even if* they don't mention the bound type variables. +Reason: because implicit parameters, uniquely, have local instance +declarations. See pickQuantifiablePreds. + +Note [Quantifying over equality constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Should we quantify over an equality constraint (s ~ t)? In general, we don't. +Doing so may simply postpone a type error from the function definition site to +its call site. (At worst, imagine (Int ~ Bool)). + +However, consider this + forall a. (F [a] ~ Int) => blah +Should we quantify over the (F [a] ~ Int). Perhaps yes, because at the call +site we will know 'a', and perhaps we have instance F [Bool] = Int. +So we *do* quantify over a type-family equality where the arguments mention +the quantified variables. + +************************************************************************ +* * + Classifying types +* * +************************************************************************ +-} + +isSigmaTy :: TcType -> Bool +-- isSigmaTy returns true of any qualified type. It doesn't +-- *necessarily* have any foralls. E.g +-- f :: (?x::Int) => Int -> Int +isSigmaTy ty | Just ty' <- tcView ty = isSigmaTy ty' +isSigmaTy (ForAllTy {}) = True +isSigmaTy (FunTy { ft_af = InvisArg }) = True +isSigmaTy _ = False + +isRhoTy :: TcType -> Bool -- True of TcRhoTypes; see Note [TcRhoType] +isRhoTy ty | Just ty' <- tcView ty = isRhoTy ty' +isRhoTy (ForAllTy {}) = False +isRhoTy (FunTy { ft_af = VisArg, ft_res = r }) = isRhoTy r +isRhoTy _ = True + +-- | Like 'isRhoTy', but also says 'True' for 'Infer' types +isRhoExpTy :: ExpType -> Bool +isRhoExpTy (Check ty) = isRhoTy ty +isRhoExpTy (Infer {}) = True + +isOverloadedTy :: Type -> Bool +-- Yes for a type of a function that might require evidence-passing +-- Used only by bindLocalMethods +isOverloadedTy ty | Just ty' <- tcView ty = isOverloadedTy ty' +isOverloadedTy (ForAllTy _ ty) = isOverloadedTy ty +isOverloadedTy (FunTy { ft_af = InvisArg }) = True +isOverloadedTy _ = False + +isFloatTy, isDoubleTy, isIntegerTy, isIntTy, isWordTy, isBoolTy, + isUnitTy, isCharTy, isAnyTy :: Type -> Bool +isFloatTy = is_tc floatTyConKey +isDoubleTy = is_tc doubleTyConKey +isIntegerTy = is_tc integerTyConKey +isIntTy = is_tc intTyConKey +isWordTy = is_tc wordTyConKey +isBoolTy = is_tc boolTyConKey +isUnitTy = is_tc unitTyConKey +isCharTy = is_tc charTyConKey +isAnyTy = is_tc anyTyConKey + +-- | Does a type represent a floating-point number? +isFloatingTy :: Type -> Bool +isFloatingTy ty = isFloatTy ty || isDoubleTy ty + +-- | Is a type 'String'? +isStringTy :: Type -> Bool +isStringTy ty + = case tcSplitTyConApp_maybe ty of + Just (tc, [arg_ty]) -> tc == listTyCon && isCharTy arg_ty + _ -> False + +-- | Is a type a 'CallStack'? +isCallStackTy :: Type -> Bool +isCallStackTy ty + | Just tc <- tyConAppTyCon_maybe ty + = tc `hasKey` callStackTyConKey + | otherwise + = False + +-- | Is a 'PredType' a 'CallStack' implicit parameter? +-- +-- If so, return the name of the parameter. +isCallStackPred :: Class -> [Type] -> Maybe FastString +isCallStackPred cls tys + | [ty1, ty2] <- tys + , isIPClass cls + , isCallStackTy ty2 + = isStrLitTy ty1 + | otherwise + = Nothing + +hasIPPred :: PredType -> Bool +hasIPPred pred + = case classifyPredType pred of + ClassPred cls tys + | isIPClass cls -> True + | isCTupleClass cls -> any hasIPPred tys + _other -> False + +is_tc :: Unique -> Type -> Bool +-- Newtypes are opaque to this +is_tc uniq ty = case tcSplitTyConApp_maybe ty of + Just (tc, _) -> uniq == getUnique tc + Nothing -> False + +-- | Does the given tyvar appear at the head of a chain of applications +-- (a t1 ... tn) +isTyVarHead :: TcTyVar -> TcType -> Bool +isTyVarHead tv (TyVarTy tv') = tv == tv' +isTyVarHead tv (AppTy fun _) = isTyVarHead tv fun +isTyVarHead tv (CastTy ty _) = isTyVarHead tv ty +isTyVarHead _ (TyConApp {}) = False +isTyVarHead _ (LitTy {}) = False +isTyVarHead _ (ForAllTy {}) = False +isTyVarHead _ (FunTy {}) = False +isTyVarHead _ (CoercionTy {}) = False + + +{- Note [AppTy and ReprEq] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider a ~R# b a + a ~R# a b + +The former is /not/ a definite error; we might instantiate 'b' with Id + newtype Id a = MkId a +but the latter /is/ a definite error. + +On the other hand, with nominal equality, both are definite errors +-} + +isRigidTy :: TcType -> Bool +isRigidTy ty + | Just (tc,_) <- tcSplitTyConApp_maybe ty = isGenerativeTyCon tc Nominal + | Just {} <- tcSplitAppTy_maybe ty = True + | isForAllTy ty = True + | otherwise = False + + +{- +************************************************************************ +* * +\subsection{Misc} +* * +************************************************************************ + +Note [Visible type application] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +GHC implements a generalisation of the algorithm described in the +"Visible Type Application" paper (available from +http://www.cis.upenn.edu/~sweirich/publications.html). A key part +of that algorithm is to distinguish user-specified variables from inferred +variables. For example, the following should typecheck: + + f :: forall a b. a -> b -> b + f = const id + + g = const id + + x = f @Int @Bool 5 False + y = g 5 @Bool False + +The idea is that we wish to allow visible type application when we are +instantiating a specified, fixed variable. In practice, specified, fixed +variables are either written in a type signature (or +annotation), OR are imported from another module. (We could do better here, +for example by doing SCC analysis on parts of a module and considering any +type from outside one's SCC to be fully specified, but this is very confusing to +users. The simple rule above is much more straightforward and predictable.) + +So, both of f's quantified variables are specified and may be instantiated. +But g has no type signature, so only id's variable is specified (because id +is imported). We write the type of g as forall {a}. a -> forall b. b -> b. +Note that the a is in braces, meaning it cannot be instantiated with +visible type application. + +Tracking specified vs. inferred variables is done conveniently by a field +in TyBinder. + +-} + +deNoteType :: Type -> Type +-- Remove all *outermost* type synonyms and other notes +deNoteType ty | Just ty' <- coreView ty = deNoteType ty' +deNoteType ty = ty + +{- +Find the free tycons and classes of a type. This is used in the front +end of the compiler. +-} + +{- +************************************************************************ +* * +\subsection[TysWiredIn-ext-type]{External types} +* * +************************************************************************ + +The compiler's foreign function interface supports the passing of a +restricted set of types as arguments and results (the restricting factor +being the ) +-} + +tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type) +-- (tcSplitIOType_maybe t) returns Just (IO,t',co) +-- if co : t ~ IO t' +-- returns Nothing otherwise +tcSplitIOType_maybe ty + = case tcSplitTyConApp_maybe ty of + Just (io_tycon, [io_res_ty]) + | io_tycon `hasKey` ioTyConKey -> + Just (io_tycon, io_res_ty) + _ -> + Nothing + +isFFITy :: Type -> Bool +-- True for any TyCon that can possibly be an arg or result of an FFI call +isFFITy ty = isValid (checkRepTyCon legalFFITyCon ty) + +isFFIArgumentTy :: DynFlags -> Safety -> Type -> Validity +-- Checks for valid argument type for a 'foreign import' +isFFIArgumentTy dflags safety ty + = checkRepTyCon (legalOutgoingTyCon dflags safety) ty + +isFFIExternalTy :: Type -> Validity +-- Types that are allowed as arguments of a 'foreign export' +isFFIExternalTy ty = checkRepTyCon legalFEArgTyCon ty + +isFFIImportResultTy :: DynFlags -> Type -> Validity +isFFIImportResultTy dflags ty + = checkRepTyCon (legalFIResultTyCon dflags) ty + +isFFIExportResultTy :: Type -> Validity +isFFIExportResultTy ty = checkRepTyCon legalFEResultTyCon ty + +isFFIDynTy :: Type -> Type -> Validity +-- The type in a foreign import dynamic must be Ptr, FunPtr, or a newtype of +-- either, and the wrapped function type must be equal to the given type. +-- We assume that all types have been run through normaliseFfiType, so we don't +-- need to worry about expanding newtypes here. +isFFIDynTy expected ty + -- Note [Foreign import dynamic] + -- In the example below, expected would be 'CInt -> IO ()', while ty would + -- be 'FunPtr (CDouble -> IO ())'. + | Just (tc, [ty']) <- splitTyConApp_maybe ty + , tyConUnique tc `elem` [ptrTyConKey, funPtrTyConKey] + , eqType ty' expected + = IsValid + | otherwise + = NotValid (vcat [ text "Expected: Ptr/FunPtr" <+> pprParendType expected <> comma + , text " Actual:" <+> ppr ty ]) + +isFFILabelTy :: Type -> Validity +-- The type of a foreign label must be Ptr, FunPtr, or a newtype of either. +isFFILabelTy ty = checkRepTyCon ok ty + where + ok tc | tc `hasKey` funPtrTyConKey || tc `hasKey` ptrTyConKey + = IsValid + | otherwise + = NotValid (text "A foreign-imported address (via &foo) must have type (Ptr a) or (FunPtr a)") + +isFFIPrimArgumentTy :: DynFlags -> Type -> Validity +-- Checks for valid argument type for a 'foreign import prim' +-- Currently they must all be simple unlifted types, or the well-known type +-- Any, which can be used to pass the address to a Haskell object on the heap to +-- the foreign function. +isFFIPrimArgumentTy dflags ty + | isAnyTy ty = IsValid + | otherwise = checkRepTyCon (legalFIPrimArgTyCon dflags) ty + +isFFIPrimResultTy :: DynFlags -> Type -> Validity +-- Checks for valid result type for a 'foreign import prim' Currently +-- it must be an unlifted type, including unboxed tuples, unboxed +-- sums, or the well-known type Any. +isFFIPrimResultTy dflags ty + | isAnyTy ty = IsValid + | otherwise = checkRepTyCon (legalFIPrimResultTyCon dflags) ty + +isFunPtrTy :: Type -> Bool +isFunPtrTy ty + | Just (tc, [_]) <- splitTyConApp_maybe ty + = tc `hasKey` funPtrTyConKey + | otherwise + = False + +-- normaliseFfiType gets run before checkRepTyCon, so we don't +-- need to worry about looking through newtypes or type functions +-- here; that's already been taken care of. +checkRepTyCon :: (TyCon -> Validity) -> Type -> Validity +checkRepTyCon check_tc ty + = case splitTyConApp_maybe ty of + Just (tc, tys) + | isNewTyCon tc -> NotValid (hang msg 2 (mk_nt_reason tc tys $$ nt_fix)) + | otherwise -> case check_tc tc of + IsValid -> IsValid + NotValid extra -> NotValid (msg $$ extra) + Nothing -> NotValid (quotes (ppr ty) <+> text "is not a data type") + where + msg = quotes (ppr ty) <+> text "cannot be marshalled in a foreign call" + mk_nt_reason tc tys + | null tys = text "because its data constructor is not in scope" + | otherwise = text "because the data constructor for" + <+> quotes (ppr tc) <+> text "is not in scope" + nt_fix = text "Possible fix: import the data constructor to bring it into scope" + +{- +Note [Foreign import dynamic] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A dynamic stub must be of the form 'FunPtr ft -> ft' where ft is any foreign +type. Similarly, a wrapper stub must be of the form 'ft -> IO (FunPtr ft)'. + +We use isFFIDynTy to check whether a signature is well-formed. For example, +given a (illegal) declaration like: + +foreign import ccall "dynamic" + foo :: FunPtr (CDouble -> IO ()) -> CInt -> IO () + +isFFIDynTy will compare the 'FunPtr' type 'CDouble -> IO ()' with the curried +result type 'CInt -> IO ()', and return False, as they are not equal. + + +---------------------------------------------- +These chaps do the work; they are not exported +---------------------------------------------- +-} + +legalFEArgTyCon :: TyCon -> Validity +legalFEArgTyCon tc + -- It's illegal to make foreign exports that take unboxed + -- arguments. The RTS API currently can't invoke such things. --SDM 7/2000 + = boxedMarshalableTyCon tc + +legalFIResultTyCon :: DynFlags -> TyCon -> Validity +legalFIResultTyCon dflags tc + | tc == unitTyCon = IsValid + | otherwise = marshalableTyCon dflags tc + +legalFEResultTyCon :: TyCon -> Validity +legalFEResultTyCon tc + | tc == unitTyCon = IsValid + | otherwise = boxedMarshalableTyCon tc + +legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Validity +-- Checks validity of types going from Haskell -> external world +legalOutgoingTyCon dflags _ tc + = marshalableTyCon dflags tc + +legalFFITyCon :: TyCon -> Validity +-- True for any TyCon that can possibly be an arg or result of an FFI call +legalFFITyCon tc + | isUnliftedTyCon tc = IsValid + | tc == unitTyCon = IsValid + | otherwise = boxedMarshalableTyCon tc + +marshalableTyCon :: DynFlags -> TyCon -> Validity +marshalableTyCon dflags tc + | isUnliftedTyCon tc + , not (isUnboxedTupleTyCon tc || isUnboxedSumTyCon tc) + , not (null (tyConPrimRep tc)) -- Note [Marshalling void] + = validIfUnliftedFFITypes dflags + | otherwise + = boxedMarshalableTyCon tc + +boxedMarshalableTyCon :: TyCon -> Validity +boxedMarshalableTyCon tc + | getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey + , int32TyConKey, int64TyConKey + , wordTyConKey, word8TyConKey, word16TyConKey + , word32TyConKey, word64TyConKey + , floatTyConKey, doubleTyConKey + , ptrTyConKey, funPtrTyConKey + , charTyConKey + , stablePtrTyConKey + , boolTyConKey + ] + = IsValid + + | otherwise = NotValid empty + +legalFIPrimArgTyCon :: DynFlags -> TyCon -> Validity +-- Check args of 'foreign import prim', only allow simple unlifted types. +-- Strictly speaking it is unnecessary to ban unboxed tuples and sums here since +-- currently they're of the wrong kind to use in function args anyway. +legalFIPrimArgTyCon dflags tc + | isUnliftedTyCon tc + , not (isUnboxedTupleTyCon tc || isUnboxedSumTyCon tc) + = validIfUnliftedFFITypes dflags + | otherwise + = NotValid unlifted_only + +legalFIPrimResultTyCon :: DynFlags -> TyCon -> Validity +-- Check result type of 'foreign import prim'. Allow simple unlifted +-- types and also unboxed tuple and sum result types. +legalFIPrimResultTyCon dflags tc + | isUnliftedTyCon tc + , isUnboxedTupleTyCon tc || isUnboxedSumTyCon tc + || not (null (tyConPrimRep tc)) -- Note [Marshalling void] + = validIfUnliftedFFITypes dflags + + | otherwise + = NotValid unlifted_only + +unlifted_only :: MsgDoc +unlifted_only = text "foreign import prim only accepts simple unlifted types" + +validIfUnliftedFFITypes :: DynFlags -> Validity +validIfUnliftedFFITypes dflags + | xopt LangExt.UnliftedFFITypes dflags = IsValid + | otherwise = NotValid (text "To marshal unlifted types, use UnliftedFFITypes") + +{- +Note [Marshalling void] +~~~~~~~~~~~~~~~~~~~~~~~ +We don't treat State# (whose PrimRep is VoidRep) as marshalable. +In turn that means you can't write + foreign import foo :: Int -> State# RealWorld + +Reason: the back end falls over with panic "primRepHint:VoidRep"; + and there is no compelling reason to permit it +-} + +{- +************************************************************************ +* * + The "Paterson size" of a type +* * +************************************************************************ +-} + +{- +Note [Paterson conditions on PredTypes] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We are considering whether *class* constraints terminate +(see Note [Paterson conditions]). Precisely, the Paterson conditions +would have us check that "the constraint has fewer constructors and variables +(taken together and counting repetitions) than the head.". + +However, we can be a bit more refined by looking at which kind of constraint +this actually is. There are two main tricks: + + 1. It seems like it should be OK not to count the tuple type constructor + for a PredType like (Show a, Eq a) :: Constraint, since we don't + count the "implicit" tuple in the ThetaType itself. + + In fact, the Paterson test just checks *each component* of the top level + ThetaType against the size bound, one at a time. By analogy, it should be + OK to return the size of the *largest* tuple component as the size of the + whole tuple. + + 2. Once we get into an implicit parameter or equality we + can't get back to a class constraint, so it's safe + to say "size 0". See #4200. + +NB: we don't want to detect PredTypes in sizeType (and then call +sizePred on them), or we might get an infinite loop if that PredType +is irreducible. See #5581. +-} + +type TypeSize = IntWithInf + +sizeType :: Type -> TypeSize +-- Size of a type: the number of variables and constructors +-- Ignore kinds altogether +sizeType = go + where + go ty | Just exp_ty <- tcView ty = go exp_ty + go (TyVarTy {}) = 1 + go (TyConApp tc tys) + | isTypeFamilyTyCon tc = infinity -- Type-family applications can + -- expand to any arbitrary size + | otherwise = sizeTypes (filterOutInvisibleTypes tc tys) + 1 + -- Why filter out invisible args? I suppose any + -- size ordering is sound, but why is this better? + -- I came across this when investigating #14010. + go (LitTy {}) = 1 + go (FunTy _ arg res) = go arg + go res + 1 + go (AppTy fun arg) = go fun + go arg + go (ForAllTy (Bndr tv vis) ty) + | isVisibleArgFlag vis = go (tyVarKind tv) + go ty + 1 + | otherwise = go ty + 1 + go (CastTy ty _) = go ty + go (CoercionTy {}) = 0 + +sizeTypes :: [Type] -> TypeSize +sizeTypes tys = sum (map sizeType tys) + +----------------------------------------------------------------------------------- +----------------------------------------------------------------------------------- +----------------------- +-- | For every arg a tycon can take, the returned list says True if the argument +-- is taken visibly, and False otherwise. Ends with an infinite tail of Trues to +-- allow for oversaturation. +tcTyConVisibilities :: TyCon -> [Bool] +tcTyConVisibilities tc = tc_binder_viss ++ tc_return_kind_viss ++ repeat True + where + tc_binder_viss = map isVisibleTyConBinder (tyConBinders tc) + tc_return_kind_viss = map isVisibleBinder (fst $ tcSplitPiTys (tyConResKind tc)) + +-- | If the tycon is applied to the types, is the next argument visible? +isNextTyConArgVisible :: TyCon -> [Type] -> Bool +isNextTyConArgVisible tc tys + = tcTyConVisibilities tc `getNth` length tys + +-- | Should this type be applied to a visible argument? +isNextArgVisible :: TcType -> Bool +isNextArgVisible ty + | Just (bndr, _) <- tcSplitPiTy_maybe ty = isVisibleBinder bndr + | otherwise = True + -- this second case might happen if, say, we have an unzonked TauTv. + -- But TauTvs can't range over types that take invisible arguments diff --git a/compiler/typecheck/TcType.hs-boot b/compiler/typecheck/TcType.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/typecheck/TcType.hs-boot @@ -0,0 +1,8 @@ +module TcType where +import Outputable( SDoc ) + +data MetaDetails + +data TcTyVarDetails +pprTcTyVarDetails :: TcTyVarDetails -> SDoc +vanillaSkolemTv :: TcTyVarDetails diff --git a/compiler/types/Class.hs b/compiler/types/Class.hs new file mode 100644 --- /dev/null +++ b/compiler/types/Class.hs @@ -0,0 +1,359 @@ +-- (c) The University of Glasgow 2006 +-- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-- +-- The @Class@ datatype + +{-# LANGUAGE CPP #-} + +module Class ( + Class, + ClassOpItem, + ClassATItem(..), + ClassMinimalDef, + DefMethInfo, pprDefMethInfo, + + FunDep, pprFundeps, pprFunDep, + + mkClass, mkAbstractClass, classTyVars, classArity, + classKey, className, classATs, classATItems, classTyCon, classMethods, + classOpItems, classBigSig, classExtraBigSig, classTvsFds, classSCTheta, + classAllSelIds, classSCSelId, classSCSelIds, classMinimalDef, classHasFds, + isAbstractClass, + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import {-# SOURCE #-} TyCon ( TyCon ) +import {-# SOURCE #-} TyCoRep ( Type, PredType, pprType ) +import Var +import Name +import BasicTypes +import Unique +import Util +import SrcLoc +import Outputable +import BooleanFormula (BooleanFormula, mkTrue) + +import qualified Data.Data as Data + +{- +************************************************************************ +* * +\subsection[Class-basic]{@Class@: basic definition} +* * +************************************************************************ + +A @Class@ corresponds to a Greek kappa in the static semantics: +-} + +data Class + = Class { + classTyCon :: TyCon, -- The data type constructor for + -- dictionaries of this class + -- See Note [ATyCon for classes] in TyCoRep + + className :: Name, -- Just the cached name of the TyCon + classKey :: Unique, -- Cached unique of TyCon + + classTyVars :: [TyVar], -- The class kind and type variables; + -- identical to those of the TyCon + -- If you want visibility info, look at the classTyCon + -- This field is redundant because it's duplicated in the + -- classTyCon, but classTyVars is used quite often, so maybe + -- it's a bit faster to cache it here + + classFunDeps :: [FunDep TyVar], -- The functional dependencies + + classBody :: ClassBody -- Superclasses, ATs, methods + + } + +-- | e.g. +-- +-- > class C a b c | a b -> c, a c -> b where... +-- +-- Here fun-deps are [([a,b],[c]), ([a,c],[b])] +-- +-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow'', + +-- For details on above see note [Api annotations] in ApiAnnotation +type FunDep a = ([a],[a]) + +type ClassOpItem = (Id, DefMethInfo) + -- Selector function; contains unfolding + -- Default-method info + +type DefMethInfo = Maybe (Name, DefMethSpec Type) + -- Nothing No default method + -- Just ($dm, VanillaDM) A polymorphic default method, name $dm + -- Just ($gm, GenericDM ty) A generic default method, name $gm, type ty + -- The generic dm type is *not* quantified + -- over the class variables; ie has the + -- class variables free + +data ClassATItem + = ATI TyCon -- See Note [Associated type tyvar names] + (Maybe (Type, SrcSpan)) + -- Default associated type (if any) from this template + -- Note [Associated type defaults] + +type ClassMinimalDef = BooleanFormula Name -- Required methods + +data ClassBody + = AbstractClass + | ConcreteClass { + -- Superclasses: eg: (F a ~ b, F b ~ G a, Eq a, Show b) + -- We need value-level selectors for both the dictionary + -- superclasses and the equality superclasses + cls_sc_theta :: [PredType], -- Immediate superclasses, + cls_sc_sel_ids :: [Id], -- Selector functions to extract the + -- superclasses from a + -- dictionary of this class + -- Associated types + cls_ats :: [ClassATItem], -- Associated type families + + -- Class operations (methods, not superclasses) + cls_ops :: [ClassOpItem], -- Ordered by tag + + -- Minimal complete definition + cls_min_def :: ClassMinimalDef + } + -- TODO: maybe super classes should be allowed in abstract class definitions + +classMinimalDef :: Class -> ClassMinimalDef +classMinimalDef Class{ classBody = ConcreteClass{ cls_min_def = d } } = d +classMinimalDef _ = mkTrue -- TODO: make sure this is the right direction + +{- +Note [Associated type defaults] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The following is an example of associated type defaults: + class C a where + data D a r + + type F x a b :: * + type F p q r = (p,q)->r -- Default + +Note that + + * The TyCons for the associated types *share type variables* with the + class, so that we can tell which argument positions should be + instantiated in an instance decl. (The first for 'D', the second + for 'F'.) + + * We can have default definitions only for *type* families, + not data families + + * In the default decl, the "patterns" should all be type variables, + but (in the source language) they don't need to be the same as in + the 'type' decl signature or the class. It's more like a + free-standing 'type instance' declaration. + + * HOWEVER, in the internal ClassATItem we rename the RHS to match the + tyConTyVars of the family TyCon. So in the example above we'd get + a ClassATItem of + ATI F ((x,a) -> b) + So the tyConTyVars of the family TyCon bind the free vars of + the default Type rhs + +The @mkClass@ function fills in the indirect superclasses. + +The SrcSpan is for the entire original declaration. +-} + +mkClass :: Name -> [TyVar] + -> [FunDep TyVar] + -> [PredType] -> [Id] + -> [ClassATItem] + -> [ClassOpItem] + -> ClassMinimalDef + -> TyCon + -> Class + +mkClass cls_name tyvars fds super_classes superdict_sels at_stuff + op_stuff mindef tycon + = Class { classKey = nameUnique cls_name, + className = cls_name, + -- NB: tyConName tycon = cls_name, + -- But it takes a module loop to assert it here + classTyVars = tyvars, + classFunDeps = fds, + classBody = ConcreteClass { + cls_sc_theta = super_classes, + cls_sc_sel_ids = superdict_sels, + cls_ats = at_stuff, + cls_ops = op_stuff, + cls_min_def = mindef + }, + classTyCon = tycon } + +mkAbstractClass :: Name -> [TyVar] + -> [FunDep TyVar] + -> TyCon + -> Class + +mkAbstractClass cls_name tyvars fds tycon + = Class { classKey = nameUnique cls_name, + className = cls_name, + -- NB: tyConName tycon = cls_name, + -- But it takes a module loop to assert it here + classTyVars = tyvars, + classFunDeps = fds, + classBody = AbstractClass, + classTyCon = tycon } + +{- +Note [Associated type tyvar names] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The TyCon of an associated type should use the same variable names as its +parent class. Thus + class C a b where + type F b x a :: * +We make F use the same Name for 'a' as C does, and similary 'b'. + +The reason for this is when checking instances it's easier to match +them up, to ensure they match. Eg + instance C Int [d] where + type F [d] x Int = .... +we should make sure that the first and third args match the instance +header. + +Having the same variables for class and tycon is also used in checkValidRoles +(in TcTyClsDecls) when checking a class's roles. + + +************************************************************************ +* * +\subsection[Class-selectors]{@Class@: simple selectors} +* * +************************************************************************ + +The rest of these functions are just simple selectors. +-} + +classArity :: Class -> Arity +classArity clas = length (classTyVars clas) + -- Could memoise this + +classAllSelIds :: Class -> [Id] +-- Both superclass-dictionary and method selectors +classAllSelIds c@(Class { classBody = ConcreteClass { cls_sc_sel_ids = sc_sels }}) + = sc_sels ++ classMethods c +classAllSelIds c = ASSERT( null (classMethods c) ) [] + +classSCSelIds :: Class -> [Id] +-- Both superclass-dictionary and method selectors +classSCSelIds (Class { classBody = ConcreteClass { cls_sc_sel_ids = sc_sels }}) + = sc_sels +classSCSelIds c = ASSERT( null (classMethods c) ) [] + +classSCSelId :: Class -> Int -> Id +-- Get the n'th superclass selector Id +-- where n is 0-indexed, and counts +-- *all* superclasses including equalities +classSCSelId (Class { classBody = ConcreteClass { cls_sc_sel_ids = sc_sels } }) n + = ASSERT( n >= 0 && lengthExceeds sc_sels n ) + sc_sels !! n +classSCSelId c n = pprPanic "classSCSelId" (ppr c <+> ppr n) + +classMethods :: Class -> [Id] +classMethods (Class { classBody = ConcreteClass { cls_ops = op_stuff } }) + = [op_sel | (op_sel, _) <- op_stuff] +classMethods _ = [] + +classOpItems :: Class -> [ClassOpItem] +classOpItems (Class { classBody = ConcreteClass { cls_ops = op_stuff }}) + = op_stuff +classOpItems _ = [] + +classATs :: Class -> [TyCon] +classATs (Class { classBody = ConcreteClass { cls_ats = at_stuff } }) + = [tc | ATI tc _ <- at_stuff] +classATs _ = [] + +classATItems :: Class -> [ClassATItem] +classATItems (Class { classBody = ConcreteClass { cls_ats = at_stuff }}) + = at_stuff +classATItems _ = [] + +classSCTheta :: Class -> [PredType] +classSCTheta (Class { classBody = ConcreteClass { cls_sc_theta = theta_stuff }}) + = theta_stuff +classSCTheta _ = [] + +classTvsFds :: Class -> ([TyVar], [FunDep TyVar]) +classTvsFds c = (classTyVars c, classFunDeps c) + +classHasFds :: Class -> Bool +classHasFds (Class { classFunDeps = fds }) = not (null fds) + +classBigSig :: Class -> ([TyVar], [PredType], [Id], [ClassOpItem]) +classBigSig (Class {classTyVars = tyvars, + classBody = AbstractClass}) + = (tyvars, [], [], []) +classBigSig (Class {classTyVars = tyvars, + classBody = ConcreteClass { + cls_sc_theta = sc_theta, + cls_sc_sel_ids = sc_sels, + cls_ops = op_stuff + }}) + = (tyvars, sc_theta, sc_sels, op_stuff) + +classExtraBigSig :: Class -> ([TyVar], [FunDep TyVar], [PredType], [Id], [ClassATItem], [ClassOpItem]) +classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps, + classBody = AbstractClass}) + = (tyvars, fundeps, [], [], [], []) +classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps, + classBody = ConcreteClass { + cls_sc_theta = sc_theta, cls_sc_sel_ids = sc_sels, + cls_ats = ats, cls_ops = op_stuff + }}) + = (tyvars, fundeps, sc_theta, sc_sels, ats, op_stuff) + +isAbstractClass :: Class -> Bool +isAbstractClass Class{ classBody = AbstractClass } = True +isAbstractClass _ = False + +{- +************************************************************************ +* * +\subsection[Class-instances]{Instance declarations for @Class@} +* * +************************************************************************ + +We compare @Classes@ by their keys (which include @Uniques@). +-} + +instance Eq Class where + c1 == c2 = classKey c1 == classKey c2 + c1 /= c2 = classKey c1 /= classKey c2 + +instance Uniquable Class where + getUnique c = classKey c + +instance NamedThing Class where + getName clas = className clas + +instance Outputable Class where + ppr c = ppr (getName c) + +pprDefMethInfo :: DefMethInfo -> SDoc +pprDefMethInfo Nothing = empty -- No default method +pprDefMethInfo (Just (n, VanillaDM)) = text "Default method" <+> ppr n +pprDefMethInfo (Just (n, GenericDM ty)) = text "Generic default method" + <+> ppr n <+> dcolon <+> pprType ty + +pprFundeps :: Outputable a => [FunDep a] -> SDoc +pprFundeps [] = empty +pprFundeps fds = hsep (vbar : punctuate comma (map pprFunDep fds)) + +pprFunDep :: Outputable a => FunDep a -> SDoc +pprFunDep (us, vs) = hsep [interppSP us, arrow, interppSP vs] + +instance Data.Data Class where + -- don't traverse? + toConstr _ = abstractConstr "Class" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "Class" diff --git a/compiler/types/CoAxiom.hs b/compiler/types/CoAxiom.hs new file mode 100644 --- /dev/null +++ b/compiler/types/CoAxiom.hs @@ -0,0 +1,576 @@ +-- (c) The University of Glasgow 2012 + +{-# LANGUAGE CPP, DataKinds, DeriveDataTypeable, GADTs, KindSignatures, + ScopedTypeVariables, StandaloneDeriving, RoleAnnotations #-} + +-- | Module for coercion axioms, used to represent type family instances +-- and newtypes + +module CoAxiom ( + BranchFlag, Branched, Unbranched, BranchIndex, Branches(..), + manyBranches, unbranched, + fromBranches, numBranches, + mapAccumBranches, + + CoAxiom(..), CoAxBranch(..), + + toBranchedAxiom, toUnbranchedAxiom, + coAxiomName, coAxiomArity, coAxiomBranches, + coAxiomTyCon, isImplicitCoAxiom, coAxiomNumPats, + coAxiomNthBranch, coAxiomSingleBranch_maybe, coAxiomRole, + coAxiomSingleBranch, coAxBranchTyVars, coAxBranchCoVars, + coAxBranchRoles, + coAxBranchLHS, coAxBranchRHS, coAxBranchSpan, coAxBranchIncomps, + placeHolderIncomps, + + Role(..), fsFromRole, + + CoAxiomRule(..), TypeEqn, + BuiltInSynFamily(..), trivialBuiltInFamily + ) where + +import GhcPrelude + +import {-# SOURCE #-} TyCoRep ( Type, pprType ) +import {-# SOURCE #-} TyCon ( TyCon ) +import Outputable +import FastString +import Name +import Unique +import Var +import Util +import Binary +import Pair +import BasicTypes +import Data.Typeable ( Typeable ) +import SrcLoc +import qualified Data.Data as Data +import Data.Array +import Data.List ( mapAccumL ) + +#include "HsVersions.h" + +{- +Note [Coercion axiom branches] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In order to allow closed type families, an axiom needs to contain an +ordered list of alternatives, called branches. The kind of the coercion built +from an axiom is determined by which index is used when building the coercion +from the axiom. + +For example, consider the axiom derived from the following declaration: + +type family F a where + F [Int] = Bool + F [a] = Double + F (a b) = Char + +This will give rise to this axiom: + +axF :: { F [Int] ~ Bool + ; forall (a :: *). F [a] ~ Double + ; forall (k :: *) (a :: k -> *) (b :: k). F (a b) ~ Char + } + +The axiom is used with the AxiomInstCo constructor of Coercion. If we wish +to have a coercion showing that F (Maybe Int) ~ Char, it will look like + +axF[2] <*> :: F (Maybe Int) ~ Char +-- or, written using concrete-ish syntax -- +AxiomInstCo axF 2 [Refl *, Refl Maybe, Refl Int] + +Note that the index is 0-based. + +For type-checking, it is also necessary to check that no previous pattern +can unify with the supplied arguments. After all, it is possible that some +of the type arguments are lambda-bound type variables whose instantiation may +cause an earlier match among the branches. We wish to prohibit this behavior, +so the type checker rules out the choice of a branch where a previous branch +can unify. See also [Apartness] in FamInstEnv.hs. + +For example, the following is malformed, where 'a' is a lambda-bound type +variable: + +axF[2] <*> :: F (a Bool) ~ Char + +Why? Because a might be instantiated with [], meaning that branch 1 should +apply, not branch 2. This is a vital consistency check; without it, we could +derive Int ~ Bool, and that is a Bad Thing. + +Note [Branched axioms] +~~~~~~~~~~~~~~~~~~~~~~ +Although a CoAxiom has the capacity to store many branches, in certain cases, +we want only one. These cases are in data/newtype family instances, newtype +coercions, and type family instances. +Furthermore, these unbranched axioms are used in a +variety of places throughout GHC, and it would difficult to generalize all of +that code to deal with branched axioms, especially when the code can be sure +of the fact that an axiom is indeed a singleton. At the same time, it seems +dangerous to assume singlehood in various places through GHC. + +The solution to this is to label a CoAxiom with a phantom type variable +declaring whether it is known to be a singleton or not. The branches +are stored using a special datatype, declared below, that ensures that the +type variable is accurate. + +************************************************************************ +* * + Branches +* * +************************************************************************ +-} + +type BranchIndex = Int -- The index of the branch in the list of branches + -- Counting from zero + +-- promoted data type +data BranchFlag = Branched | Unbranched +type Branched = 'Branched +type Unbranched = 'Unbranched +-- By using type synonyms for the promoted constructors, we avoid needing +-- DataKinds and the promotion quote in client modules. This also means that +-- we don't need to export the term-level constructors, which should never be used. + +newtype Branches (br :: BranchFlag) + = MkBranches { unMkBranches :: Array BranchIndex CoAxBranch } +type role Branches nominal + +manyBranches :: [CoAxBranch] -> Branches Branched +manyBranches brs = ASSERT( snd bnds >= fst bnds ) + MkBranches (listArray bnds brs) + where + bnds = (0, length brs - 1) + +unbranched :: CoAxBranch -> Branches Unbranched +unbranched br = MkBranches (listArray (0, 0) [br]) + +toBranched :: Branches br -> Branches Branched +toBranched = MkBranches . unMkBranches + +toUnbranched :: Branches br -> Branches Unbranched +toUnbranched (MkBranches arr) = ASSERT( bounds arr == (0,0) ) + MkBranches arr + +fromBranches :: Branches br -> [CoAxBranch] +fromBranches = elems . unMkBranches + +branchesNth :: Branches br -> BranchIndex -> CoAxBranch +branchesNth (MkBranches arr) n = arr ! n + +numBranches :: Branches br -> Int +numBranches (MkBranches arr) = snd (bounds arr) + 1 + +-- | The @[CoAxBranch]@ passed into the mapping function is a list of +-- all previous branches, reversed +mapAccumBranches :: ([CoAxBranch] -> CoAxBranch -> CoAxBranch) + -> Branches br -> Branches br +mapAccumBranches f (MkBranches arr) + = MkBranches (listArray (bounds arr) (snd $ mapAccumL go [] (elems arr))) + where + go :: [CoAxBranch] -> CoAxBranch -> ([CoAxBranch], CoAxBranch) + go prev_branches cur_branch = ( cur_branch : prev_branches + , f prev_branches cur_branch ) + + +{- +************************************************************************ +* * + Coercion axioms +* * +************************************************************************ + +Note [Storing compatibility] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +During axiom application, we need to be aware of which branches are compatible +with which others. The full explanation is in Note [Compatibility] in +FamInstEnv. (The code is placed there to avoid a dependency from CoAxiom on +the unification algorithm.) Although we could theoretically compute +compatibility on the fly, this is silly, so we store it in a CoAxiom. + +Specifically, each branch refers to all other branches with which it is +incompatible. This list might well be empty, and it will always be for the +first branch of any axiom. + +CoAxBranches that do not (yet) belong to a CoAxiom should have a panic thunk +stored in cab_incomps. The incompatibilities are properly a property of the +axiom as a whole, and they are computed only when the final axiom is built. + +During serialization, the list is converted into a list of the indices +of the branches. +-} + +-- | A 'CoAxiom' is a \"coercion constructor\", i.e. a named equality axiom. + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in coreSyn/CoreLint.hs +data CoAxiom br + = CoAxiom -- Type equality axiom. + { co_ax_unique :: Unique -- Unique identifier + , co_ax_name :: Name -- Name for pretty-printing + , co_ax_role :: Role -- Role of the axiom's equality + , co_ax_tc :: TyCon -- The head of the LHS patterns + -- e.g. the newtype or family tycon + , co_ax_branches :: Branches br -- The branches that form this axiom + , co_ax_implicit :: Bool -- True <=> the axiom is "implicit" + -- See Note [Implicit axioms] + -- INVARIANT: co_ax_implicit == True implies length co_ax_branches == 1. + } + +data CoAxBranch + = CoAxBranch + { cab_loc :: SrcSpan -- Location of the defining equation + -- See Note [CoAxiom locations] + , cab_tvs :: [TyVar] -- Bound type variables; not necessarily fresh + , cab_eta_tvs :: [TyVar] -- Eta-reduced tyvars + -- See Note [CoAxBranch type variables] + -- cab_tvs and cab_lhs may be eta-reduded; see + -- Note [Eta reduction for data families] + , cab_cvs :: [CoVar] -- Bound coercion variables + -- Always empty, for now. + -- See Note [Constraints in patterns] + -- in TcTyClsDecls + , cab_roles :: [Role] -- See Note [CoAxBranch roles] + , cab_lhs :: [Type] -- Type patterns to match against + -- See Note [CoAxiom saturation] + , cab_rhs :: Type -- Right-hand side of the equality + , cab_incomps :: [CoAxBranch] -- The previous incompatible branches + -- See Note [Storing compatibility] + } + deriving Data.Data + +toBranchedAxiom :: CoAxiom br -> CoAxiom Branched +toBranchedAxiom (CoAxiom unique name role tc branches implicit) + = CoAxiom unique name role tc (toBranched branches) implicit + +toUnbranchedAxiom :: CoAxiom br -> CoAxiom Unbranched +toUnbranchedAxiom (CoAxiom unique name role tc branches implicit) + = CoAxiom unique name role tc (toUnbranched branches) implicit + +coAxiomNumPats :: CoAxiom br -> Int +coAxiomNumPats = length . coAxBranchLHS . (flip coAxiomNthBranch 0) + +coAxiomNthBranch :: CoAxiom br -> BranchIndex -> CoAxBranch +coAxiomNthBranch (CoAxiom { co_ax_branches = bs }) index + = branchesNth bs index + +coAxiomArity :: CoAxiom br -> BranchIndex -> Arity +coAxiomArity ax index + = length tvs + length cvs + where + CoAxBranch { cab_tvs = tvs, cab_cvs = cvs } = coAxiomNthBranch ax index + +coAxiomName :: CoAxiom br -> Name +coAxiomName = co_ax_name + +coAxiomRole :: CoAxiom br -> Role +coAxiomRole = co_ax_role + +coAxiomBranches :: CoAxiom br -> Branches br +coAxiomBranches = co_ax_branches + +coAxiomSingleBranch_maybe :: CoAxiom br -> Maybe CoAxBranch +coAxiomSingleBranch_maybe (CoAxiom { co_ax_branches = MkBranches arr }) + | snd (bounds arr) == 0 + = Just $ arr ! 0 + | otherwise + = Nothing + +coAxiomSingleBranch :: CoAxiom Unbranched -> CoAxBranch +coAxiomSingleBranch (CoAxiom { co_ax_branches = MkBranches arr }) + = arr ! 0 + +coAxiomTyCon :: CoAxiom br -> TyCon +coAxiomTyCon = co_ax_tc + +coAxBranchTyVars :: CoAxBranch -> [TyVar] +coAxBranchTyVars = cab_tvs + +coAxBranchCoVars :: CoAxBranch -> [CoVar] +coAxBranchCoVars = cab_cvs + +coAxBranchLHS :: CoAxBranch -> [Type] +coAxBranchLHS = cab_lhs + +coAxBranchRHS :: CoAxBranch -> Type +coAxBranchRHS = cab_rhs + +coAxBranchRoles :: CoAxBranch -> [Role] +coAxBranchRoles = cab_roles + +coAxBranchSpan :: CoAxBranch -> SrcSpan +coAxBranchSpan = cab_loc + +isImplicitCoAxiom :: CoAxiom br -> Bool +isImplicitCoAxiom = co_ax_implicit + +coAxBranchIncomps :: CoAxBranch -> [CoAxBranch] +coAxBranchIncomps = cab_incomps + +-- See Note [Compatibility checking] in FamInstEnv +placeHolderIncomps :: [CoAxBranch] +placeHolderIncomps = panic "placeHolderIncomps" + +{- Note [CoAxiom saturation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* When co + +Note [CoAxBranch type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the case of a CoAxBranch of an associated type-family instance, +we use the *same* type variables (where possible) as the +enclosing class or instance. Consider + + instance C Int [z] where + type F Int [z] = ... -- Second param must be [z] + +In the CoAxBranch in the instance decl (F Int [z]) we use the +same 'z', so that it's easy to check that that type is the same +as that in the instance header. + +So, unlike FamInsts, there is no expectation that the cab_tvs +are fresh wrt each other, or any other CoAxBranch. + +Note [CoAxBranch roles] +~~~~~~~~~~~~~~~~~~~~~~~ +Consider this code: + + newtype Age = MkAge Int + newtype Wrap a = MkWrap a + + convert :: Wrap Age -> Int + convert (MkWrap (MkAge i)) = i + +We want this to compile to: + + NTCo:Wrap :: forall a. Wrap a ~R a + NTCo:Age :: Age ~R Int + convert = \x -> x |> (NTCo:Wrap[0] NTCo:Age[0]) + +But, note that NTCo:Age is at role R. Thus, we need to be able to pass +coercions at role R into axioms. However, we don't *always* want to be able to +do this, as it would be disastrous with type families. The solution is to +annotate the arguments to the axiom with roles, much like we annotate tycon +tyvars. Where do these roles get set? Newtype axioms inherit their roles from +the newtype tycon; family axioms are all at role N. + +Note [CoAxiom locations] +~~~~~~~~~~~~~~~~~~~~~~~~ +The source location of a CoAxiom is stored in two places in the +datatype tree. + * The first is in the location info buried in the Name of the + CoAxiom. This span includes all of the branches of a branched + CoAxiom. + * The second is in the cab_loc fields of the CoAxBranches. + +In the case of a single branch, we can extract the source location of +the branch from the name of the CoAxiom. In other cases, we need an +explicit SrcSpan to correctly store the location of the equation +giving rise to the FamInstBranch. + +Note [Implicit axioms] +~~~~~~~~~~~~~~~~~~~~~~ +See also Note [Implicit TyThings] in HscTypes +* A CoAxiom arising from data/type family instances is not "implicit". + That is, it has its own IfaceAxiom declaration in an interface file + +* The CoAxiom arising from a newtype declaration *is* "implicit". + That is, it does not have its own IfaceAxiom declaration in an + interface file; instead the CoAxiom is generated by type-checking + the newtype declaration + +Note [Eta reduction for data families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + data family T a b :: * + newtype instance T Int a = MkT (IO a) deriving( Monad ) +We'd like this to work. + +From the 'newtype instance' you might think we'd get: + newtype TInt a = MkT (IO a) + axiom ax1 a :: T Int a ~ TInt a -- The newtype-instance part + axiom ax2 a :: TInt a ~ IO a -- The newtype part + +But now what can we do? We have this problem + Given: d :: Monad IO + Wanted: d' :: Monad (T Int) = d |> ???? +What coercion can we use for the ??? + +Solution: eta-reduce both axioms, thus: + axiom ax1 :: T Int ~ TInt + axiom ax2 :: TInt ~ IO +Now + d' = d |> Monad (sym (ax2 ; ax1)) + +----- Bottom line ------ + +For a CoAxBranch for a data family instance with representation +TyCon rep_tc: + + - cab_tvs (of its CoAxiom) may be shorter + than tyConTyVars of rep_tc. + + - cab_lhs may be shorter than tyConArity of the family tycon + i.e. LHS is unsaturated + + - cab_rhs will be (rep_tc cab_tvs) + i.e. RHS is un-saturated + + - This eta reduction happens for data instances as well + as newtype instances. Here we want to eta-reduce the data family axiom. + + - This eta-reduction is done in TcInstDcls.tcDataFamInstDecl. + +But for a /type/ family + - cab_lhs has the exact arity of the family tycon + +There are certain situations (e.g., pretty-printing) where it is necessary to +deal with eta-expanded data family instances. For these situations, the +cab_eta_tvs field records the stuff that has been eta-reduced away. +So if we have + axiom forall a b. F [a->b] = D b a +and cab_eta_tvs is [p,q], then the original user-written definition +looked like + axiom forall a b p q. F [a->b] p q = D b a p q +(See #9692, #14179, and #15845 for examples of what can go wrong if +we don't eta-expand when showing things to the user.) + +(See also Note [Newtype eta] in TyCon. This is notionally separate +and deals with the axiom connecting a newtype with its representation +type; but it too is eta-reduced.) +-} + +instance Eq (CoAxiom br) where + a == b = getUnique a == getUnique b + a /= b = getUnique a /= getUnique b + +instance Uniquable (CoAxiom br) where + getUnique = co_ax_unique + +instance Outputable (CoAxiom br) where + ppr = ppr . getName + +instance NamedThing (CoAxiom br) where + getName = co_ax_name + +instance Typeable br => Data.Data (CoAxiom br) where + -- don't traverse? + toConstr _ = abstractConstr "CoAxiom" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "CoAxiom" + +instance Outputable CoAxBranch where + ppr (CoAxBranch { cab_loc = loc + , cab_lhs = lhs + , cab_rhs = rhs }) = + text "CoAxBranch" <+> parens (ppr loc) <> colon + <+> brackets (fsep (punctuate comma (map pprType lhs))) + <+> text "=>" <+> pprType rhs + +{- +************************************************************************ +* * + Roles +* * +************************************************************************ + +Roles are defined here to avoid circular dependencies. +-} + +-- See Note [Roles] in Coercion +-- defined here to avoid cyclic dependency with Coercion +-- +-- Order of constructors matters: the Ord instance coincides with the *super*typing +-- relation on roles. +data Role = Nominal | Representational | Phantom + deriving (Eq, Ord, Data.Data) + +-- These names are slurped into the parser code. Changing these strings +-- will change the **surface syntax** that GHC accepts! If you want to +-- change only the pretty-printing, do some replumbing. See +-- mkRoleAnnotDecl in RdrHsSyn +fsFromRole :: Role -> FastString +fsFromRole Nominal = fsLit "nominal" +fsFromRole Representational = fsLit "representational" +fsFromRole Phantom = fsLit "phantom" + +instance Outputable Role where + ppr = ftext . fsFromRole + +instance Binary Role where + put_ bh Nominal = putByte bh 1 + put_ bh Representational = putByte bh 2 + put_ bh Phantom = putByte bh 3 + + get bh = do tag <- getByte bh + case tag of 1 -> return Nominal + 2 -> return Representational + 3 -> return Phantom + _ -> panic ("get Role " ++ show tag) + +{- +************************************************************************ +* * + CoAxiomRule + Rules for building Evidence +* * +************************************************************************ + +Conditional axioms. The general idea is that a `CoAxiomRule` looks like this: + + forall as. (r1 ~ r2, s1 ~ s2) => t1 ~ t2 + +My intention is to reuse these for both (~) and (~#). +The short-term plan is to use this datatype to represent the type-nat axioms. +In the longer run, it may be good to unify this and `CoAxiom`, +as `CoAxiom` is the special case when there are no assumptions. +-} + +-- | A more explicit representation for `t1 ~ t2`. +type TypeEqn = Pair Type + +-- | For now, we work only with nominal equality. +data CoAxiomRule = CoAxiomRule + { coaxrName :: FastString + , coaxrAsmpRoles :: [Role] -- roles of parameter equations + , coaxrRole :: Role -- role of resulting equation + , coaxrProves :: [TypeEqn] -> Maybe TypeEqn + -- ^ coaxrProves returns @Nothing@ when it doesn't like + -- the supplied arguments. When this happens in a coercion + -- that means that the coercion is ill-formed, and Core Lint + -- checks for that. + } + +instance Data.Data CoAxiomRule where + -- don't traverse? + toConstr _ = abstractConstr "CoAxiomRule" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "CoAxiomRule" + +instance Uniquable CoAxiomRule where + getUnique = getUnique . coaxrName + +instance Eq CoAxiomRule where + x == y = coaxrName x == coaxrName y + +instance Ord CoAxiomRule where + compare x y = compare (coaxrName x) (coaxrName y) + +instance Outputable CoAxiomRule where + ppr = ppr . coaxrName + + +-- Type checking of built-in families +data BuiltInSynFamily = BuiltInSynFamily + { sfMatchFam :: [Type] -> Maybe (CoAxiomRule, [Type], Type) + , sfInteractTop :: [Type] -> Type -> [TypeEqn] + , sfInteractInert :: [Type] -> Type -> + [Type] -> Type -> [TypeEqn] + } + +-- Provides default implementations that do nothing. +trivialBuiltInFamily :: BuiltInSynFamily +trivialBuiltInFamily = BuiltInSynFamily + { sfMatchFam = \_ -> Nothing + , sfInteractTop = \_ _ -> [] + , sfInteractInert = \_ _ _ _ -> [] + } diff --git a/compiler/types/Coercion.hs b/compiler/types/Coercion.hs new file mode 100644 --- /dev/null +++ b/compiler/types/Coercion.hs @@ -0,0 +1,2820 @@ +{- +(c) The University of Glasgow 2006 +-} + +{-# LANGUAGE RankNTypes, CPP, MultiWayIf, FlexibleContexts, BangPatterns, + ScopedTypeVariables #-} + +-- | Module for (a) type kinds and (b) type coercions, +-- as used in System FC. See 'CoreSyn.Expr' for +-- more on System FC and how coercions fit into it. +-- +module Coercion ( + -- * Main data type + Coercion, CoercionN, CoercionR, CoercionP, MCoercion(..), MCoercionR, + UnivCoProvenance, CoercionHole(..), coHoleCoVar, setCoHoleCoVar, + LeftOrRight(..), + Var, CoVar, TyCoVar, + Role(..), ltRole, + + -- ** Functions over coercions + coVarTypes, coVarKind, coVarKindsTypesRole, coVarRole, + coercionType, coercionKind, coercionKinds, + mkCoercionType, + coercionRole, coercionKindRole, + + -- ** Constructing coercions + mkGReflCo, mkReflCo, mkRepReflCo, mkNomReflCo, + mkCoVarCo, mkCoVarCos, + mkAxInstCo, mkUnbranchedAxInstCo, + mkAxInstRHS, mkUnbranchedAxInstRHS, + mkAxInstLHS, mkUnbranchedAxInstLHS, + mkPiCo, mkPiCos, mkCoCast, + mkSymCo, mkTransCo, mkTransMCo, + mkNthCo, nthCoRole, mkLRCo, + mkInstCo, mkAppCo, mkAppCos, mkTyConAppCo, mkFunCo, + mkForAllCo, mkForAllCos, mkHomoForAllCos, + mkPhantomCo, + mkUnsafeCo, mkHoleCo, mkUnivCo, mkSubCo, + mkAxiomInstCo, mkProofIrrelCo, + downgradeRole, maybeSubCo, mkAxiomRuleCo, + mkGReflRightCo, mkGReflLeftCo, mkCoherenceLeftCo, mkCoherenceRightCo, + mkKindCo, castCoercionKind, castCoercionKindI, + + mkHeteroCoercionType, + + -- ** Decomposition + instNewTyCon_maybe, + + NormaliseStepper, NormaliseStepResult(..), composeSteppers, + mapStepResult, unwrapNewTypeStepper, + topNormaliseNewType_maybe, topNormaliseTypeX, + + decomposeCo, decomposeFunCo, decomposePiCos, getCoVar_maybe, + splitTyConAppCo_maybe, + splitAppCo_maybe, + splitFunCo_maybe, + splitForAllCo_maybe, + splitForAllCo_ty_maybe, splitForAllCo_co_maybe, + + nthRole, tyConRolesX, tyConRolesRepresentational, setNominalRole_maybe, + + pickLR, + + isGReflCo, isReflCo, isReflCo_maybe, isGReflCo_maybe, isReflexiveCo, isReflexiveCo_maybe, + isReflCoVar_maybe, + + -- ** Coercion variables + mkCoVar, isCoVar, coVarName, setCoVarName, setCoVarUnique, + isCoVar_maybe, + + -- ** Free variables + tyCoVarsOfCo, tyCoVarsOfCos, coVarsOfCo, + tyCoFVsOfCo, tyCoFVsOfCos, tyCoVarsOfCoDSet, + coercionSize, + + -- ** Substitution + CvSubstEnv, emptyCvSubstEnv, + lookupCoVar, + substCo, substCos, substCoVar, substCoVars, substCoWith, + substCoVarBndr, + extendTvSubstAndInScope, getCvSubstEnv, + + -- ** Lifting + liftCoSubst, liftCoSubstTyVar, liftCoSubstWith, liftCoSubstWithEx, + emptyLiftingContext, extendLiftingContext, extendLiftingContextAndInScope, + liftCoSubstVarBndrUsing, isMappedByLC, + + mkSubstLiftingContext, zapLiftingContext, + substForAllCoBndrUsingLC, lcTCvSubst, lcInScopeSet, + + LiftCoEnv, LiftingContext(..), liftEnvSubstLeft, liftEnvSubstRight, + substRightCo, substLeftCo, swapLiftCoEnv, lcSubstLeft, lcSubstRight, + + -- ** Comparison + eqCoercion, eqCoercionX, + + -- ** Forcing evaluation of coercions + seqCo, + + -- * Pretty-printing + pprCo, pprParendCo, + pprCoAxiom, pprCoAxBranch, pprCoAxBranchLHS, + pprCoAxBranchUser, tidyCoAxBndrsForUser, + etaExpandCoAxBranch, + + -- * Tidying + tidyCo, tidyCos, + + -- * Other + promoteCoercion, buildCoercion, + + simplifyArgsWorker + ) where + +#include "HsVersions.h" + +import {-# SOURCE #-} ToIface (toIfaceTyCon, tidyToIfaceTcArgs) + +import GhcPrelude + +import IfaceType +import TyCoRep +import Type +import TyCon +import CoAxiom +import Var +import VarEnv +import VarSet +import Name hiding ( varName ) +import Util +import BasicTypes +import Outputable +import Unique +import Pair +import SrcLoc +import PrelNames +import TysPrim ( eqPhantPrimTyCon ) +import ListSetOps +import Maybes +import UniqFM + +import Control.Monad (foldM, zipWithM) +import Data.Function ( on ) +import Data.Char( isDigit ) + +{- +%************************************************************************ +%* * + -- The coercion arguments always *precisely* saturate + -- arity of (that branch of) the CoAxiom. If there are + -- any left over, we use AppCo. See + -- See [Coercion axioms applied to coercions] in TyCoRep + +\subsection{Coercion variables} +%* * +%************************************************************************ +-} + +coVarName :: CoVar -> Name +coVarName = varName + +setCoVarUnique :: CoVar -> Unique -> CoVar +setCoVarUnique = setVarUnique + +setCoVarName :: CoVar -> Name -> CoVar +setCoVarName = setVarName + +{- +%************************************************************************ +%* * + Pretty-printing CoAxioms +%* * +%************************************************************************ + +Defined here to avoid module loops. CoAxiom is loaded very early on. + +-} + +etaExpandCoAxBranch :: CoAxBranch -> ([TyVar], [Type], Type) +-- Return the (tvs,lhs,rhs) after eta-expanding, +-- to the way in which the axiom was originally written +-- See Note [Eta reduction for data families] in CoAxiom +etaExpandCoAxBranch (CoAxBranch { cab_tvs = tvs + , cab_eta_tvs = eta_tvs + , cab_lhs = lhs + , cab_rhs = rhs }) + -- ToDo: what about eta_cvs? + = (tvs ++ eta_tvs, lhs ++ eta_tys, mkAppTys rhs eta_tys) + where + eta_tys = mkTyVarTys eta_tvs + +pprCoAxiom :: CoAxiom br -> SDoc +-- Used in debug-printing only +pprCoAxiom ax@(CoAxiom { co_ax_tc = tc, co_ax_branches = branches }) + = hang (text "axiom" <+> ppr ax <+> dcolon) + 2 (vcat (map (pprCoAxBranchUser tc) (fromBranches branches))) + +pprCoAxBranchUser :: TyCon -> CoAxBranch -> SDoc +-- Used when printing injectivity errors (FamInst.makeInjectivityErrors) +-- and inaccessible branches (TcValidity.inaccessibleCoAxBranch) +-- This happens in error messages: don't print the RHS of a data +-- family axiom, which is meaningless to a user +pprCoAxBranchUser tc br + | isDataFamilyTyCon tc = pprCoAxBranchLHS tc br + | otherwise = pprCoAxBranch tc br + +pprCoAxBranchLHS :: TyCon -> CoAxBranch -> SDoc +-- Print the family-instance equation when reporting +-- a conflict between equations (FamInst.conflictInstErr) +-- For type families the RHS is important; for data families not so. +-- Indeed for data families the RHS is a mysterious internal +-- type constructor, so we suppress it (#14179) +-- See FamInstEnv Note [Family instance overlap conflicts] +pprCoAxBranchLHS = ppr_co_ax_branch pp_rhs + where + pp_rhs _ _ = empty + +pprCoAxBranch :: TyCon -> CoAxBranch -> SDoc +pprCoAxBranch = ppr_co_ax_branch ppr_rhs + where + ppr_rhs env rhs = equals <+> pprPrecTypeX env topPrec rhs + +ppr_co_ax_branch :: (TidyEnv -> Type -> SDoc) + -> TyCon -> CoAxBranch -> SDoc +ppr_co_ax_branch ppr_rhs fam_tc branch + = foldr1 (flip hangNotEmpty 2) + [ pprUserForAll (mkTyCoVarBinders Inferred bndrs') + -- See Note [Printing foralls in type family instances] in IfaceType + , pp_lhs <+> ppr_rhs tidy_env ee_rhs + , text "-- Defined" <+> pp_loc ] + where + loc = coAxBranchSpan branch + pp_loc | isGoodSrcSpan loc = text "at" <+> ppr (srcSpanStart loc) + | otherwise = text "in" <+> ppr loc + + -- Eta-expand LHS and RHS types, because sometimes data family + -- instances are eta-reduced. + -- See Note [Eta reduction for data families] in FamInstEnv. + (ee_tvs, ee_lhs, ee_rhs) = etaExpandCoAxBranch branch + + pp_lhs = pprIfaceTypeApp topPrec (toIfaceTyCon fam_tc) + (tidyToIfaceTcArgs tidy_env fam_tc ee_lhs) + + (tidy_env, bndrs') = tidyCoAxBndrsForUser emptyTidyEnv ee_tvs + +tidyCoAxBndrsForUser :: TidyEnv -> [Var] -> (TidyEnv, [Var]) +-- Tidy wildcards "_1", "_2" to "_", and do not return them +-- in the list of binders to be printed +-- This is so that in error messages we see +-- forall a. F _ [a] _ = ... +-- rather than +-- forall a _1 _2. F _1 [a] _2 = ... +-- +-- This is a rather disgusting function +tidyCoAxBndrsForUser init_env tcvs + = (tidy_env, reverse tidy_bndrs) + where + (tidy_env, tidy_bndrs) = foldl tidy_one (init_env, []) tcvs + + tidy_one (env@(occ_env, subst), rev_bndrs') bndr + | is_wildcard bndr = (env_wild, rev_bndrs') + | otherwise = (env', bndr' : rev_bndrs') + where + (env', bndr') = tidyVarBndr env bndr + env_wild = (occ_env, extendVarEnv subst bndr wild_bndr) + wild_bndr = setVarName bndr $ + tidyNameOcc (varName bndr) (mkTyVarOcc "_") + -- Tidy the binder to "_" + + is_wildcard :: Var -> Bool + is_wildcard tv = case occNameString (getOccName tv) of + ('_' : rest) -> all isDigit rest + _ -> False + +{- +%************************************************************************ +%* * + Destructing coercions +%* * +%************************************************************************ + +Note [Function coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Remember that + (->) :: forall r1 r2. TYPE r1 -> TYPE r2 -> TYPE LiftedRep + +Hence + FunCo r co1 co2 :: (s1->t1) ~r (s2->t2) +is short for + TyConAppCo (->) co_rep1 co_rep2 co1 co2 +where co_rep1, co_rep2 are the coercions on the representations. +-} + + +-- | This breaks a 'Coercion' with type @T A B C ~ T D E F@ into +-- a list of 'Coercion's of kinds @A ~ D@, @B ~ E@ and @E ~ F@. Hence: +-- +-- > decomposeCo 3 c [r1, r2, r3] = [nth r1 0 c, nth r2 1 c, nth r3 2 c] +decomposeCo :: Arity -> Coercion + -> [Role] -- the roles of the output coercions + -- this must have at least as many + -- entries as the Arity provided + -> [Coercion] +decomposeCo arity co rs + = [mkNthCo r n co | (n,r) <- [0..(arity-1)] `zip` rs ] + -- Remember, Nth is zero-indexed + +decomposeFunCo :: HasDebugCallStack + => Role -- Role of the input coercion + -> Coercion -- Input coercion + -> (Coercion, Coercion) +-- Expects co :: (s1 -> t1) ~ (s2 -> t2) +-- Returns (co1 :: s1~s2, co2 :: t1~t2) +-- See Note [Function coercions] for the "2" and "3" +decomposeFunCo r co = ASSERT2( all_ok, ppr co ) + (mkNthCo r 2 co, mkNthCo r 3 co) + where + Pair s1t1 s2t2 = coercionKind co + all_ok = isFunTy s1t1 && isFunTy s2t2 + +{- Note [Pushing a coercion into a pi-type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have this: + (f |> co) t1 .. tn +Then we want to push the coercion into the arguments, so as to make +progress. For example of why you might want to do so, see Note +[Respecting definitional equality] in TyCoRep. + +This is done by decomposePiCos. Specifically, if + decomposePiCos co [t1,..,tn] = ([co1,...,cok], cor) +then + (f |> co) t1 .. tn = (f (t1 |> co1) ... (tk |> cok)) |> cor) t(k+1) ... tn + +Notes: + +* k can be smaller than n! That is decomposePiCos can return *fewer* + coercions than there are arguments (ie k < n), if the kind provided + doesn't have enough binders. + +* If there is a type error, we might see + (f |> co) t1 + where co :: (forall a. ty) ~ (ty1 -> ty2) + Here 'co' is insoluble, but we don't want to crash in decoposePiCos. + So decomposePiCos carefully tests both sides of the coercion to check + they are both foralls or both arrows. Not doing this caused #15343. +-} + +decomposePiCos :: HasDebugCallStack + => CoercionN -> Pair Type -- Coercion and its kind + -> [Type] + -> ([CoercionN], CoercionN) +-- See Note [Pushing a coercion into a pi-type] +decomposePiCos orig_co (Pair orig_k1 orig_k2) orig_args + = go [] (orig_subst,orig_k1) orig_co (orig_subst,orig_k2) orig_args + where + orig_subst = mkEmptyTCvSubst $ mkInScopeSet $ + tyCoVarsOfTypes orig_args `unionVarSet` tyCoVarsOfCo orig_co + + go :: [CoercionN] -- accumulator for argument coercions, reversed + -> (TCvSubst,Kind) -- Lhs kind of coercion + -> CoercionN -- coercion originally applied to the function + -> (TCvSubst,Kind) -- Rhs kind of coercion + -> [Type] -- Arguments to that function + -> ([CoercionN], Coercion) + -- Invariant: co :: subst1(k2) ~ subst2(k2) + + go acc_arg_cos (subst1,k1) co (subst2,k2) (ty:tys) + | Just (a, t1) <- splitForAllTy_maybe k1 + , Just (b, t2) <- splitForAllTy_maybe k2 + -- know co :: (forall a:s1.t1) ~ (forall b:s2.t2) + -- function :: forall a:s1.t1 (the function is not passed to decomposePiCos) + -- a :: s1 + -- b :: s2 + -- ty :: s2 + -- need arg_co :: s2 ~ s1 + -- res_co :: t1[ty |> arg_co / a] ~ t2[ty / b] + = let arg_co = mkNthCo Nominal 0 (mkSymCo co) + res_co = mkInstCo co (mkGReflLeftCo Nominal ty arg_co) + subst1' = extendTCvSubst subst1 a (ty `CastTy` arg_co) + subst2' = extendTCvSubst subst2 b ty + in + go (arg_co : acc_arg_cos) (subst1', t1) res_co (subst2', t2) tys + + | Just (_s1, t1) <- splitFunTy_maybe k1 + , Just (_s2, t2) <- splitFunTy_maybe k2 + -- know co :: (s1 -> t1) ~ (s2 -> t2) + -- function :: s1 -> t1 + -- ty :: s2 + -- need arg_co :: s2 ~ s1 + -- res_co :: t1 ~ t2 + = let (sym_arg_co, res_co) = decomposeFunCo Nominal co + arg_co = mkSymCo sym_arg_co + in + go (arg_co : acc_arg_cos) (subst1,t1) res_co (subst2,t2) tys + + | not (isEmptyTCvSubst subst1) || not (isEmptyTCvSubst subst2) + = go acc_arg_cos (zapTCvSubst subst1, substTy subst1 k1) + co + (zapTCvSubst subst2, substTy subst1 k2) + (ty:tys) + + -- tys might not be empty, if the left-hand type of the original coercion + -- didn't have enough binders + go acc_arg_cos _ki1 co _ki2 _tys = (reverse acc_arg_cos, co) + +-- | Attempts to obtain the type variable underlying a 'Coercion' +getCoVar_maybe :: Coercion -> Maybe CoVar +getCoVar_maybe (CoVarCo cv) = Just cv +getCoVar_maybe _ = Nothing + +-- | Attempts to tease a coercion apart into a type constructor and the application +-- of a number of coercion arguments to that constructor +splitTyConAppCo_maybe :: Coercion -> Maybe (TyCon, [Coercion]) +splitTyConAppCo_maybe co + | Just (ty, r) <- isReflCo_maybe co + = do { (tc, tys) <- splitTyConApp_maybe ty + ; let args = zipWith mkReflCo (tyConRolesX r tc) tys + ; return (tc, args) } +splitTyConAppCo_maybe (TyConAppCo _ tc cos) = Just (tc, cos) +splitTyConAppCo_maybe (FunCo _ arg res) = Just (funTyCon, cos) + where cos = [mkRuntimeRepCo arg, mkRuntimeRepCo res, arg, res] +splitTyConAppCo_maybe _ = Nothing + +-- first result has role equal to input; third result is Nominal +splitAppCo_maybe :: Coercion -> Maybe (Coercion, Coercion) +-- ^ Attempt to take a coercion application apart. +splitAppCo_maybe (AppCo co arg) = Just (co, arg) +splitAppCo_maybe (TyConAppCo r tc args) + | args `lengthExceeds` tyConArity tc + , Just (args', arg') <- snocView args + = Just ( mkTyConAppCo r tc args', arg' ) + + | not (mustBeSaturated tc) + -- Never create unsaturated type family apps! + , Just (args', arg') <- snocView args + , Just arg'' <- setNominalRole_maybe (nthRole r tc (length args')) arg' + = Just ( mkTyConAppCo r tc args', arg'' ) + -- Use mkTyConAppCo to preserve the invariant + -- that identity coercions are always represented by Refl + +splitAppCo_maybe co + | Just (ty, r) <- isReflCo_maybe co + , Just (ty1, ty2) <- splitAppTy_maybe ty + = Just (mkReflCo r ty1, mkNomReflCo ty2) +splitAppCo_maybe _ = Nothing + +splitFunCo_maybe :: Coercion -> Maybe (Coercion, Coercion) +splitFunCo_maybe (FunCo _ arg res) = Just (arg, res) +splitFunCo_maybe _ = Nothing + +splitForAllCo_maybe :: Coercion -> Maybe (TyCoVar, Coercion, Coercion) +splitForAllCo_maybe (ForAllCo tv k_co co) = Just (tv, k_co, co) +splitForAllCo_maybe _ = Nothing + +-- | Like 'splitForAllCo_maybe', but only returns Just for tyvar binder +splitForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, Coercion, Coercion) +splitForAllCo_ty_maybe (ForAllCo tv k_co co) + | isTyVar tv = Just (tv, k_co, co) +splitForAllCo_ty_maybe _ = Nothing + +-- | Like 'splitForAllCo_maybe', but only returns Just for covar binder +splitForAllCo_co_maybe :: Coercion -> Maybe (CoVar, Coercion, Coercion) +splitForAllCo_co_maybe (ForAllCo cv k_co co) + | isCoVar cv = Just (cv, k_co, co) +splitForAllCo_co_maybe _ = Nothing + +------------------------------------------------------- +-- and some coercion kind stuff + +coVarTypes :: HasDebugCallStack => CoVar -> Pair Type +coVarTypes cv + | (_, _, ty1, ty2, _) <- coVarKindsTypesRole cv + = Pair ty1 ty2 + +coVarKindsTypesRole :: HasDebugCallStack => CoVar -> (Kind,Kind,Type,Type,Role) +coVarKindsTypesRole cv + | Just (tc, [k1,k2,ty1,ty2]) <- splitTyConApp_maybe (varType cv) + = let role + | tc `hasKey` eqPrimTyConKey = Nominal + | tc `hasKey` eqReprPrimTyConKey = Representational + | otherwise = panic "coVarKindsTypesRole" + in (k1,k2,ty1,ty2,role) + | otherwise = pprPanic "coVarKindsTypesRole, non coercion variable" + (ppr cv $$ ppr (varType cv)) + +coVarKind :: CoVar -> Type +coVarKind cv + = ASSERT( isCoVar cv ) + varType cv + +coVarRole :: CoVar -> Role +coVarRole cv + | tc `hasKey` eqPrimTyConKey + = Nominal + | tc `hasKey` eqReprPrimTyConKey + = Representational + | otherwise + = pprPanic "coVarRole: unknown tycon" (ppr cv <+> dcolon <+> ppr (varType cv)) + + where + tc = case tyConAppTyCon_maybe (varType cv) of + Just tc0 -> tc0 + Nothing -> pprPanic "coVarRole: not tyconapp" (ppr cv) + +-- | Makes a coercion type from two types: the types whose equality +-- is proven by the relevant 'Coercion' +mkCoercionType :: Role -> Type -> Type -> Type +mkCoercionType Nominal = mkPrimEqPred +mkCoercionType Representational = mkReprPrimEqPred +mkCoercionType Phantom = \ty1 ty2 -> + let ki1 = typeKind ty1 + ki2 = typeKind ty2 + in + TyConApp eqPhantPrimTyCon [ki1, ki2, ty1, ty2] + +mkHeteroCoercionType :: Role -> Kind -> Kind -> Type -> Type -> Type +mkHeteroCoercionType Nominal = mkHeteroPrimEqPred +mkHeteroCoercionType Representational = mkHeteroReprPrimEqPred +mkHeteroCoercionType Phantom = panic "mkHeteroCoercionType" + +-- | Given a coercion @co1 :: (a :: TYPE r1) ~ (b :: TYPE r2)@, +-- produce a coercion @rep_co :: r1 ~ r2@. +mkRuntimeRepCo :: HasDebugCallStack => Coercion -> Coercion +mkRuntimeRepCo co + = mkNthCo Nominal 0 kind_co + where + kind_co = mkKindCo co -- kind_co :: TYPE r1 ~ TYPE r2 + -- (up to silliness with Constraint) + +isReflCoVar_maybe :: Var -> Maybe Coercion +-- If cv :: t~t then isReflCoVar_maybe cv = Just (Refl t) +-- Works on all kinds of Vars, not just CoVars +isReflCoVar_maybe cv + | isCoVar cv + , Pair ty1 ty2 <- coVarTypes cv + , ty1 `eqType` ty2 + = Just (mkReflCo (coVarRole cv) ty1) + | otherwise + = Nothing + +-- | Tests if this coercion is obviously a generalized reflexive coercion. +-- Guaranteed to work very quickly. +isGReflCo :: Coercion -> Bool +isGReflCo (GRefl{}) = True +isGReflCo (Refl{}) = True -- Refl ty == GRefl N ty MRefl +isGReflCo _ = False + +-- | Tests if this MCoercion is obviously generalized reflexive +-- Guaranteed to work very quickly. +isGReflMCo :: MCoercion -> Bool +isGReflMCo MRefl = True +isGReflMCo (MCo co) | isGReflCo co = True +isGReflMCo _ = False + +-- | Tests if this coercion is obviously reflexive. Guaranteed to work +-- very quickly. Sometimes a coercion can be reflexive, but not obviously +-- so. c.f. 'isReflexiveCo' +isReflCo :: Coercion -> Bool +isReflCo (Refl{}) = True +isReflCo (GRefl _ _ mco) | isGReflMCo mco = True +isReflCo _ = False + +-- | Returns the type coerced if this coercion is a generalized reflexive +-- coercion. Guaranteed to work very quickly. +isGReflCo_maybe :: Coercion -> Maybe (Type, Role) +isGReflCo_maybe (GRefl r ty _) = Just (ty, r) +isGReflCo_maybe (Refl ty) = Just (ty, Nominal) +isGReflCo_maybe _ = Nothing + +-- | Returns the type coerced if this coercion is reflexive. Guaranteed +-- to work very quickly. Sometimes a coercion can be reflexive, but not +-- obviously so. c.f. 'isReflexiveCo_maybe' +isReflCo_maybe :: Coercion -> Maybe (Type, Role) +isReflCo_maybe (Refl ty) = Just (ty, Nominal) +isReflCo_maybe (GRefl r ty mco) | isGReflMCo mco = Just (ty, r) +isReflCo_maybe _ = Nothing + +-- | Slowly checks if the coercion is reflexive. Don't call this in a loop, +-- as it walks over the entire coercion. +isReflexiveCo :: Coercion -> Bool +isReflexiveCo = isJust . isReflexiveCo_maybe + +-- | Extracts the coerced type from a reflexive coercion. This potentially +-- walks over the entire coercion, so avoid doing this in a loop. +isReflexiveCo_maybe :: Coercion -> Maybe (Type, Role) +isReflexiveCo_maybe (Refl ty) = Just (ty, Nominal) +isReflexiveCo_maybe (GRefl r ty mco) | isGReflMCo mco = Just (ty, r) +isReflexiveCo_maybe co + | ty1 `eqType` ty2 + = Just (ty1, r) + | otherwise + = Nothing + where (Pair ty1 ty2, r) = coercionKindRole co + +{- +%************************************************************************ +%* * + Building coercions +%* * +%************************************************************************ + +These "smart constructors" maintain the invariants listed in the definition +of Coercion, and they perform very basic optimizations. + +Note [Role twiddling functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +There are a plethora of functions for twiddling roles: + +mkSubCo: Requires a nominal input coercion and always produces a +representational output. This is used when you (the programmer) are sure you +know exactly that role you have and what you want. + +downgradeRole_maybe: This function takes both the input role and the output role +as parameters. (The *output* role comes first!) It can only *downgrade* a +role -- that is, change it from N to R or P, or from R to P. This one-way +behavior is why there is the "_maybe". If an upgrade is requested, this +function produces Nothing. This is used when you need to change the role of a +coercion, but you're not sure (as you're writing the code) of which roles are +involved. + +This function could have been written using coercionRole to ascertain the role +of the input. But, that function is recursive, and the caller of downgradeRole_maybe +often knows the input role. So, this is more efficient. + +downgradeRole: This is just like downgradeRole_maybe, but it panics if the +conversion isn't a downgrade. + +setNominalRole_maybe: This is the only function that can *upgrade* a coercion. +The result (if it exists) is always Nominal. The input can be at any role. It +works on a "best effort" basis, as it should never be strictly necessary to +upgrade a coercion during compilation. It is currently only used within GHC in +splitAppCo_maybe. In order to be a proper inverse of mkAppCo, the second +coercion that splitAppCo_maybe returns must be nominal. But, it's conceivable +that splitAppCo_maybe is operating over a TyConAppCo that uses a +representational coercion. Hence the need for setNominalRole_maybe. +splitAppCo_maybe, in turn, is used only within coercion optimization -- thus, +it is not absolutely critical that setNominalRole_maybe be complete. + +Note that setNominalRole_maybe will never upgrade a phantom UnivCo. Phantom +UnivCos are perfectly type-safe, whereas representational and nominal ones are +not. Indeed, `unsafeCoerce` is implemented via a representational UnivCo. +(Nominal ones are no worse than representational ones, so this function *will* +change a UnivCo Representational to a UnivCo Nominal.) + +Conal Elliott also came across a need for this function while working with the +GHC API, as he was decomposing Core casts. The Core casts use representational +coercions, as they must, but his use case required nominal coercions (he was +building a GADT). So, that's why this function is exported from this module. + +One might ask: shouldn't downgradeRole_maybe just use setNominalRole_maybe as +appropriate? I (Richard E.) have decided not to do this, because upgrading a +role is bizarre and a caller should have to ask for this behavior explicitly. + +-} + +-- | Make a generalized reflexive coercion +mkGReflCo :: Role -> Type -> MCoercionN -> Coercion +mkGReflCo r ty mco + | isGReflMCo mco = if r == Nominal then Refl ty + else GRefl r ty MRefl + | otherwise = GRefl r ty mco + +-- | Make a reflexive coercion +mkReflCo :: Role -> Type -> Coercion +mkReflCo Nominal ty = Refl ty +mkReflCo r ty = GRefl r ty MRefl + +-- | Make a representational reflexive coercion +mkRepReflCo :: Type -> Coercion +mkRepReflCo ty = GRefl Representational ty MRefl + +-- | Make a nominal reflexive coercion +mkNomReflCo :: Type -> Coercion +mkNomReflCo = Refl + +-- | Apply a type constructor to a list of coercions. It is the +-- caller's responsibility to get the roles correct on argument coercions. +mkTyConAppCo :: HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion +mkTyConAppCo r tc cos + | tc `hasKey` funTyConKey + , [_rep1, _rep2, co1, co2] <- cos -- See Note [Function coercions] + = -- (a :: TYPE ra) -> (b :: TYPE rb) ~ (c :: TYPE rc) -> (d :: TYPE rd) + -- rep1 :: ra ~ rc rep2 :: rb ~ rd + -- co1 :: a ~ c co2 :: b ~ d + mkFunCo r co1 co2 + + -- Expand type synonyms + | Just (tv_co_prs, rhs_ty, leftover_cos) <- expandSynTyCon_maybe tc cos + = mkAppCos (liftCoSubst r (mkLiftingContext tv_co_prs) rhs_ty) leftover_cos + + | Just tys_roles <- traverse isReflCo_maybe cos + = mkReflCo r (mkTyConApp tc (map fst tys_roles)) + -- See Note [Refl invariant] + + | otherwise = TyConAppCo r tc cos + +-- | Build a function 'Coercion' from two other 'Coercion's. That is, +-- given @co1 :: a ~ b@ and @co2 :: x ~ y@ produce @co :: (a -> x) ~ (b -> y)@. +mkFunCo :: Role -> Coercion -> Coercion -> Coercion +mkFunCo r co1 co2 + -- See Note [Refl invariant] + | Just (ty1, _) <- isReflCo_maybe co1 + , Just (ty2, _) <- isReflCo_maybe co2 + = mkReflCo r (mkVisFunTy ty1 ty2) + | otherwise = FunCo r co1 co2 + +-- | Apply a 'Coercion' to another 'Coercion'. +-- The second coercion must be Nominal, unless the first is Phantom. +-- If the first is Phantom, then the second can be either Phantom or Nominal. +mkAppCo :: Coercion -- ^ :: t1 ~r t2 + -> Coercion -- ^ :: s1 ~N s2, where s1 :: k1, s2 :: k2 + -> Coercion -- ^ :: t1 s1 ~r t2 s2 +mkAppCo co arg + | Just (ty1, r) <- isReflCo_maybe co + , Just (ty2, _) <- isReflCo_maybe arg + = mkReflCo r (mkAppTy ty1 ty2) + + | Just (ty1, r) <- isReflCo_maybe co + , Just (tc, tys) <- splitTyConApp_maybe ty1 + -- Expand type synonyms; a TyConAppCo can't have a type synonym (#9102) + = mkTyConAppCo r tc (zip_roles (tyConRolesX r tc) tys) + where + zip_roles (r1:_) [] = [downgradeRole r1 Nominal arg] + zip_roles (r1:rs) (ty1:tys) = mkReflCo r1 ty1 : zip_roles rs tys + zip_roles _ _ = panic "zip_roles" -- but the roles are infinite... + +mkAppCo (TyConAppCo r tc args) arg + = case r of + Nominal -> mkTyConAppCo Nominal tc (args ++ [arg]) + Representational -> mkTyConAppCo Representational tc (args ++ [arg']) + where new_role = (tyConRolesRepresentational tc) !! (length args) + arg' = downgradeRole new_role Nominal arg + Phantom -> mkTyConAppCo Phantom tc (args ++ [toPhantomCo arg]) +mkAppCo co arg = AppCo co arg +-- Note, mkAppCo is careful to maintain invariants regarding +-- where Refl constructors appear; see the comments in the definition +-- of Coercion and the Note [Refl invariant] in TyCoRep. + +-- | Applies multiple 'Coercion's to another 'Coercion', from left to right. +-- See also 'mkAppCo'. +mkAppCos :: Coercion + -> [Coercion] + -> Coercion +mkAppCos co1 cos = foldl' mkAppCo co1 cos + +{- Note [Unused coercion variable in ForAllCo] + +See Note [Unused coercion variable in ForAllTy] in TyCoRep for the motivation for +checking coercion variable in types. +To lift the design choice to (ForAllCo cv kind_co body_co), we have two options: + +(1) In mkForAllCo, we check whether cv is a coercion variable + and whether it is not used in body_co. If so we construct a FunCo. +(2) We don't do this check in mkForAllCo. + In coercionKind, we use mkTyCoForAllTy to perform the check and construct + a FunTy when necessary. + +We chose (2) for two reasons: + +* for a coercion, all that matters is its kind, So ForAllCo or FunCo does not + make a difference. +* even if cv occurs in body_co, it is possible that cv does not occur in the kind + of body_co. Therefore the check in coercionKind is inevitable. + +The last wrinkle is that there are restrictions around the use of the cv in the +coercion, as described in Section 5.8.5.2 of Richard's thesis. The idea is that +we cannot prove that the type system is consistent with unrestricted use of this +cv; the consistency proof uses an untyped rewrite relation that works over types +with all coercions and casts removed. So, we can allow the cv to appear only in +positions that are erased. As an approximation of this (and keeping close to the +published theory), we currently allow the cv only within the type in a Refl node +and under a GRefl node (including in the Coercion stored in a GRefl). It's +possible other places are OK, too, but this is a safe approximation. + +Sadly, with heterogeneous equality, this restriction might be able to be violated; +Richard's thesis is unable to prove that it isn't. Specifically, the liftCoSubst +function might create an invalid coercion. Because a violation of the +restriction might lead to a program that "goes wrong", it is checked all the time, +even in a production compiler and without -dcore-list. We *have* proved that the +problem does not occur with homogeneous equality, so this check can be dropped +once ~# is made to be homogeneous. +-} + + +-- | Make a Coercion from a tycovar, a kind coercion, and a body coercion. +-- The kind of the tycovar should be the left-hand kind of the kind coercion. +-- See Note [Unused coercion variable in ForAllCo] +mkForAllCo :: TyCoVar -> CoercionN -> Coercion -> Coercion +mkForAllCo v kind_co co + | ASSERT( varType v `eqType` (pFst $ coercionKind kind_co)) True + , ASSERT( isTyVar v || almostDevoidCoVarOfCo v co) True + , Just (ty, r) <- isReflCo_maybe co + , isGReflCo kind_co + = mkReflCo r (mkTyCoInvForAllTy v ty) + | otherwise + = ForAllCo v kind_co co + +-- | Like 'mkForAllCo', but the inner coercion shouldn't be an obvious +-- reflexive coercion. For example, it is guaranteed in 'mkForAllCos'. +-- The kind of the tycovar should be the left-hand kind of the kind coercion. +mkForAllCo_NoRefl :: TyCoVar -> CoercionN -> Coercion -> Coercion +mkForAllCo_NoRefl v kind_co co + | ASSERT( varType v `eqType` (pFst $ coercionKind kind_co)) True + , ASSERT( isTyVar v || almostDevoidCoVarOfCo v co) True + , ASSERT( not (isReflCo co)) True + , isCoVar v + , not (v `elemVarSet` tyCoVarsOfCo co) + = FunCo (coercionRole co) kind_co co + | otherwise + = ForAllCo v kind_co co + +-- | Make nested ForAllCos +mkForAllCos :: [(TyCoVar, CoercionN)] -> Coercion -> Coercion +mkForAllCos bndrs co + | Just (ty, r ) <- isReflCo_maybe co + = let (refls_rev'd, non_refls_rev'd) = span (isReflCo . snd) (reverse bndrs) in + foldl' (flip $ uncurry mkForAllCo_NoRefl) + (mkReflCo r (mkTyCoInvForAllTys (reverse (map fst refls_rev'd)) ty)) + non_refls_rev'd + | otherwise + = foldr (uncurry mkForAllCo_NoRefl) co bndrs + +-- | Make a Coercion quantified over a type/coercion variable; +-- the variable has the same type in both sides of the coercion +mkHomoForAllCos :: [TyCoVar] -> Coercion -> Coercion +mkHomoForAllCos vs co + | Just (ty, r) <- isReflCo_maybe co + = mkReflCo r (mkTyCoInvForAllTys vs ty) + | otherwise + = mkHomoForAllCos_NoRefl vs co + +-- | Like 'mkHomoForAllCos', but the inner coercion shouldn't be an obvious +-- reflexive coercion. For example, it is guaranteed in 'mkHomoForAllCos'. +mkHomoForAllCos_NoRefl :: [TyCoVar] -> Coercion -> Coercion +mkHomoForAllCos_NoRefl vs orig_co + = ASSERT( not (isReflCo orig_co)) + foldr go orig_co vs + where + go v co = mkForAllCo_NoRefl v (mkNomReflCo (varType v)) co + +mkCoVarCo :: CoVar -> Coercion +-- cv :: s ~# t +-- See Note [mkCoVarCo] +mkCoVarCo cv = CoVarCo cv + +mkCoVarCos :: [CoVar] -> [Coercion] +mkCoVarCos = map mkCoVarCo + +{- Note [mkCoVarCo] +~~~~~~~~~~~~~~~~~~~ +In the past, mkCoVarCo optimised (c :: t~t) to (Refl t). That is +valid (although see Note [Unbound RULE binders] in Rules), but +it's a relatively expensive test and perhaps better done in +optCoercion. Not a big deal either way. +-} + +-- | Extract a covar, if possible. This check is dirty. Be ashamed +-- of yourself. (It's dirty because it cares about the structure of +-- a coercion, which is morally reprehensible.) +isCoVar_maybe :: Coercion -> Maybe CoVar +isCoVar_maybe (CoVarCo cv) = Just cv +isCoVar_maybe _ = Nothing + +mkAxInstCo :: Role -> CoAxiom br -> BranchIndex -> [Type] -> [Coercion] + -> Coercion +-- mkAxInstCo can legitimately be called over-staturated; +-- i.e. with more type arguments than the coercion requires +mkAxInstCo role ax index tys cos + | arity == n_tys = downgradeRole role ax_role $ + mkAxiomInstCo ax_br index (rtys `chkAppend` cos) + | otherwise = ASSERT( arity < n_tys ) + downgradeRole role ax_role $ + mkAppCos (mkAxiomInstCo ax_br index + (ax_args `chkAppend` cos)) + leftover_args + where + n_tys = length tys + ax_br = toBranchedAxiom ax + branch = coAxiomNthBranch ax_br index + tvs = coAxBranchTyVars branch + arity = length tvs + arg_roles = coAxBranchRoles branch + rtys = zipWith mkReflCo (arg_roles ++ repeat Nominal) tys + (ax_args, leftover_args) + = splitAt arity rtys + ax_role = coAxiomRole ax + +-- worker function +mkAxiomInstCo :: CoAxiom Branched -> BranchIndex -> [Coercion] -> Coercion +mkAxiomInstCo ax index args + = ASSERT( args `lengthIs` coAxiomArity ax index ) + AxiomInstCo ax index args + +-- to be used only with unbranched axioms +mkUnbranchedAxInstCo :: Role -> CoAxiom Unbranched + -> [Type] -> [Coercion] -> Coercion +mkUnbranchedAxInstCo role ax tys cos + = mkAxInstCo role ax 0 tys cos + +mkAxInstRHS :: CoAxiom br -> BranchIndex -> [Type] -> [Coercion] -> Type +-- Instantiate the axiom with specified types, +-- returning the instantiated RHS +-- A companion to mkAxInstCo: +-- mkAxInstRhs ax index tys = snd (coercionKind (mkAxInstCo ax index tys)) +mkAxInstRHS ax index tys cos + = ASSERT( tvs `equalLength` tys1 ) + mkAppTys rhs' tys2 + where + branch = coAxiomNthBranch ax index + tvs = coAxBranchTyVars branch + cvs = coAxBranchCoVars branch + (tys1, tys2) = splitAtList tvs tys + rhs' = substTyWith tvs tys1 $ + substTyWithCoVars cvs cos $ + coAxBranchRHS branch + +mkUnbranchedAxInstRHS :: CoAxiom Unbranched -> [Type] -> [Coercion] -> Type +mkUnbranchedAxInstRHS ax = mkAxInstRHS ax 0 + +-- | Return the left-hand type of the axiom, when the axiom is instantiated +-- at the types given. +mkAxInstLHS :: CoAxiom br -> BranchIndex -> [Type] -> [Coercion] -> Type +mkAxInstLHS ax index tys cos + = ASSERT( tvs `equalLength` tys1 ) + mkTyConApp fam_tc (lhs_tys `chkAppend` tys2) + where + branch = coAxiomNthBranch ax index + tvs = coAxBranchTyVars branch + cvs = coAxBranchCoVars branch + (tys1, tys2) = splitAtList tvs tys + lhs_tys = substTysWith tvs tys1 $ + substTysWithCoVars cvs cos $ + coAxBranchLHS branch + fam_tc = coAxiomTyCon ax + +-- | Instantiate the left-hand side of an unbranched axiom +mkUnbranchedAxInstLHS :: CoAxiom Unbranched -> [Type] -> [Coercion] -> Type +mkUnbranchedAxInstLHS ax = mkAxInstLHS ax 0 + +-- | Manufacture an unsafe coercion from thin air. +-- Currently (May 14) this is used only to implement the +-- @unsafeCoerce#@ primitive. Optimise by pushing +-- down through type constructors. +mkUnsafeCo :: Role -> Type -> Type -> Coercion +mkUnsafeCo role ty1 ty2 + = mkUnivCo UnsafeCoerceProv role ty1 ty2 + +-- | Make a coercion from a coercion hole +mkHoleCo :: CoercionHole -> Coercion +mkHoleCo h = HoleCo h + +-- | Make a universal coercion between two arbitrary types. +mkUnivCo :: UnivCoProvenance + -> Role -- ^ role of the built coercion, "r" + -> Type -- ^ t1 :: k1 + -> Type -- ^ t2 :: k2 + -> Coercion -- ^ :: t1 ~r t2 +mkUnivCo prov role ty1 ty2 + | ty1 `eqType` ty2 = mkReflCo role ty1 + | otherwise = UnivCo prov role ty1 ty2 + +-- | Create a symmetric version of the given 'Coercion' that asserts +-- equality between the same types but in the other "direction", so +-- a kind of @t1 ~ t2@ becomes the kind @t2 ~ t1@. +mkSymCo :: Coercion -> Coercion + +-- Do a few simple optimizations, but don't bother pushing occurrences +-- of symmetry to the leaves; the optimizer will take care of that. +mkSymCo co | isReflCo co = co +mkSymCo (SymCo co) = co +mkSymCo (SubCo (SymCo co)) = SubCo co +mkSymCo co = SymCo co + +-- | Create a new 'Coercion' by composing the two given 'Coercion's transitively. +-- (co1 ; co2) +mkTransCo :: Coercion -> Coercion -> Coercion +mkTransCo co1 co2 | isReflCo co1 = co2 + | isReflCo co2 = co1 +mkTransCo (GRefl r t1 (MCo co1)) (GRefl _ _ (MCo co2)) + = GRefl r t1 (MCo $ mkTransCo co1 co2) +mkTransCo co1 co2 = TransCo co1 co2 + +-- | Compose two MCoercions via transitivity +mkTransMCo :: MCoercion -> MCoercion -> MCoercion +mkTransMCo MRefl co2 = co2 +mkTransMCo co1 MRefl = co1 +mkTransMCo (MCo co1) (MCo co2) = MCo (mkTransCo co1 co2) + +mkNthCo :: HasDebugCallStack + => Role -- The role of the coercion you're creating + -> Int -- Zero-indexed + -> Coercion + -> Coercion +mkNthCo r n co + = ASSERT2( good_call, bad_call_msg ) + go r n co + where + Pair ty1 ty2 = coercionKind co + + go r 0 co + | Just (ty, _) <- isReflCo_maybe co + , Just (tv, _) <- splitForAllTy_maybe ty + = -- works for both tyvar and covar + ASSERT( r == Nominal ) + mkNomReflCo (varType tv) + + go r n co + | Just (ty, r0) <- isReflCo_maybe co + , let tc = tyConAppTyCon ty + = ASSERT2( ok_tc_app ty n, ppr n $$ ppr ty ) + ASSERT( nthRole r0 tc n == r ) + mkReflCo r (tyConAppArgN n ty) + where ok_tc_app :: Type -> Int -> Bool + ok_tc_app ty n + | Just (_, tys) <- splitTyConApp_maybe ty + = tys `lengthExceeds` n + | isForAllTy ty -- nth:0 pulls out a kind coercion from a hetero forall + = n == 0 + | otherwise + = False + + go r 0 (ForAllCo _ kind_co _) + = ASSERT( r == Nominal ) + kind_co + -- If co :: (forall a1:k1. t1) ~ (forall a2:k2. t2) + -- then (nth 0 co :: k1 ~N k2) + -- If co :: (forall a1:t1 ~ t2. t1) ~ (forall a2:t3 ~ t4. t2) + -- then (nth 0 co :: (t1 ~ t2) ~N (t3 ~ t4)) + + go r n co@(FunCo r0 arg res) + -- See Note [Function coercions] + -- If FunCo _ arg_co res_co :: (s1:TYPE sk1 -> s2:TYPE sk2) + -- ~ (t1:TYPE tk1 -> t2:TYPE tk2) + -- Then we want to behave as if co was + -- TyConAppCo argk_co resk_co arg_co res_co + -- where + -- argk_co :: sk1 ~ tk1 = mkNthCo 0 (mkKindCo arg_co) + -- resk_co :: sk2 ~ tk2 = mkNthCo 0 (mkKindCo res_co) + -- i.e. mkRuntimeRepCo + = case n of + 0 -> ASSERT( r == Nominal ) mkRuntimeRepCo arg + 1 -> ASSERT( r == Nominal ) mkRuntimeRepCo res + 2 -> ASSERT( r == r0 ) arg + 3 -> ASSERT( r == r0 ) res + _ -> pprPanic "mkNthCo(FunCo)" (ppr n $$ ppr co) + + go r n (TyConAppCo r0 tc arg_cos) = ASSERT2( r == nthRole r0 tc n + , (vcat [ ppr tc + , ppr arg_cos + , ppr r0 + , ppr n + , ppr r ]) ) + arg_cos `getNth` n + + go r n co = + NthCo r n co + + -- Assertion checking + bad_call_msg = vcat [ text "Coercion =" <+> ppr co + , text "LHS ty =" <+> ppr ty1 + , text "RHS ty =" <+> ppr ty2 + , text "n =" <+> ppr n, text "r =" <+> ppr r + , text "coercion role =" <+> ppr (coercionRole co) ] + good_call + -- If the Coercion passed in is between forall-types, then the Int must + -- be 0 and the role must be Nominal. + | Just (_tv1, _) <- splitForAllTy_maybe ty1 + , Just (_tv2, _) <- splitForAllTy_maybe ty2 + = n == 0 && r == Nominal + + -- If the Coercion passed in is between T tys and T tys', then the Int + -- must be less than the length of tys/tys' (which must be the same + -- lengths). + -- + -- If the role of the Coercion is nominal, then the role passed in must + -- be nominal. If the role of the Coercion is representational, then the + -- role passed in must be tyConRolesRepresentational T !! n. If the role + -- of the Coercion is Phantom, then the role passed in must be Phantom. + -- + -- See also Note [NthCo Cached Roles] if you're wondering why it's + -- blaringly obvious that we should be *computing* this role instead of + -- passing it in. + | Just (tc1, tys1) <- splitTyConApp_maybe ty1 + , Just (tc2, tys2) <- splitTyConApp_maybe ty2 + , tc1 == tc2 + = let len1 = length tys1 + len2 = length tys2 + good_role = case coercionRole co of + Nominal -> r == Nominal + Representational -> r == (tyConRolesRepresentational tc1 !! n) + Phantom -> r == Phantom + in len1 == len2 && n < len1 && good_role + + | otherwise + = True + + + +-- | If you're about to call @mkNthCo r n co@, then @r@ should be +-- whatever @nthCoRole n co@ returns. +nthCoRole :: Int -> Coercion -> Role +nthCoRole n co + | Just (tc, _) <- splitTyConApp_maybe lty + = nthRole r tc n + + | Just _ <- splitForAllTy_maybe lty + = Nominal + + | otherwise + = pprPanic "nthCoRole" (ppr co) + + where + (Pair lty _, r) = coercionKindRole co + +mkLRCo :: LeftOrRight -> Coercion -> Coercion +mkLRCo lr co + | Just (ty, eq) <- isReflCo_maybe co + = mkReflCo eq (pickLR lr (splitAppTy ty)) + | otherwise + = LRCo lr co + +-- | Instantiates a 'Coercion'. +mkInstCo :: Coercion -> Coercion -> Coercion +mkInstCo (ForAllCo tcv _kind_co body_co) co + | Just (arg, _) <- isReflCo_maybe co + -- works for both tyvar and covar + = substCoUnchecked (zipTCvSubst [tcv] [arg]) body_co +mkInstCo co arg = InstCo co arg + +-- | Given @ty :: k1@, @co :: k1 ~ k2@, +-- produces @co' :: ty ~r (ty |> co)@ +mkGReflRightCo :: Role -> Type -> CoercionN -> Coercion +mkGReflRightCo r ty co + | isGReflCo co = mkReflCo r ty + -- the kinds of @k1@ and @k2@ are the same, thus @isGReflCo@ + -- instead of @isReflCo@ + | otherwise = GRefl r ty (MCo co) + +-- | Given @ty :: k1@, @co :: k1 ~ k2@, +-- produces @co' :: (ty |> co) ~r ty@ +mkGReflLeftCo :: Role -> Type -> CoercionN -> Coercion +mkGReflLeftCo r ty co + | isGReflCo co = mkReflCo r ty + -- the kinds of @k1@ and @k2@ are the same, thus @isGReflCo@ + -- instead of @isReflCo@ + | otherwise = mkSymCo $ GRefl r ty (MCo co) + +-- | Given @ty :: k1@, @co :: k1 ~ k2@, @co2:: ty ~r ty'@, +-- produces @co' :: (ty |> co) ~r ty' +-- It is not only a utility function, but it saves allocation when co +-- is a GRefl coercion. +mkCoherenceLeftCo :: Role -> Type -> CoercionN -> Coercion -> Coercion +mkCoherenceLeftCo r ty co co2 + | isGReflCo co = co2 + | otherwise = (mkSymCo $ GRefl r ty (MCo co)) `mkTransCo` co2 + +-- | Given @ty :: k1@, @co :: k1 ~ k2@, @co2:: ty' ~r ty@, +-- produces @co' :: ty' ~r (ty |> co) +-- It is not only a utility function, but it saves allocation when co +-- is a GRefl coercion. +mkCoherenceRightCo :: Role -> Type -> CoercionN -> Coercion -> Coercion +mkCoherenceRightCo r ty co co2 + | isGReflCo co = co2 + | otherwise = co2 `mkTransCo` GRefl r ty (MCo co) + +-- | Given @co :: (a :: k) ~ (b :: k')@ produce @co' :: k ~ k'@. +mkKindCo :: Coercion -> Coercion +mkKindCo co | Just (ty, _) <- isReflCo_maybe co = Refl (typeKind ty) +mkKindCo (GRefl _ _ (MCo co)) = co +mkKindCo (UnivCo (PhantomProv h) _ _ _) = h +mkKindCo (UnivCo (ProofIrrelProv h) _ _ _) = h +mkKindCo co + | Pair ty1 ty2 <- coercionKind co + -- generally, calling coercionKind during coercion creation is a bad idea, + -- as it can lead to exponential behavior. But, we don't have nested mkKindCos, + -- so it's OK here. + , let tk1 = typeKind ty1 + tk2 = typeKind ty2 + , tk1 `eqType` tk2 + = Refl tk1 + | otherwise + = KindCo co + +mkSubCo :: Coercion -> Coercion +-- Input coercion is Nominal, result is Representational +-- see also Note [Role twiddling functions] +mkSubCo (Refl ty) = GRefl Representational ty MRefl +mkSubCo (GRefl Nominal ty co) = GRefl Representational ty co +mkSubCo (TyConAppCo Nominal tc cos) + = TyConAppCo Representational tc (applyRoles tc cos) +mkSubCo (FunCo Nominal arg res) + = FunCo Representational + (downgradeRole Representational Nominal arg) + (downgradeRole Representational Nominal res) +mkSubCo co = ASSERT2( coercionRole co == Nominal, ppr co <+> ppr (coercionRole co) ) + SubCo co + +-- | Changes a role, but only a downgrade. See Note [Role twiddling functions] +downgradeRole_maybe :: Role -- ^ desired role + -> Role -- ^ current role + -> Coercion -> Maybe Coercion +-- In (downgradeRole_maybe dr cr co) it's a precondition that +-- cr = coercionRole co + +downgradeRole_maybe Nominal Nominal co = Just co +downgradeRole_maybe Nominal _ _ = Nothing + +downgradeRole_maybe Representational Nominal co = Just (mkSubCo co) +downgradeRole_maybe Representational Representational co = Just co +downgradeRole_maybe Representational Phantom _ = Nothing + +downgradeRole_maybe Phantom Phantom co = Just co +downgradeRole_maybe Phantom _ co = Just (toPhantomCo co) + +-- | Like 'downgradeRole_maybe', but panics if the change isn't a downgrade. +-- See Note [Role twiddling functions] +downgradeRole :: Role -- desired role + -> Role -- current role + -> Coercion -> Coercion +downgradeRole r1 r2 co + = case downgradeRole_maybe r1 r2 co of + Just co' -> co' + Nothing -> pprPanic "downgradeRole" (ppr co) + +-- | If the EqRel is ReprEq, makes a SubCo; otherwise, does nothing. +-- Note that the input coercion should always be nominal. +maybeSubCo :: EqRel -> Coercion -> Coercion +maybeSubCo NomEq = id +maybeSubCo ReprEq = mkSubCo + + +mkAxiomRuleCo :: CoAxiomRule -> [Coercion] -> Coercion +mkAxiomRuleCo = AxiomRuleCo + +-- | Make a "coercion between coercions". +mkProofIrrelCo :: Role -- ^ role of the created coercion, "r" + -> Coercion -- ^ :: phi1 ~N phi2 + -> Coercion -- ^ g1 :: phi1 + -> Coercion -- ^ g2 :: phi2 + -> Coercion -- ^ :: g1 ~r g2 + +-- if the two coercion prove the same fact, I just don't care what +-- the individual coercions are. +mkProofIrrelCo r co g _ | isGReflCo co = mkReflCo r (mkCoercionTy g) + -- kco is a kind coercion, thus @isGReflCo@ rather than @isReflCo@ +mkProofIrrelCo r kco g1 g2 = mkUnivCo (ProofIrrelProv kco) r + (mkCoercionTy g1) (mkCoercionTy g2) + +{- +%************************************************************************ +%* * + Roles +%* * +%************************************************************************ +-} + +-- | Converts a coercion to be nominal, if possible. +-- See Note [Role twiddling functions] +setNominalRole_maybe :: Role -- of input coercion + -> Coercion -> Maybe Coercion +setNominalRole_maybe r co + | r == Nominal = Just co + | otherwise = setNominalRole_maybe_helper co + where + setNominalRole_maybe_helper (SubCo co) = Just co + setNominalRole_maybe_helper co@(Refl _) = Just co + setNominalRole_maybe_helper (GRefl _ ty co) = Just $ GRefl Nominal ty co + setNominalRole_maybe_helper (TyConAppCo Representational tc cos) + = do { cos' <- zipWithM setNominalRole_maybe (tyConRolesX Representational tc) cos + ; return $ TyConAppCo Nominal tc cos' } + setNominalRole_maybe_helper (FunCo Representational co1 co2) + = do { co1' <- setNominalRole_maybe Representational co1 + ; co2' <- setNominalRole_maybe Representational co2 + ; return $ FunCo Nominal co1' co2' + } + setNominalRole_maybe_helper (SymCo co) + = SymCo <$> setNominalRole_maybe_helper co + setNominalRole_maybe_helper (TransCo co1 co2) + = TransCo <$> setNominalRole_maybe_helper co1 <*> setNominalRole_maybe_helper co2 + setNominalRole_maybe_helper (AppCo co1 co2) + = AppCo <$> setNominalRole_maybe_helper co1 <*> pure co2 + setNominalRole_maybe_helper (ForAllCo tv kind_co co) + = ForAllCo tv kind_co <$> setNominalRole_maybe_helper co + setNominalRole_maybe_helper (NthCo _r n co) + -- NB, this case recurses via setNominalRole_maybe, not + -- setNominalRole_maybe_helper! + = NthCo Nominal n <$> setNominalRole_maybe (coercionRole co) co + setNominalRole_maybe_helper (InstCo co arg) + = InstCo <$> setNominalRole_maybe_helper co <*> pure arg + setNominalRole_maybe_helper (UnivCo prov _ co1 co2) + | case prov of UnsafeCoerceProv -> True -- it's always unsafe + PhantomProv _ -> False -- should always be phantom + ProofIrrelProv _ -> True -- it's always safe + PluginProv _ -> False -- who knows? This choice is conservative. + = Just $ UnivCo prov Nominal co1 co2 + setNominalRole_maybe_helper _ = Nothing + +-- | Make a phantom coercion between two types. The coercion passed +-- in must be a nominal coercion between the kinds of the +-- types. +mkPhantomCo :: Coercion -> Type -> Type -> Coercion +mkPhantomCo h t1 t2 + = mkUnivCo (PhantomProv h) Phantom t1 t2 + +-- takes any coercion and turns it into a Phantom coercion +toPhantomCo :: Coercion -> Coercion +toPhantomCo co + = mkPhantomCo (mkKindCo co) ty1 ty2 + where Pair ty1 ty2 = coercionKind co + +-- Convert args to a TyConAppCo Nominal to the same TyConAppCo Representational +applyRoles :: TyCon -> [Coercion] -> [Coercion] +applyRoles tc cos + = zipWith (\r -> downgradeRole r Nominal) (tyConRolesRepresentational tc) cos + +-- the Role parameter is the Role of the TyConAppCo +-- defined here because this is intimately concerned with the implementation +-- of TyConAppCo +-- Always returns an infinite list (with a infinite tail of Nominal) +tyConRolesX :: Role -> TyCon -> [Role] +tyConRolesX Representational tc = tyConRolesRepresentational tc +tyConRolesX role _ = repeat role + +-- Returns the roles of the parameters of a tycon, with an infinite tail +-- of Nominal +tyConRolesRepresentational :: TyCon -> [Role] +tyConRolesRepresentational tc = tyConRoles tc ++ repeat Nominal + +nthRole :: Role -> TyCon -> Int -> Role +nthRole Nominal _ _ = Nominal +nthRole Phantom _ _ = Phantom +nthRole Representational tc n + = (tyConRolesRepresentational tc) `getNth` n + +ltRole :: Role -> Role -> Bool +-- Is one role "less" than another? +-- Nominal < Representational < Phantom +ltRole Phantom _ = False +ltRole Representational Phantom = True +ltRole Representational _ = False +ltRole Nominal Nominal = False +ltRole Nominal _ = True + +------------------------------- + +-- | like mkKindCo, but aggressively & recursively optimizes to avoid using +-- a KindCo constructor. The output role is nominal. +promoteCoercion :: Coercion -> CoercionN + +-- First cases handles anything that should yield refl. +promoteCoercion co = case co of + + _ | ki1 `eqType` ki2 + -> mkNomReflCo (typeKind ty1) + -- no later branch should return refl + -- The ASSERT( False )s throughout + -- are these cases explicitly, but they should never fire. + + Refl _ -> ASSERT( False ) + mkNomReflCo ki1 + + GRefl _ _ MRefl -> ASSERT( False ) + mkNomReflCo ki1 + + GRefl _ _ (MCo co) -> co + + TyConAppCo _ tc args + | Just co' <- instCoercions (mkNomReflCo (tyConKind tc)) args + -> co' + | otherwise + -> mkKindCo co + + AppCo co1 arg + | Just co' <- instCoercion (coercionKind (mkKindCo co1)) + (promoteCoercion co1) arg + -> co' + | otherwise + -> mkKindCo co + + ForAllCo tv _ g + | isTyVar tv + -> promoteCoercion g + + ForAllCo _ _ _ + -> ASSERT( False ) + mkNomReflCo liftedTypeKind + -- See Note [Weird typing rule for ForAllTy] in Type + + FunCo _ _ _ + -> ASSERT( False ) + mkNomReflCo liftedTypeKind + + CoVarCo {} -> mkKindCo co + HoleCo {} -> mkKindCo co + AxiomInstCo {} -> mkKindCo co + AxiomRuleCo {} -> mkKindCo co + + UnivCo UnsafeCoerceProv _ t1 t2 -> mkUnsafeCo Nominal (typeKind t1) (typeKind t2) + UnivCo (PhantomProv kco) _ _ _ -> kco + UnivCo (ProofIrrelProv kco) _ _ _ -> kco + UnivCo (PluginProv _) _ _ _ -> mkKindCo co + + SymCo g + -> mkSymCo (promoteCoercion g) + + TransCo co1 co2 + -> mkTransCo (promoteCoercion co1) (promoteCoercion co2) + + NthCo _ n co1 + | Just (_, args) <- splitTyConAppCo_maybe co1 + , args `lengthExceeds` n + -> promoteCoercion (args !! n) + + | Just _ <- splitForAllCo_maybe co + , n == 0 + -> ASSERT( False ) mkNomReflCo liftedTypeKind + + | otherwise + -> mkKindCo co + + LRCo lr co1 + | Just (lco, rco) <- splitAppCo_maybe co1 + -> case lr of + CLeft -> promoteCoercion lco + CRight -> promoteCoercion rco + + | otherwise + -> mkKindCo co + + InstCo g _ + | isForAllTy_ty ty1 + -> ASSERT( isForAllTy_ty ty2 ) + promoteCoercion g + | otherwise + -> ASSERT( False) + mkNomReflCo liftedTypeKind + -- See Note [Weird typing rule for ForAllTy] in Type + + KindCo _ + -> ASSERT( False ) + mkNomReflCo liftedTypeKind + + SubCo g + -> promoteCoercion g + + where + Pair ty1 ty2 = coercionKind co + ki1 = typeKind ty1 + ki2 = typeKind ty2 + +-- | say @g = promoteCoercion h@. Then, @instCoercion g w@ yields @Just g'@, +-- where @g' = promoteCoercion (h w)@. +-- fails if this is not possible, if @g@ coerces between a forall and an -> +-- or if second parameter has a representational role and can't be used +-- with an InstCo. +instCoercion :: Pair Type -- g :: lty ~ rty + -> CoercionN -- ^ must be nominal + -> Coercion + -> Maybe CoercionN +instCoercion (Pair lty rty) g w + | (isForAllTy_ty lty && isForAllTy_ty rty) + || (isForAllTy_co lty && isForAllTy_co rty) + , Just w' <- setNominalRole_maybe (coercionRole w) w + -- g :: (forall t1. t2) ~ (forall t1. t3) + -- w :: s1 ~ s2 + -- returns mkInstCo g w' :: t2 [t1 |-> s1 ] ~ t3 [t1 |-> s2] + = Just $ mkInstCo g w' + | isFunTy lty && isFunTy rty + -- g :: (t1 -> t2) ~ (t3 -> t4) + -- returns t2 ~ t4 + = Just $ mkNthCo Nominal 3 g -- extract result type, which is the 4th argument to (->) + | otherwise -- one forall, one funty... + = Nothing + +-- | Repeated use of 'instCoercion' +instCoercions :: CoercionN -> [Coercion] -> Maybe CoercionN +instCoercions g ws + = let arg_ty_pairs = map coercionKind ws in + snd <$> foldM go (coercionKind g, g) (zip arg_ty_pairs ws) + where + go :: (Pair Type, Coercion) -> (Pair Type, Coercion) + -> Maybe (Pair Type, Coercion) + go (g_tys, g) (w_tys, w) + = do { g' <- instCoercion g_tys g w + ; return (piResultTy <$> g_tys <*> w_tys, g') } + +-- | Creates a new coercion with both of its types casted by different casts +-- @castCoercionKind g r t1 t2 h1 h2@, where @g :: t1 ~r t2@, +-- has type @(t1 |> h1) ~r (t2 |> h2)@. +-- @h1@ and @h2@ must be nominal. +castCoercionKind :: Coercion -> Role -> Type -> Type + -> CoercionN -> CoercionN -> Coercion +castCoercionKind g r t1 t2 h1 h2 + = mkCoherenceRightCo r t2 h2 (mkCoherenceLeftCo r t1 h1 g) + +-- | Creates a new coercion with both of its types casted by different casts +-- @castCoercionKind g h1 h2@, where @g :: t1 ~r t2@, +-- has type @(t1 |> h1) ~r (t2 |> h2)@. +-- @h1@ and @h2@ must be nominal. +-- It calls @coercionKindRole@, so it's quite inefficient (which 'I' stands for) +-- Use @castCoercionKind@ instead if @t1@, @t2@, and @r@ are known beforehand. +castCoercionKindI :: Coercion -> CoercionN -> CoercionN -> Coercion +castCoercionKindI g h1 h2 + = mkCoherenceRightCo r t2 h2 (mkCoherenceLeftCo r t1 h1 g) + where (Pair t1 t2, r) = coercionKindRole g + +-- See note [Newtype coercions] in TyCon + +mkPiCos :: Role -> [Var] -> Coercion -> Coercion +mkPiCos r vs co = foldr (mkPiCo r) co vs + +-- | Make a forall 'Coercion', where both types related by the coercion +-- are quantified over the same variable. +mkPiCo :: Role -> Var -> Coercion -> Coercion +mkPiCo r v co | isTyVar v = mkHomoForAllCos [v] co + | isCoVar v = ASSERT( not (v `elemVarSet` tyCoVarsOfCo co) ) + -- We didn't call mkForAllCo here because if v does not appear + -- in co, the argement coercion will be nominal. But here we + -- want it to be r. It is only called in 'mkPiCos', which is + -- only used in SimplUtils, where we are sure for + -- now (Aug 2018) v won't occur in co. + mkFunCo r (mkReflCo r (varType v)) co + | otherwise = mkFunCo r (mkReflCo r (varType v)) co + +-- mkCoCast (c :: s1 ~?r t1) (g :: (s1 ~?r t1) ~#R (s2 ~?r t2)) :: s2 ~?r t2 +-- The first coercion might be lifted or unlifted; thus the ~? above +-- Lifted and unlifted equalities take different numbers of arguments, +-- so we have to make sure to supply the right parameter to decomposeCo. +-- Also, note that the role of the first coercion is the same as the role of +-- the equalities related by the second coercion. The second coercion is +-- itself always representational. +mkCoCast :: Coercion -> CoercionR -> Coercion +mkCoCast c g + | (g2:g1:_) <- reverse co_list + = mkSymCo g1 `mkTransCo` c `mkTransCo` g2 + + | otherwise + = pprPanic "mkCoCast" (ppr g $$ ppr (coercionKind g)) + where + -- g :: (s1 ~# t1) ~# (s2 ~# t2) + -- g1 :: s1 ~# s2 + -- g2 :: t1 ~# t2 + (tc, _) = splitTyConApp (pFst $ coercionKind g) + co_list = decomposeCo (tyConArity tc) g (tyConRolesRepresentational tc) + +{- +%************************************************************************ +%* * + Newtypes +%* * +%************************************************************************ +-} + +-- | If @co :: T ts ~ rep_ty@ then: +-- +-- > instNewTyCon_maybe T ts = Just (rep_ty, co) +-- +-- Checks for a newtype, and for being saturated +instNewTyCon_maybe :: TyCon -> [Type] -> Maybe (Type, Coercion) +instNewTyCon_maybe tc tys + | Just (tvs, ty, co_tc) <- unwrapNewTyConEtad_maybe tc -- Check for newtype + , tvs `leLength` tys -- Check saturated enough + = Just (applyTysX tvs ty tys, mkUnbranchedAxInstCo Representational co_tc tys []) + | otherwise + = Nothing + +{- +************************************************************************ +* * + Type normalisation +* * +************************************************************************ +-} + +-- | A function to check if we can reduce a type by one step. Used +-- with 'topNormaliseTypeX'. +type NormaliseStepper ev = RecTcChecker + -> TyCon -- tc + -> [Type] -- tys + -> NormaliseStepResult ev + +-- | The result of stepping in a normalisation function. +-- See 'topNormaliseTypeX'. +data NormaliseStepResult ev + = NS_Done -- ^ Nothing more to do + | NS_Abort -- ^ Utter failure. The outer function should fail too. + | NS_Step RecTcChecker Type ev -- ^ We stepped, yielding new bits; + -- ^ ev is evidence; + -- Usually a co :: old type ~ new type + +mapStepResult :: (ev1 -> ev2) + -> NormaliseStepResult ev1 -> NormaliseStepResult ev2 +mapStepResult f (NS_Step rec_nts ty ev) = NS_Step rec_nts ty (f ev) +mapStepResult _ NS_Done = NS_Done +mapStepResult _ NS_Abort = NS_Abort + +-- | Try one stepper and then try the next, if the first doesn't make +-- progress. +-- So if it returns NS_Done, it means that both steppers are satisfied +composeSteppers :: NormaliseStepper ev -> NormaliseStepper ev + -> NormaliseStepper ev +composeSteppers step1 step2 rec_nts tc tys + = case step1 rec_nts tc tys of + success@(NS_Step {}) -> success + NS_Done -> step2 rec_nts tc tys + NS_Abort -> NS_Abort + +-- | A 'NormaliseStepper' that unwraps newtypes, careful not to fall into +-- a loop. If it would fall into a loop, it produces 'NS_Abort'. +unwrapNewTypeStepper :: NormaliseStepper Coercion +unwrapNewTypeStepper rec_nts tc tys + | Just (ty', co) <- instNewTyCon_maybe tc tys + = case checkRecTc rec_nts tc of + Just rec_nts' -> NS_Step rec_nts' ty' co + Nothing -> NS_Abort + + | otherwise + = NS_Done + +-- | A general function for normalising the top-level of a type. It continues +-- to use the provided 'NormaliseStepper' until that function fails, and then +-- this function returns. The roles of the coercions produced by the +-- 'NormaliseStepper' must all be the same, which is the role returned from +-- the call to 'topNormaliseTypeX'. +-- +-- Typically ev is Coercion. +-- +-- If topNormaliseTypeX step plus ty = Just (ev, ty') +-- then ty ~ev1~ t1 ~ev2~ t2 ... ~evn~ ty' +-- and ev = ev1 `plus` ev2 `plus` ... `plus` evn +-- If it returns Nothing then no newtype unwrapping could happen +topNormaliseTypeX :: NormaliseStepper ev -> (ev -> ev -> ev) + -> Type -> Maybe (ev, Type) +topNormaliseTypeX stepper plus ty + | Just (tc, tys) <- splitTyConApp_maybe ty + , NS_Step rec_nts ty' ev <- stepper initRecTc tc tys + = go rec_nts ev ty' + | otherwise + = Nothing + where + go rec_nts ev ty + | Just (tc, tys) <- splitTyConApp_maybe ty + = case stepper rec_nts tc tys of + NS_Step rec_nts' ty' ev' -> go rec_nts' (ev `plus` ev') ty' + NS_Done -> Just (ev, ty) + NS_Abort -> Nothing + + | otherwise + = Just (ev, ty) + +topNormaliseNewType_maybe :: Type -> Maybe (Coercion, Type) +-- ^ Sometimes we want to look through a @newtype@ and get its associated coercion. +-- This function strips off @newtype@ layers enough to reveal something that isn't +-- a @newtype@. Specifically, here's the invariant: +-- +-- > topNormaliseNewType_maybe rec_nts ty = Just (co, ty') +-- +-- then (a) @co : ty0 ~ ty'@. +-- (b) ty' is not a newtype. +-- +-- The function returns @Nothing@ for non-@newtypes@, +-- or unsaturated applications +-- +-- This function does *not* look through type families, because it has no access to +-- the type family environment. If you do have that at hand, consider to use +-- topNormaliseType_maybe, which should be a drop-in replacement for +-- topNormaliseNewType_maybe +-- If topNormliseNewType_maybe ty = Just (co, ty'), then co : ty ~R ty' +topNormaliseNewType_maybe ty + = topNormaliseTypeX unwrapNewTypeStepper mkTransCo ty + +{- +%************************************************************************ +%* * + Comparison of coercions +%* * +%************************************************************************ +-} + +-- | Syntactic equality of coercions +eqCoercion :: Coercion -> Coercion -> Bool +eqCoercion = eqType `on` coercionType + +-- | Compare two 'Coercion's, with respect to an RnEnv2 +eqCoercionX :: RnEnv2 -> Coercion -> Coercion -> Bool +eqCoercionX env = eqTypeX env `on` coercionType + +{- +%************************************************************************ +%* * + "Lifting" substitution + [(TyCoVar,Coercion)] -> Type -> Coercion +%* * +%************************************************************************ + +Note [Lifting coercions over types: liftCoSubst] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The KPUSH rule deals with this situation + data T a = K (a -> Maybe a) + g :: T t1 ~ T t2 + x :: t1 -> Maybe t1 + + case (K @t1 x) |> g of + K (y:t2 -> Maybe t2) -> rhs + +We want to push the coercion inside the constructor application. +So we do this + + g' :: t1~t2 = Nth 0 g + + case K @t2 (x |> g' -> Maybe g') of + K (y:t2 -> Maybe t2) -> rhs + +The crucial operation is that we + * take the type of K's argument: a -> Maybe a + * and substitute g' for a +thus giving *coercion*. This is what liftCoSubst does. + +In the presence of kind coercions, this is a bit +of a hairy operation. So, we refer you to the paper introducing kind coercions, +available at www.cis.upenn.edu/~sweirich/papers/fckinds-extended.pdf + +Note [extendLiftingContextEx] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider we have datatype + K :: \/k. \/a::k. P -> T k -- P be some type + g :: T k1 ~ T k2 + + case (K @k1 @t1 x) |> g of + K y -> rhs + +We want to push the coercion inside the constructor application. +We first get the coercion mapped by the universal type variable k: + lc = k |-> Nth 0 g :: k1~k2 + +Here, the important point is that the kind of a is coerced, and P might be +dependent on the existential type variable a. +Thus we first get the coercion of a's kind + g2 = liftCoSubst lc k :: k1 ~ k2 + +Then we store a new mapping into the lifting context + lc2 = a |-> (t1 ~ t1 |> g2), lc + +So later when we can correctly deal with the argument type P + liftCoSubst lc2 P :: P [k|->k1][a|->t1] ~ P[k|->k2][a |-> (t1|>g2)] + +This is exactly what extendLiftingContextEx does. +* For each (tyvar:k, ty) pair, we product the mapping + tyvar |-> (ty ~ ty |> (liftCoSubst lc k)) +* For each (covar:s1~s2, ty) pair, we produce the mapping + covar |-> (co ~ co') + co' = Sym (liftCoSubst lc s1) ;; covar ;; liftCoSubst lc s2 :: s1'~s2' + +This follows the lifting context extension definition in the +"FC with Explicit Kind Equality" paper. +-} + +-- ---------------------------------------------------- +-- See Note [Lifting coercions over types: liftCoSubst] +-- ---------------------------------------------------- + +data LiftingContext = LC TCvSubst LiftCoEnv + -- in optCoercion, we need to lift when optimizing InstCo. + -- See Note [Optimising InstCo] in OptCoercion + -- We thus propagate the substitution from OptCoercion here. + +instance Outputable LiftingContext where + ppr (LC _ env) = hang (text "LiftingContext:") 2 (ppr env) + +type LiftCoEnv = VarEnv Coercion + -- Maps *type variables* to *coercions*. + -- That's the whole point of this function! + -- Also maps coercion variables to ProofIrrelCos. + +-- like liftCoSubstWith, but allows for existentially-bound types as well +liftCoSubstWithEx :: Role -- desired role for output coercion + -> [TyVar] -- universally quantified tyvars + -> [Coercion] -- coercions to substitute for those + -> [TyCoVar] -- existentially quantified tycovars + -> [Type] -- types and coercions to be bound to ex vars + -> (Type -> Coercion, [Type]) -- (lifting function, converted ex args) +liftCoSubstWithEx role univs omegas exs rhos + = let theta = mkLiftingContext (zipEqual "liftCoSubstWithExU" univs omegas) + psi = extendLiftingContextEx theta (zipEqual "liftCoSubstWithExX" exs rhos) + in (ty_co_subst psi role, substTys (lcSubstRight psi) (mkTyCoVarTys exs)) + +liftCoSubstWith :: Role -> [TyCoVar] -> [Coercion] -> Type -> Coercion +liftCoSubstWith r tvs cos ty + = liftCoSubst r (mkLiftingContext $ zipEqual "liftCoSubstWith" tvs cos) ty + +-- | @liftCoSubst role lc ty@ produces a coercion (at role @role@) +-- that coerces between @lc_left(ty)@ and @lc_right(ty)@, where +-- @lc_left@ is a substitution mapping type variables to the left-hand +-- types of the mapped coercions in @lc@, and similar for @lc_right@. +liftCoSubst :: HasDebugCallStack => Role -> LiftingContext -> Type -> Coercion +liftCoSubst r lc@(LC subst env) ty + | isEmptyVarEnv env = mkReflCo r (substTy subst ty) + | otherwise = ty_co_subst lc r ty + +emptyLiftingContext :: InScopeSet -> LiftingContext +emptyLiftingContext in_scope = LC (mkEmptyTCvSubst in_scope) emptyVarEnv + +mkLiftingContext :: [(TyCoVar,Coercion)] -> LiftingContext +mkLiftingContext pairs + = LC (mkEmptyTCvSubst $ mkInScopeSet $ tyCoVarsOfCos (map snd pairs)) + (mkVarEnv pairs) + +mkSubstLiftingContext :: TCvSubst -> LiftingContext +mkSubstLiftingContext subst = LC subst emptyVarEnv + +-- | Extend a lifting context with a new mapping. +extendLiftingContext :: LiftingContext -- ^ original LC + -> TyCoVar -- ^ new variable to map... + -> Coercion -- ^ ...to this lifted version + -> LiftingContext + -- mappings to reflexive coercions are just substitutions +extendLiftingContext (LC subst env) tv arg + | Just (ty, _) <- isReflCo_maybe arg + = LC (extendTCvSubst subst tv ty) env + | otherwise + = LC subst (extendVarEnv env tv arg) + +-- | Extend a lifting context with a new mapping, and extend the in-scope set +extendLiftingContextAndInScope :: LiftingContext -- ^ Original LC + -> TyCoVar -- ^ new variable to map... + -> Coercion -- ^ to this coercion + -> LiftingContext +extendLiftingContextAndInScope (LC subst env) tv co + = extendLiftingContext (LC (extendTCvInScopeSet subst (tyCoVarsOfCo co)) env) tv co + +-- | Extend a lifting context with existential-variable bindings. +-- See Note [extendLiftingContextEx] +extendLiftingContextEx :: LiftingContext -- ^ original lifting context + -> [(TyCoVar,Type)] -- ^ ex. var / value pairs + -> LiftingContext +-- Note that this is more involved than extendLiftingContext. That function +-- takes a coercion to extend with, so it's assumed that the caller has taken +-- into account any of the kind-changing stuff worried about here. +extendLiftingContextEx lc [] = lc +extendLiftingContextEx lc@(LC subst env) ((v,ty):rest) +-- This function adds bindings for *Nominal* coercions. Why? Because it +-- works with existentially bound variables, which are considered to have +-- nominal roles. + | isTyVar v + = let lc' = LC (subst `extendTCvInScopeSet` tyCoVarsOfType ty) + (extendVarEnv env v $ + mkGReflRightCo Nominal + ty + (ty_co_subst lc Nominal (tyVarKind v))) + in extendLiftingContextEx lc' rest + | CoercionTy co <- ty + = -- co :: s1 ~r s2 + -- lift_s1 :: s1 ~r s1' + -- lift_s2 :: s2 ~r s2' + -- kco :: (s1 ~r s2) ~N (s1' ~r s2') + ASSERT( isCoVar v ) + let (_, _, s1, s2, r) = coVarKindsTypesRole v + lift_s1 = ty_co_subst lc r s1 + lift_s2 = ty_co_subst lc r s2 + kco = mkTyConAppCo Nominal (equalityTyCon r) + [ mkKindCo lift_s1, mkKindCo lift_s2 + , lift_s1 , lift_s2 ] + lc' = LC (subst `extendTCvInScopeSet` tyCoVarsOfCo co) + (extendVarEnv env v + (mkProofIrrelCo Nominal kco co $ + (mkSymCo lift_s1) `mkTransCo` co `mkTransCo` lift_s2)) + in extendLiftingContextEx lc' rest + | otherwise + = pprPanic "extendLiftingContextEx" (ppr v <+> text "|->" <+> ppr ty) + + +-- | Erase the environments in a lifting context +zapLiftingContext :: LiftingContext -> LiftingContext +zapLiftingContext (LC subst _) = LC (zapTCvSubst subst) emptyVarEnv + +-- | Like 'substForAllCoBndr', but works on a lifting context +substForAllCoBndrUsingLC :: Bool + -> (Coercion -> Coercion) + -> LiftingContext -> TyCoVar -> Coercion + -> (LiftingContext, TyCoVar, Coercion) +substForAllCoBndrUsingLC sym sco (LC subst lc_env) tv co + = (LC subst' lc_env, tv', co') + where + (subst', tv', co') = substForAllCoBndrUsing sym sco subst tv co + +-- | The \"lifting\" operation which substitutes coercions for type +-- variables in a type to produce a coercion. +-- +-- For the inverse operation, see 'liftCoMatch' +ty_co_subst :: LiftingContext -> Role -> Type -> Coercion +ty_co_subst lc role ty + = go role ty + where + go :: Role -> Type -> Coercion + go r ty | Just ty' <- coreView ty + = go r ty' + go Phantom ty = lift_phantom ty + go r (TyVarTy tv) = expectJust "ty_co_subst bad roles" $ + liftCoSubstTyVar lc r tv + go r (AppTy ty1 ty2) = mkAppCo (go r ty1) (go Nominal ty2) + go r (TyConApp tc tys) = mkTyConAppCo r tc (zipWith go (tyConRolesX r tc) tys) + go r (FunTy _ ty1 ty2) = mkFunCo r (go r ty1) (go r ty2) + go r t@(ForAllTy (Bndr v _) ty) + = let (lc', v', h) = liftCoSubstVarBndr lc v + body_co = ty_co_subst lc' r ty in + if isTyVar v' || almostDevoidCoVarOfCo v' body_co + -- Lifting a ForAllTy over a coercion variable could fail as ForAllCo + -- imposes an extra restriction on where a covar can appear. See last + -- wrinkle in Note [Unused coercion variable in ForAllCo]. + -- We specifically check for this and panic because we know that + -- there's a hole in the type system here, and we'd rather panic than + -- fall into it. + then mkForAllCo v' h body_co + else pprPanic "ty_co_subst: covar is not almost devoid" (ppr t) + go r ty@(LitTy {}) = ASSERT( r == Nominal ) + mkNomReflCo ty + go r (CastTy ty co) = castCoercionKindI (go r ty) (substLeftCo lc co) + (substRightCo lc co) + go r (CoercionTy co) = mkProofIrrelCo r kco (substLeftCo lc co) + (substRightCo lc co) + where kco = go Nominal (coercionType co) + + lift_phantom ty = mkPhantomCo (go Nominal (typeKind ty)) + (substTy (lcSubstLeft lc) ty) + (substTy (lcSubstRight lc) ty) + +{- +Note [liftCoSubstTyVar] +~~~~~~~~~~~~~~~~~~~~~~~~~ +This function can fail if a coercion in the environment is of too low a role. + +liftCoSubstTyVar is called from two places: in liftCoSubst (naturally), and +also in matchAxiom in OptCoercion. From liftCoSubst, the so-called lifting +lemma guarantees that the roles work out. If we fail in this +case, we really should panic -- something is deeply wrong. But, in matchAxiom, +failing is fine. matchAxiom is trying to find a set of coercions +that match, but it may fail, and this is healthy behavior. +-} + +-- See Note [liftCoSubstTyVar] +liftCoSubstTyVar :: LiftingContext -> Role -> TyVar -> Maybe Coercion +liftCoSubstTyVar (LC subst env) r v + | Just co_arg <- lookupVarEnv env v + = downgradeRole_maybe r (coercionRole co_arg) co_arg + + | otherwise + = Just $ mkReflCo r (substTyVar subst v) + +{- Note [liftCoSubstVarBndr] + +callback: + We want 'liftCoSubstVarBndrUsing' to be general enough to be reused in + FamInstEnv, therefore the input arg 'fun' returns a pair with polymophic type + in snd. + However in 'liftCoSubstVarBndr', we don't need the snd, so we use unit and + ignore the fourth component of the return value. + +liftCoSubstTyVarBndrUsing: + Given + forall tv:k. t + We want to get + forall (tv:k1) (kind_co :: k1 ~ k2) body_co + + We lift the kind k to get the kind_co + kind_co = ty_co_subst k :: k1 ~ k2 + + Now in the LiftingContext, we add the new mapping + tv |-> (tv :: k1) ~ ((tv |> kind_co) :: k2) + +liftCoSubstCoVarBndrUsing: + Given + forall cv:(s1 ~ s2). t + We want to get + forall (cv:s1'~s2') (kind_co :: (s1'~s2') ~ (t1 ~ t2)) body_co + + We lift s1 and s2 respectively to get + eta1 :: s1' ~ t1 + eta2 :: s2' ~ t2 + And + kind_co = TyConAppCo Nominal (~#) eta1 eta2 + + Now in the liftingContext, we add the new mapping + cv |-> (cv :: s1' ~ s2') ~ ((sym eta1;cv;eta2) :: t1 ~ t2) +-} + +-- See Note [liftCoSubstVarBndr] +liftCoSubstVarBndr :: LiftingContext -> TyCoVar + -> (LiftingContext, TyCoVar, Coercion) +liftCoSubstVarBndr lc tv + = let (lc', tv', h, _) = liftCoSubstVarBndrUsing callback lc tv in + (lc', tv', h) + where + callback lc' ty' = (ty_co_subst lc' Nominal ty', ()) + +-- the callback must produce a nominal coercion +liftCoSubstVarBndrUsing :: (LiftingContext -> Type -> (CoercionN, a)) + -> LiftingContext -> TyCoVar + -> (LiftingContext, TyCoVar, CoercionN, a) +liftCoSubstVarBndrUsing fun lc old_var + | isTyVar old_var + = liftCoSubstTyVarBndrUsing fun lc old_var + | otherwise + = liftCoSubstCoVarBndrUsing fun lc old_var + +-- Works for tyvar binder +liftCoSubstTyVarBndrUsing :: (LiftingContext -> Type -> (CoercionN, a)) + -> LiftingContext -> TyVar + -> (LiftingContext, TyVar, CoercionN, a) +liftCoSubstTyVarBndrUsing fun lc@(LC subst cenv) old_var + = ASSERT( isTyVar old_var ) + ( LC (subst `extendTCvInScope` new_var) new_cenv + , new_var, eta, stuff ) + where + old_kind = tyVarKind old_var + (eta, stuff) = fun lc old_kind + Pair k1 _ = coercionKind eta + new_var = uniqAway (getTCvInScope subst) (setVarType old_var k1) + + lifted = mkGReflRightCo Nominal (TyVarTy new_var) eta + -- :: new_var ~ new_var |> eta + new_cenv = extendVarEnv cenv old_var lifted + +-- Works for covar binder +liftCoSubstCoVarBndrUsing :: (LiftingContext -> Type -> (CoercionN, a)) + -> LiftingContext -> CoVar + -> (LiftingContext, CoVar, CoercionN, a) +liftCoSubstCoVarBndrUsing fun lc@(LC subst cenv) old_var + = ASSERT( isCoVar old_var ) + ( LC (subst `extendTCvInScope` new_var) new_cenv + , new_var, kind_co, stuff ) + where + old_kind = coVarKind old_var + (eta, stuff) = fun lc old_kind + Pair k1 _ = coercionKind eta + new_var = uniqAway (getTCvInScope subst) (setVarType old_var k1) + + -- old_var :: s1 ~r s2 + -- eta :: (s1' ~r s2') ~N (t1 ~r t2) + -- eta1 :: s1' ~r t1 + -- eta2 :: s2' ~r t2 + -- co1 :: s1' ~r s2' + -- co2 :: t1 ~r t2 + -- kind_co :: (s1' ~r s2') ~N (t1 ~r t2) + -- lifted :: co1 ~N co2 + + role = coVarRole old_var + eta' = downgradeRole role Nominal eta + eta1 = mkNthCo role 2 eta' + eta2 = mkNthCo role 3 eta' + + co1 = mkCoVarCo new_var + co2 = mkSymCo eta1 `mkTransCo` co1 `mkTransCo` eta2 + kind_co = mkTyConAppCo Nominal (equalityTyCon role) + [ mkKindCo co1, mkKindCo co2 + , co1 , co2 ] + lifted = mkProofIrrelCo Nominal kind_co co1 co2 + + new_cenv = extendVarEnv cenv old_var lifted + +-- | Is a var in the domain of a lifting context? +isMappedByLC :: TyCoVar -> LiftingContext -> Bool +isMappedByLC tv (LC _ env) = tv `elemVarEnv` env + +-- If [a |-> g] is in the substitution and g :: t1 ~ t2, substitute a for t1 +-- If [a |-> (g1, g2)] is in the substitution, substitute a for g1 +substLeftCo :: LiftingContext -> Coercion -> Coercion +substLeftCo lc co + = substCo (lcSubstLeft lc) co + +-- Ditto, but for t2 and g2 +substRightCo :: LiftingContext -> Coercion -> Coercion +substRightCo lc co + = substCo (lcSubstRight lc) co + +-- | Apply "sym" to all coercions in a 'LiftCoEnv' +swapLiftCoEnv :: LiftCoEnv -> LiftCoEnv +swapLiftCoEnv = mapVarEnv mkSymCo + +lcSubstLeft :: LiftingContext -> TCvSubst +lcSubstLeft (LC subst lc_env) = liftEnvSubstLeft subst lc_env + +lcSubstRight :: LiftingContext -> TCvSubst +lcSubstRight (LC subst lc_env) = liftEnvSubstRight subst lc_env + +liftEnvSubstLeft :: TCvSubst -> LiftCoEnv -> TCvSubst +liftEnvSubstLeft = liftEnvSubst pFst + +liftEnvSubstRight :: TCvSubst -> LiftCoEnv -> TCvSubst +liftEnvSubstRight = liftEnvSubst pSnd + +liftEnvSubst :: (forall a. Pair a -> a) -> TCvSubst -> LiftCoEnv -> TCvSubst +liftEnvSubst selector subst lc_env + = composeTCvSubst (TCvSubst emptyInScopeSet tenv cenv) subst + where + pairs = nonDetUFMToList lc_env + -- It's OK to use nonDetUFMToList here because we + -- immediately forget the ordering by creating + -- a VarEnv + (tpairs, cpairs) = partitionWith ty_or_co pairs + tenv = mkVarEnv_Directly tpairs + cenv = mkVarEnv_Directly cpairs + + ty_or_co :: (Unique, Coercion) -> Either (Unique, Type) (Unique, Coercion) + ty_or_co (u, co) + | Just equality_co <- isCoercionTy_maybe equality_ty + = Right (u, equality_co) + | otherwise + = Left (u, equality_ty) + where + equality_ty = selector (coercionKind co) + +-- | Extract the underlying substitution from the LiftingContext +lcTCvSubst :: LiftingContext -> TCvSubst +lcTCvSubst (LC subst _) = subst + +-- | Get the 'InScopeSet' from a 'LiftingContext' +lcInScopeSet :: LiftingContext -> InScopeSet +lcInScopeSet (LC subst _) = getTCvInScope subst + +{- +%************************************************************************ +%* * + Sequencing on coercions +%* * +%************************************************************************ +-} + +seqMCo :: MCoercion -> () +seqMCo MRefl = () +seqMCo (MCo co) = seqCo co + +seqCo :: Coercion -> () +seqCo (Refl ty) = seqType ty +seqCo (GRefl r ty mco) = r `seq` seqType ty `seq` seqMCo mco +seqCo (TyConAppCo r tc cos) = r `seq` tc `seq` seqCos cos +seqCo (AppCo co1 co2) = seqCo co1 `seq` seqCo co2 +seqCo (ForAllCo tv k co) = seqType (varType tv) `seq` seqCo k + `seq` seqCo co +seqCo (FunCo r co1 co2) = r `seq` seqCo co1 `seq` seqCo co2 +seqCo (CoVarCo cv) = cv `seq` () +seqCo (HoleCo h) = coHoleCoVar h `seq` () +seqCo (AxiomInstCo con ind cos) = con `seq` ind `seq` seqCos cos +seqCo (UnivCo p r t1 t2) + = seqProv p `seq` r `seq` seqType t1 `seq` seqType t2 +seqCo (SymCo co) = seqCo co +seqCo (TransCo co1 co2) = seqCo co1 `seq` seqCo co2 +seqCo (NthCo r n co) = r `seq` n `seq` seqCo co +seqCo (LRCo lr co) = lr `seq` seqCo co +seqCo (InstCo co arg) = seqCo co `seq` seqCo arg +seqCo (KindCo co) = seqCo co +seqCo (SubCo co) = seqCo co +seqCo (AxiomRuleCo _ cs) = seqCos cs + +seqProv :: UnivCoProvenance -> () +seqProv UnsafeCoerceProv = () +seqProv (PhantomProv co) = seqCo co +seqProv (ProofIrrelProv co) = seqCo co +seqProv (PluginProv _) = () + +seqCos :: [Coercion] -> () +seqCos [] = () +seqCos (co:cos) = seqCo co `seq` seqCos cos + +{- +%************************************************************************ +%* * + The kind of a type, and of a coercion +%* * +%************************************************************************ +-} + +coercionType :: Coercion -> Type +coercionType co = case coercionKindRole co of + (Pair ty1 ty2, r) -> mkCoercionType r ty1 ty2 + +------------------ +-- | If it is the case that +-- +-- > c :: (t1 ~ t2) +-- +-- i.e. the kind of @c@ relates @t1@ and @t2@, then @coercionKind c = Pair t1 t2@. + +coercionKind :: Coercion -> Pair Type +coercionKind co = + go co + where + go (Refl ty) = Pair ty ty + go (GRefl _ ty MRefl) = Pair ty ty + go (GRefl _ ty (MCo co1)) = Pair ty (mkCastTy ty co1) + go (TyConAppCo _ tc cos)= mkTyConApp tc <$> (sequenceA $ map go cos) + go (AppCo co1 co2) = mkAppTy <$> go co1 <*> go co2 + go co@(ForAllCo tv1 k_co co1) -- works for both tyvar and covar + | isGReflCo k_co = mkTyCoInvForAllTy tv1 <$> go co1 + -- kind_co always has kind @Type@, thus @isGReflCo@ + | otherwise = go_forall empty_subst co + where + empty_subst = mkEmptyTCvSubst (mkInScopeSet $ tyCoVarsOfCo co) + go (FunCo _ co1 co2) = mkVisFunTy <$> go co1 <*> go co2 + go (CoVarCo cv) = coVarTypes cv + go (HoleCo h) = coVarTypes (coHoleCoVar h) + go (AxiomInstCo ax ind cos) + | CoAxBranch { cab_tvs = tvs, cab_cvs = cvs + , cab_lhs = lhs, cab_rhs = rhs } <- coAxiomNthBranch ax ind + , let Pair tycos1 tycos2 = sequenceA (map go cos) + (tys1, cotys1) = splitAtList tvs tycos1 + (tys2, cotys2) = splitAtList tvs tycos2 + cos1 = map stripCoercionTy cotys1 + cos2 = map stripCoercionTy cotys2 + = ASSERT( cos `equalLength` (tvs ++ cvs) ) + -- Invariant of AxiomInstCo: cos should + -- exactly saturate the axiom branch + Pair (substTyWith tvs tys1 $ + substTyWithCoVars cvs cos1 $ + mkTyConApp (coAxiomTyCon ax) lhs) + (substTyWith tvs tys2 $ + substTyWithCoVars cvs cos2 rhs) + go (UnivCo _ _ ty1 ty2) = Pair ty1 ty2 + go (SymCo co) = swap $ go co + go (TransCo co1 co2) = Pair (pFst $ go co1) (pSnd $ go co2) + go g@(NthCo _ d co) + | Just argss <- traverse tyConAppArgs_maybe tys + = ASSERT( and $ (`lengthExceeds` d) <$> argss ) + (`getNth` d) <$> argss + + | d == 0 + , Just splits <- traverse splitForAllTy_maybe tys + = (tyVarKind . fst) <$> splits + + | otherwise + = pprPanic "coercionKind" (ppr g) + where + tys = go co + go (LRCo lr co) = (pickLR lr . splitAppTy) <$> go co + go (InstCo aco arg) = go_app aco [arg] + go (KindCo co) = typeKind <$> go co + go (SubCo co) = go co + go (AxiomRuleCo ax cos) = expectJust "coercionKind" $ + coaxrProves ax (map go cos) + + go_app :: Coercion -> [Coercion] -> Pair Type + -- Collect up all the arguments and apply all at once + -- See Note [Nested InstCos] + go_app (InstCo co arg) args = go_app co (arg:args) + go_app co args = piResultTys <$> go co <*> (sequenceA $ map go args) + + go_forall subst (ForAllCo tv1 k_co co) + -- See Note [Nested ForAllCos] + | isTyVar tv1 + = mkInvForAllTy <$> Pair tv1 tv2 <*> go_forall subst' co + where + Pair _ k2 = go k_co + tv2 = setTyVarKind tv1 (substTy subst k2) + subst' | isGReflCo k_co = extendTCvInScope subst tv1 + -- kind_co always has kind @Type@, thus @isGReflCo@ + | otherwise = extendTvSubst (extendTCvInScope subst tv2) tv1 $ + TyVarTy tv2 `mkCastTy` mkSymCo k_co + go_forall subst (ForAllCo cv1 k_co co) + | isCoVar cv1 + = mkTyCoInvForAllTy <$> Pair cv1 cv2 <*> go_forall subst' co + where + Pair _ k2 = go k_co + r = coVarRole cv1 + eta1 = mkNthCo r 2 (downgradeRole r Nominal k_co) + eta2 = mkNthCo r 3 (downgradeRole r Nominal k_co) + + -- k_co :: (t1 ~r t2) ~N (s1 ~r s2) + -- k1 = t1 ~r t2 + -- k2 = s1 ~r s2 + -- cv1 :: t1 ~r t2 + -- cv2 :: s1 ~r s2 + -- eta1 :: t1 ~r s1 + -- eta2 :: t2 ~r s2 + -- n_subst = (eta1 ; cv2 ; sym eta2) :: t1 ~r t2 + + cv2 = setVarType cv1 (substTy subst k2) + n_subst = eta1 `mkTransCo` (mkCoVarCo cv2) `mkTransCo` (mkSymCo eta2) + subst' | isReflCo k_co = extendTCvInScope subst cv1 + | otherwise = extendCvSubst (extendTCvInScope subst cv2) + cv1 n_subst + + go_forall subst other_co + -- when other_co is not a ForAllCo + = substTy subst `pLiftSnd` go other_co + +{- + +Note [Nested ForAllCos] +~~~~~~~~~~~~~~~~~~~~~~~ + +Suppose we need `coercionKind (ForAllCo a1 (ForAllCo a2 ... (ForAllCo an +co)...) )`. We do not want to perform `n` single-type-variable +substitutions over the kind of `co`; rather we want to do one substitution +which substitutes for all of `a1`, `a2` ... simultaneously. If we do one +at a time we get the performance hole reported in #11735. + +Solution: gather up the type variables for nested `ForAllCos`, and +substitute for them all at once. Remarkably, for #11735 this single +change reduces /total/ compile time by a factor of more than ten. + +-} + +-- | Apply 'coercionKind' to multiple 'Coercion's +coercionKinds :: [Coercion] -> Pair [Type] +coercionKinds tys = sequenceA $ map coercionKind tys + +-- | Get a coercion's kind and role. +coercionKindRole :: Coercion -> (Pair Type, Role) +coercionKindRole co = (coercionKind co, coercionRole co) + +-- | Retrieve the role from a coercion. +coercionRole :: Coercion -> Role +coercionRole = go + where + go (Refl _) = Nominal + go (GRefl r _ _) = r + go (TyConAppCo r _ _) = r + go (AppCo co1 _) = go co1 + go (ForAllCo _ _ co) = go co + go (FunCo r _ _) = r + go (CoVarCo cv) = coVarRole cv + go (HoleCo h) = coVarRole (coHoleCoVar h) + go (AxiomInstCo ax _ _) = coAxiomRole ax + go (UnivCo _ r _ _) = r + go (SymCo co) = go co + go (TransCo co1 _co2) = go co1 + go (NthCo r _d _co) = r + go (LRCo {}) = Nominal + go (InstCo co _) = go co + go (KindCo {}) = Nominal + go (SubCo _) = Representational + go (AxiomRuleCo ax _) = coaxrRole ax + +{- +Note [Nested InstCos] +~~~~~~~~~~~~~~~~~~~~~ +In #5631 we found that 70% of the entire compilation time was +being spent in coercionKind! The reason was that we had + (g @ ty1 @ ty2 .. @ ty100) -- The "@s" are InstCos +where + g :: forall a1 a2 .. a100. phi +If we deal with the InstCos one at a time, we'll do this: + 1. Find the kind of (g @ ty1 .. @ ty99) : forall a100. phi' + 2. Substitute phi'[ ty100/a100 ], a single tyvar->type subst +But this is a *quadratic* algorithm, and the blew up #5631. +So it's very important to do the substitution simultaneously; +cf Type.piResultTys (which in fact we call here). + +-} + +-- | Assuming that two types are the same, ignoring coercions, find +-- a nominal coercion between the types. This is useful when optimizing +-- transitivity over coercion applications, where splitting two +-- AppCos might yield different kinds. See Note [EtaAppCo] in OptCoercion. +buildCoercion :: Type -> Type -> CoercionN +buildCoercion orig_ty1 orig_ty2 = go orig_ty1 orig_ty2 + where + go ty1 ty2 | Just ty1' <- coreView ty1 = go ty1' ty2 + | Just ty2' <- coreView ty2 = go ty1 ty2' + + go (CastTy ty1 co) ty2 + = let co' = go ty1 ty2 + r = coercionRole co' + in mkCoherenceLeftCo r ty1 co co' + + go ty1 (CastTy ty2 co) + = let co' = go ty1 ty2 + r = coercionRole co' + in mkCoherenceRightCo r ty2 co co' + + go ty1@(TyVarTy tv1) _tyvarty + = ASSERT( case _tyvarty of + { TyVarTy tv2 -> tv1 == tv2 + ; _ -> False } ) + mkNomReflCo ty1 + + go (FunTy { ft_arg = arg1, ft_res = res1 }) + (FunTy { ft_arg = arg2, ft_res = res2 }) + = mkFunCo Nominal (go arg1 arg2) (go res1 res2) + + go (TyConApp tc1 args1) (TyConApp tc2 args2) + = ASSERT( tc1 == tc2 ) + mkTyConAppCo Nominal tc1 (zipWith go args1 args2) + + go (AppTy ty1a ty1b) ty2 + | Just (ty2a, ty2b) <- repSplitAppTy_maybe ty2 + = mkAppCo (go ty1a ty2a) (go ty1b ty2b) + + go ty1 (AppTy ty2a ty2b) + | Just (ty1a, ty1b) <- repSplitAppTy_maybe ty1 + = mkAppCo (go ty1a ty2a) (go ty1b ty2b) + + go (ForAllTy (Bndr tv1 _flag1) ty1) (ForAllTy (Bndr tv2 _flag2) ty2) + | isTyVar tv1 + = ASSERT( isTyVar tv2 ) + mkForAllCo tv1 kind_co (go ty1 ty2') + where kind_co = go (tyVarKind tv1) (tyVarKind tv2) + in_scope = mkInScopeSet $ tyCoVarsOfType ty2 `unionVarSet` tyCoVarsOfCo kind_co + ty2' = substTyWithInScope in_scope [tv2] + [mkTyVarTy tv1 `mkCastTy` kind_co] + ty2 + + go (ForAllTy (Bndr cv1 _flag1) ty1) (ForAllTy (Bndr cv2 _flag2) ty2) + = ASSERT( isCoVar cv1 && isCoVar cv2 ) + mkForAllCo cv1 kind_co (go ty1 ty2') + where s1 = varType cv1 + s2 = varType cv2 + kind_co = go s1 s2 + + -- s1 = t1 ~r t2 + -- s2 = t3 ~r t4 + -- kind_co :: (t1 ~r t2) ~N (t3 ~r t4) + -- eta1 :: t1 ~r t3 + -- eta2 :: t2 ~r t4 + + r = coVarRole cv1 + kind_co' = downgradeRole r Nominal kind_co + eta1 = mkNthCo r 2 kind_co' + eta2 = mkNthCo r 3 kind_co' + + subst = mkEmptyTCvSubst $ mkInScopeSet $ + tyCoVarsOfType ty2 `unionVarSet` tyCoVarsOfCo kind_co + ty2' = substTy (extendCvSubst subst cv2 $ mkSymCo eta1 `mkTransCo` + mkCoVarCo cv1 `mkTransCo` + eta2) + ty2 + + go ty1@(LitTy lit1) _lit2 + = ASSERT( case _lit2 of + { LitTy lit2 -> lit1 == lit2 + ; _ -> False } ) + mkNomReflCo ty1 + + go (CoercionTy co1) (CoercionTy co2) + = mkProofIrrelCo Nominal kind_co co1 co2 + where + kind_co = go (coercionType co1) (coercionType co2) + + go ty1 ty2 + = pprPanic "buildKindCoercion" (vcat [ ppr orig_ty1, ppr orig_ty2 + , ppr ty1, ppr ty2 ]) + +{- +%************************************************************************ +%* * + Simplifying types +%* * +%************************************************************************ + +The function below morally belongs in TcFlatten, but it is used also in +FamInstEnv, and so lives here. + +Note [simplifyArgsWorker] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Invariant (F2) of Note [Flattening] says that flattening is homogeneous. +This causes some trouble when flattening a function applied to a telescope +of arguments, perhaps with dependency. For example, suppose + + type family F :: forall (j :: Type) (k :: Type). Maybe j -> Either j k -> Bool -> [k] + +and we wish to flatten the args of (with kind applications explicit) + + F a b (Just a c) (Right a b d) False + +where all variables are skolems and + + a :: Type + b :: Type + c :: a + d :: k + + [G] aco :: a ~ fa + [G] bco :: b ~ fb + [G] cco :: c ~ fc + [G] dco :: d ~ fd + +The first step is to flatten all the arguments. This is done before calling +simplifyArgsWorker. We start from + + a + b + Just a c + Right a b d + False + +and get + + (fa, co1 :: fa ~ a) + (fb, co2 :: fb ~ b) + (Just fa (fc |> aco) |> co6, co3 :: (Just fa (fc |> aco) |> co6) ~ (Just a c)) + (Right fa fb (fd |> bco) |> co7, co4 :: (Right fa fb (fd |> bco) |> co7) ~ (Right a b d)) + (False, co5 :: False ~ False) + +where + co6 :: Maybe fa ~ Maybe a + co7 :: Either fa fb ~ Either a b + +We now process the flattened args in left-to-right order. The first two args +need no further processing. But now consider the third argument. Let f3 = the flattened +result, Just fa (fc |> aco) |> co6. +This f3 flattened argument has kind (Maybe a), due to +(F2). And yet, when we build the application (F fa fb ...), we need this +argument to have kind (Maybe fa), not (Maybe a). We must cast this argument. +The coercion to use is +determined by the kind of F: we see in F's kind that the third argument has +kind Maybe j. Critically, we also know that the argument corresponding to j +(in our example, a) flattened with a coercion co1. We can thus know the +coercion needed for the 3rd argument is (Maybe (sym co1)), thus building +(f3 |> Maybe (sym co1)) + +More generally, we must use the Lifting Lemma, as implemented in +Coercion.liftCoSubst. As we work left-to-right, any variable that is a +dependent parameter (j and k, in our example) gets mapped in a lifting context +to the coercion that is output from flattening the corresponding argument (co1 +and co2, in our example). Then, after flattening later arguments, we lift the +kind of these arguments in the lifting context that we've be building up. +This coercion is then used to keep the result of flattening well-kinded. + +Working through our example, this is what happens: + + 1. Extend the (empty) LC with [j |-> co1]. No new casting must be done, + because the binder associated with the first argument has a closed type (no + variables). + + 2. Extend the LC with [k |-> co2]. No casting to do. + + 3. Lifting the kind (Maybe j) with our LC + yields co8 :: Maybe fa ~ Maybe a. Use (f3 |> sym co8) as the argument to + F. + + 4. Lifting the kind (Either j k) with our LC + yields co9 :: Either fa fb ~ Either a b. Use (f4 |> sym co9) as the 4th + argument to F, where f4 is the flattened form of argument 4, written above. + + 5. We lift Bool with our LC, getting ; + casting has no effect. + +We're now almost done, but the new application (F fa fb (f3 |> sym co8) (f4 > sym co9) False) +has the wrong kind. Its kind is [fb], instead of the original [b]. +So we must use our LC one last time to lift the result kind [k], +getting res_co :: [fb] ~ [b], and we cast our result. + +Accordingly, the final result is + + F fa fb (Just fa (fc |> aco) |> Maybe (sym aco) |> sym (Maybe (sym aco))) + (Right fa fb (fd |> bco) |> Either (sym aco) (sym bco) |> sym (Either (sym aco) (sym bco))) + False + |> [sym bco] + +The res_co (in this case, [sym bco]) +is returned as the third return value from simplifyArgsWorker. + +Note [Last case in simplifyArgsWorker] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In writing simplifyArgsWorker's `go`, we know here that args cannot be empty, +because that case is first. We've run out of +binders. But perhaps inner_ki is a tyvar that has been instantiated with a +Π-type. + +Here is an example. + + a :: forall (k :: Type). k -> k + type family Star + Proxy :: forall j. j -> Type + axStar :: Star ~ Type + type family NoWay :: Bool + axNoWay :: NoWay ~ False + bo :: Type + [G] bc :: bo ~ Bool (in inert set) + + co :: (forall j. j -> Type) ~ (forall (j :: Star). (j |> axStar) -> Star) + co = forall (j :: sym axStar). ( -> sym axStar) + + We are flattening: + a (forall (j :: Star). (j |> axStar) -> Star) -- 1 + (Proxy |> co) -- 2 + (bo |> sym axStar) -- 3 + (NoWay |> sym bc) -- 4 + :: Star + +First, we flatten all the arguments (before simplifyArgsWorker), like so: + + (forall j. j -> Type, co1 :: (forall j. j -> Type) ~ + (forall (j :: Star). (j |> axStar) -> Star)) -- 1 + (Proxy |> co, co2 :: (Proxy |> co) ~ (Proxy |> co)) -- 2 + (Bool |> sym axStar, co3 :: (Bool |> sym axStar) ~ (bo |> sym axStar)) -- 3 + (False |> sym bc, co4 :: (False |> sym bc) ~ (NoWay |> sym bc)) -- 4 + +Then we do the process described in Note [simplifyArgsWorker]. + +1. Lifting Type (the kind of the first arg) gives us a reflexive coercion, so we + don't use it. But we do build a lifting context [k -> co1] (where co1 is a + result of flattening an argument, written above). + +2. Lifting k gives us co1, so the second argument becomes (Proxy |> co |> sym co1). + This is not a dependent argument, so we don't extend the lifting context. + +Now we need to deal with argument (3). After flattening, should we tack on a homogenizing +coercion? The way we normally tell is to lift the kind of the binder. +But here, the remainder of the kind of `a` that we're left with +after processing two arguments is just `k`. + +The way forward is look up k in the lifting context, getting co1. If we're at +all well-typed, co1 will be a coercion between Π-types, with at least one binder. +So, let's +decompose co1 with decomposePiCos. This decomposition needs arguments to use +to instantiate any kind parameters. Look at the type of co1. If we just +decomposed it, we would end up with coercions whose types include j, which is +out of scope here. Accordingly, decomposePiCos takes a list of types whose +kinds are the *right-hand* types in the decomposed coercion. (See comments on +decomposePiCos.) Because the flattened types have unflattened kinds (because +flattening is homogeneous), passing the list of flattened types to decomposePiCos +just won't do: later arguments' kinds won't be as expected. So we need to get +the *unflattened* types to pass to decomposePiCos. We can do this easily enough +by taking the kind of the argument coercions, passed in originally. + +(Alternative 1: We could re-engineer decomposePiCos to deal with this situation. +But that function is already gnarly, and taking the right-hand types is correct +at its other call sites, which are much more common than this one.) + +(Alternative 2: We could avoid calling decomposePiCos entirely, integrating its +behavior into simplifyArgsWorker. This would work, I think, but then all of the +complication of decomposePiCos would end up layered on top of all the complication +here. Please, no.) + +(Alternative 3: We could pass the unflattened arguments into simplifyArgsWorker +so that we don't have to recreate them. But that would complicate the interface +of this function to handle a very dark, dark corner case. Better to keep our +demons to ourselves here instead of exposing them to callers. This decision is +easily reversed if there is ever any performance trouble due to the call of +coercionKind.) + +So we now call + + decomposePiCos co1 + (Pair (forall j. j -> Type) (forall (j :: Star). (j |> axStar) -> Star)) + [bo |> sym axStar, NoWay |> sym bc] + +to get + + co5 :: Star ~ Type + co6 :: (j |> axStar) ~ (j |> co5), substituted to + (bo |> sym axStar |> axStar) ~ (bo |> sym axStar |> co5) + == bo ~ bo + res_co :: Type ~ Star + +We then use these casts on (the flattened) (3) and (4) to get + + (Bool |> sym axStar |> co5 :: Type) -- (C3) + (False |> sym bc |> co6 :: bo) -- (C4) + +We can simplify to + + Bool -- (C3) + (False |> sym bc :: bo) -- (C4) + +Of course, we still must do the processing in Note [simplifyArgsWorker] to finish +the job. We thus want to recur. Our new function kind is the left-hand type of +co1 (gotten, recall, by lifting the variable k that was the return kind of the +original function). Why the left-hand type (as opposed to the right-hand type)? +Because we have casted all the arguments according to decomposePiCos, which gets +us from the right-hand type to the left-hand one. We thus recur with that new +function kind, zapping our lifting context, because we have essentially applied +it. + +This recursive call returns ([Bool, False], [...], Refl). The Bool and False +are the correct arguments we wish to return. But we must be careful about the +result coercion: our new, flattened application will have kind Type, but we +want to make sure that the result coercion casts this back to Star. (Why? +Because we started with an application of kind Star, and flattening is homogeneous.) + +So, we have to twiddle the result coercion appropriately. + +Let's check whether this is well-typed. We know + + a :: forall (k :: Type). k -> k + + a (forall j. j -> Type) :: (forall j. j -> Type) -> forall j. j -> Type + + a (forall j. j -> Type) + Proxy + :: forall j. j -> Type + + a (forall j. j -> Type) + Proxy + Bool + :: Bool -> Type + + a (forall j. j -> Type) + Proxy + Bool + False + :: Type + + a (forall j. j -> Type) + Proxy + Bool + False + |> res_co + :: Star + +as desired. + +Whew. + +-} + + +-- This is shared between the flattener and the normaliser in FamInstEnv. +-- See Note [simplifyArgsWorker] +{-# INLINE simplifyArgsWorker #-} +simplifyArgsWorker :: [TyCoBinder] -> Kind + -- the binders & result kind (not a Π-type) of the function applied to the args + -- list of binders can be shorter or longer than the list of args + -> TyCoVarSet -- free vars of the args + -> [Role] -- list of roles, r + -> [(Type, Coercion)] -- flattened type arguments, arg + -- each comes with the coercion used to flatten it, + -- with co :: flattened_type ~ original_type + -> ([Type], [Coercion], CoercionN) +-- Returns (xis, cos, res_co), where each co :: xi ~ arg, +-- and res_co :: kind (f xis) ~ kind (f tys), where f is the function applied to the args +-- Precondition: if f :: forall bndrs. inner_ki (where bndrs and inner_ki are passed in), +-- then (f orig_tys) is well kinded. Note that (f flattened_tys) might *not* be well-kinded. +-- Massaging the flattened_tys in order to make (f flattened_tys) well-kinded is what this +-- function is all about. That is, (f xis), where xis are the returned arguments, *is* +-- well kinded. +simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs + orig_roles orig_simplified_args + = go [] [] orig_lc orig_ki_binders orig_inner_ki orig_roles orig_simplified_args + where + orig_lc = emptyLiftingContext $ mkInScopeSet $ orig_fvs + + go :: [Type] -- Xis accumulator, in reverse order + -> [Coercion] -- Coercions accumulator, in reverse order + -- These are in 1-to-1 correspondence + -> LiftingContext -- mapping from tyvars to flattening coercions + -> [TyCoBinder] -- Unsubsted binders of function's kind + -> Kind -- Unsubsted result kind of function (not a Pi-type) + -> [Role] -- Roles at which to flatten these ... + -> [(Type, Coercion)] -- flattened arguments, with their flattening coercions + -> ([Type], [Coercion], CoercionN) + go acc_xis acc_cos lc binders inner_ki _ [] + = (reverse acc_xis, reverse acc_cos, kind_co) + where + final_kind = mkPiTys binders inner_ki + kind_co = liftCoSubst Nominal lc final_kind + + go acc_xis acc_cos lc (binder:binders) inner_ki (role:roles) ((xi,co):args) + = -- By Note [Flattening] in TcFlatten invariant (F2), + -- tcTypeKind(xi) = tcTypeKind(ty). But, it's possible that xi will be + -- used as an argument to a function whose kind is different, if + -- earlier arguments have been flattened to new types. We thus + -- need a coercion (kind_co :: old_kind ~ new_kind). + -- + -- The bangs here have been observed to improve performance + -- significantly in optimized builds. + let kind_co = mkSymCo $ + liftCoSubst Nominal lc (tyCoBinderType binder) + !casted_xi = xi `mkCastTy` kind_co + casted_co = mkCoherenceLeftCo role xi kind_co co + + -- now, extend the lifting context with the new binding + !new_lc | Just tv <- tyCoBinderVar_maybe binder + = extendLiftingContextAndInScope lc tv casted_co + | otherwise + = lc + in + go (casted_xi : acc_xis) + (casted_co : acc_cos) + new_lc + binders + inner_ki + roles + args + + + -- See Note [Last case in simplifyArgsWorker] + go acc_xis acc_cos lc [] inner_ki roles args + | Just k <- getTyVar_maybe inner_ki + , Just co1 <- liftCoSubstTyVar lc Nominal k + = let co1_kind = coercionKind co1 + unflattened_tys = map (pSnd . coercionKind . snd) args + (arg_cos, res_co) = decomposePiCos co1 co1_kind unflattened_tys + casted_args = ASSERT2( equalLength args arg_cos + , ppr args $$ ppr arg_cos ) + [ (casted_xi, casted_co) + | ((xi, co), arg_co, role) <- zip3 args arg_cos roles + , let casted_xi = xi `mkCastTy` arg_co + casted_co = mkCoherenceLeftCo role xi arg_co co ] + -- In general decomposePiCos can return fewer cos than tys, + -- but not here; because we're well typed, there will be enough + -- binders. Note that decomposePiCos does substitutions, so even + -- if the original substitution results in something ending with + -- ... -> k, that k will be substituted to perhaps reveal more + -- binders. + zapped_lc = zapLiftingContext lc + Pair flattened_kind _ = co1_kind + (bndrs, new_inner) = splitPiTys flattened_kind + + (xis_out, cos_out, res_co_out) + = go acc_xis acc_cos zapped_lc bndrs new_inner roles casted_args + in + (xis_out, cos_out, res_co_out `mkTransCo` res_co) + + go _ _ _ _ _ _ _ = panic + "simplifyArgsWorker wandered into deeper water than usual" + -- This debug information is commented out because leaving it in + -- causes a ~2% increase in allocations in T9872d. + -- That's independent of the analagous case in flatten_args_fast + -- in TcFlatten: + -- each of these causes a 2% increase on its own, so commenting them + -- both out gives a 4% decrease in T9872d. + {- + + (vcat [ppr orig_binders, + ppr orig_inner_ki, + ppr (take 10 orig_roles), -- often infinite! + ppr orig_tys]) + -} diff --git a/compiler/types/Coercion.hs-boot b/compiler/types/Coercion.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/types/Coercion.hs-boot @@ -0,0 +1,52 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Coercion where + +import GhcPrelude + +import {-# SOURCE #-} TyCoRep +import {-# SOURCE #-} TyCon + +import BasicTypes ( LeftOrRight ) +import CoAxiom +import Var +import Pair +import Util + +mkReflCo :: Role -> Type -> Coercion +mkTyConAppCo :: HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion +mkAppCo :: Coercion -> Coercion -> Coercion +mkForAllCo :: TyCoVar -> Coercion -> Coercion -> Coercion +mkFunCo :: Role -> Coercion -> Coercion -> Coercion +mkCoVarCo :: CoVar -> Coercion +mkAxiomInstCo :: CoAxiom Branched -> BranchIndex -> [Coercion] -> Coercion +mkPhantomCo :: Coercion -> Type -> Type -> Coercion +mkUnsafeCo :: Role -> Type -> Type -> Coercion +mkUnivCo :: UnivCoProvenance -> Role -> Type -> Type -> Coercion +mkSymCo :: Coercion -> Coercion +mkTransCo :: Coercion -> Coercion -> Coercion +mkNthCo :: HasDebugCallStack => Role -> Int -> Coercion -> Coercion +mkLRCo :: LeftOrRight -> Coercion -> Coercion +mkInstCo :: Coercion -> Coercion -> Coercion +mkGReflCo :: Role -> Type -> MCoercionN -> Coercion +mkNomReflCo :: Type -> Coercion +mkKindCo :: Coercion -> Coercion +mkSubCo :: Coercion -> Coercion +mkProofIrrelCo :: Role -> Coercion -> Coercion -> Coercion -> Coercion +mkAxiomRuleCo :: CoAxiomRule -> [Coercion] -> Coercion + +isGReflCo :: Coercion -> Bool +isReflCo :: Coercion -> Bool +isReflexiveCo :: Coercion -> Bool +decomposePiCos :: HasDebugCallStack => Coercion -> Pair Type -> [Type] -> ([Coercion], Coercion) +coVarKindsTypesRole :: HasDebugCallStack => CoVar -> (Kind, Kind, Type, Type, Role) +coVarRole :: CoVar -> Role + +mkCoercionType :: Role -> Type -> Type -> Type + +data LiftingContext +liftCoSubst :: HasDebugCallStack => Role -> LiftingContext -> Type -> Coercion +seqCo :: Coercion -> () + +coercionKind :: Coercion -> Pair Type +coercionType :: Coercion -> Type diff --git a/compiler/types/FamInstEnv.hs b/compiler/types/FamInstEnv.hs new file mode 100644 --- /dev/null +++ b/compiler/types/FamInstEnv.hs @@ -0,0 +1,1754 @@ +-- (c) The University of Glasgow 2006 +-- +-- FamInstEnv: Type checked family instance declarations + +{-# LANGUAGE CPP, GADTs, ScopedTypeVariables, BangPatterns, TupleSections #-} + +module FamInstEnv ( + FamInst(..), FamFlavor(..), famInstAxiom, famInstTyCon, famInstRHS, + famInstsRepTyCons, famInstRepTyCon_maybe, dataFamInstRepTyCon, + pprFamInst, pprFamInsts, + mkImportedFamInst, + + FamInstEnvs, FamInstEnv, emptyFamInstEnv, emptyFamInstEnvs, + extendFamInstEnv, extendFamInstEnvList, + famInstEnvElts, famInstEnvSize, familyInstances, + + -- * CoAxioms + mkCoAxBranch, mkBranchedCoAxiom, mkUnbranchedCoAxiom, mkSingleCoAxiom, + mkNewTypeCoAxiom, + + FamInstMatch(..), + lookupFamInstEnv, lookupFamInstEnvConflicts, lookupFamInstEnvByTyCon, + + isDominatedBy, apartnessCheck, + + -- Injectivity + InjectivityCheckResult(..), + lookupFamInstEnvInjectivityConflicts, injectiveBranches, + + -- Normalisation + topNormaliseType, topNormaliseType_maybe, + normaliseType, normaliseTcApp, normaliseTcArgs, + reduceTyFamApp_maybe, + + -- Flattening + flattenTys + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import Unify +import Type +import TyCoRep +import TyCon +import Coercion +import CoAxiom +import VarSet +import VarEnv +import Name +import PrelNames ( eqPrimTyConKey ) +import UniqDFM +import Outputable +import Maybes +import CoreMap +import Unique +import Util +import Var +import Pair +import SrcLoc +import FastString +import Control.Monad +import Data.List( mapAccumL ) +import Data.Array( Array, assocs ) + +{- +************************************************************************ +* * + Type checked family instance heads +* * +************************************************************************ + +Note [FamInsts and CoAxioms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* CoAxioms and FamInsts are just like + DFunIds and ClsInsts + +* A CoAxiom is a System-FC thing: it can relate any two types + +* A FamInst is a Haskell source-language thing, corresponding + to a type/data family instance declaration. + - The FamInst contains a CoAxiom, which is the evidence + for the instance + + - The LHS of the CoAxiom is always of form F ty1 .. tyn + where F is a type family +-} + +data FamInst -- See Note [FamInsts and CoAxioms] + = FamInst { fi_axiom :: CoAxiom Unbranched -- The new coercion axiom + -- introduced by this family + -- instance + -- INVARIANT: apart from freshening (see below) + -- fi_tvs = cab_tvs of the (single) axiom branch + -- fi_cvs = cab_cvs ...ditto... + -- fi_tys = cab_lhs ...ditto... + -- fi_rhs = cab_rhs ...ditto... + + , fi_flavor :: FamFlavor + + -- Everything below here is a redundant, + -- cached version of the two things above + -- except that the TyVars are freshened + , fi_fam :: Name -- Family name + + -- Used for "rough matching"; same idea as for class instances + -- See Note [Rough-match field] in InstEnv + , fi_tcs :: [Maybe Name] -- Top of type args + -- INVARIANT: fi_tcs = roughMatchTcs fi_tys + + -- Used for "proper matching"; ditto + , fi_tvs :: [TyVar] -- Template tyvars for full match + , fi_cvs :: [CoVar] -- Template covars for full match + -- Like ClsInsts, these variables are always fresh + -- See Note [Template tyvars are fresh] in InstEnv + + , fi_tys :: [Type] -- The LHS type patterns + -- May be eta-reduced; see Note [Eta reduction for data families] + + , fi_rhs :: Type -- the RHS, with its freshened vars + } + +data FamFlavor + = SynFamilyInst -- A synonym family + | DataFamilyInst TyCon -- A data family, with its representation TyCon + +{- +Note [Arity of data families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Data family instances might legitimately be over- or under-saturated. + +Under-saturation has two potential causes: + U1) Eta reduction. See Note [Eta reduction for data families]. + U2) When the user has specified a return kind instead of written out patterns. + Example: + + data family Sing (a :: k) + data instance Sing :: Bool -> Type + + The data family tycon Sing has an arity of 2, the k and the a. But + the data instance has only one pattern, Bool (standing in for k). + This instance is equivalent to `data instance Sing (a :: Bool)`, but + without the last pattern, we have an under-saturated data family instance. + On its own, this example is not compelling enough to add support for + under-saturation, but U1 makes this feature more compelling. + +Over-saturation is also possible: + O1) If the data family's return kind is a type variable (see also #12369), + an instance might legitimately have more arguments than the family. + Example: + + data family Fix :: (Type -> k) -> k + data instance Fix f = MkFix1 (f (Fix f)) + data instance Fix f x = MkFix2 (f (Fix f x) x) + + In the first instance here, the k in the data family kind is chosen to + be Type. In the second, it's (Type -> Type). + + However, we require that any over-saturation is eta-reducible. That is, + we require that any extra patterns be bare unrepeated type variables; + see Note [Eta reduction for data families]. Accordingly, the FamInst + is never over-saturated. + +Why can we allow such flexibility for data families but not for type families? +Because data families can be decomposed -- that is, they are generative and +injective. A Type family is neither and so always must be applied to all its +arguments. +-} + +-- Obtain the axiom of a family instance +famInstAxiom :: FamInst -> CoAxiom Unbranched +famInstAxiom = fi_axiom + +-- Split the left-hand side of the FamInst +famInstSplitLHS :: FamInst -> (TyCon, [Type]) +famInstSplitLHS (FamInst { fi_axiom = axiom, fi_tys = lhs }) + = (coAxiomTyCon axiom, lhs) + +-- Get the RHS of the FamInst +famInstRHS :: FamInst -> Type +famInstRHS = fi_rhs + +-- Get the family TyCon of the FamInst +famInstTyCon :: FamInst -> TyCon +famInstTyCon = coAxiomTyCon . famInstAxiom + +-- Return the representation TyCons introduced by data family instances, if any +famInstsRepTyCons :: [FamInst] -> [TyCon] +famInstsRepTyCons fis = [tc | FamInst { fi_flavor = DataFamilyInst tc } <- fis] + +-- Extracts the TyCon for this *data* (or newtype) instance +famInstRepTyCon_maybe :: FamInst -> Maybe TyCon +famInstRepTyCon_maybe fi + = case fi_flavor fi of + DataFamilyInst tycon -> Just tycon + SynFamilyInst -> Nothing + +dataFamInstRepTyCon :: FamInst -> TyCon +dataFamInstRepTyCon fi + = case fi_flavor fi of + DataFamilyInst tycon -> tycon + SynFamilyInst -> pprPanic "dataFamInstRepTyCon" (ppr fi) + +{- +************************************************************************ +* * + Pretty printing +* * +************************************************************************ +-} + +instance NamedThing FamInst where + getName = coAxiomName . fi_axiom + +instance Outputable FamInst where + ppr = pprFamInst + +pprFamInst :: FamInst -> SDoc +-- Prints the FamInst as a family instance declaration +-- NB: This function, FamInstEnv.pprFamInst, is used only for internal, +-- debug printing. See PprTyThing.pprFamInst for printing for the user +pprFamInst (FamInst { fi_flavor = flavor, fi_axiom = ax + , fi_tvs = tvs, fi_tys = tys, fi_rhs = rhs }) + = hang (ppr_tc_sort <+> text "instance" + <+> pprCoAxBranchUser (coAxiomTyCon ax) (coAxiomSingleBranch ax)) + 2 (whenPprDebug debug_stuff) + where + ppr_tc_sort = case flavor of + SynFamilyInst -> text "type" + DataFamilyInst tycon + | isDataTyCon tycon -> text "data" + | isNewTyCon tycon -> text "newtype" + | isAbstractTyCon tycon -> text "data" + | otherwise -> text "WEIRD" <+> ppr tycon + + debug_stuff = vcat [ text "Coercion axiom:" <+> ppr ax + , text "Tvs:" <+> ppr tvs + , text "LHS:" <+> ppr tys + , text "RHS:" <+> ppr rhs ] + +pprFamInsts :: [FamInst] -> SDoc +pprFamInsts finsts = vcat (map pprFamInst finsts) + +{- +Note [Lazy axiom match] +~~~~~~~~~~~~~~~~~~~~~~~ +It is Vitally Important that mkImportedFamInst is *lazy* in its axiom +parameter. The axiom is loaded lazily, via a forkM, in TcIface. Sometime +later, mkImportedFamInst is called using that axiom. However, the axiom +may itself depend on entities which are not yet loaded as of the time +of the mkImportedFamInst. Thus, if mkImportedFamInst eagerly looks at the +axiom, a dependency loop spontaneously appears and GHC hangs. The solution +is simply for mkImportedFamInst never, ever to look inside of the axiom +until everything else is good and ready to do so. We can assume that this +readiness has been achieved when some other code pulls on the axiom in the +FamInst. Thus, we pattern match on the axiom lazily (in the where clause, +not in the parameter list) and we assert the consistency of names there +also. +-} + +-- Make a family instance representation from the information found in an +-- interface file. In particular, we get the rough match info from the iface +-- (instead of computing it here). +mkImportedFamInst :: Name -- Name of the family + -> [Maybe Name] -- Rough match info + -> CoAxiom Unbranched -- Axiom introduced + -> FamInst -- Resulting family instance +mkImportedFamInst fam mb_tcs axiom + = FamInst { + fi_fam = fam, + fi_tcs = mb_tcs, + fi_tvs = tvs, + fi_cvs = cvs, + fi_tys = tys, + fi_rhs = rhs, + fi_axiom = axiom, + fi_flavor = flavor } + where + -- See Note [Lazy axiom match] + ~(CoAxBranch { cab_lhs = tys + , cab_tvs = tvs + , cab_cvs = cvs + , cab_rhs = rhs }) = coAxiomSingleBranch axiom + + -- Derive the flavor for an imported FamInst rather disgustingly + -- Maybe we should store it in the IfaceFamInst? + flavor = case splitTyConApp_maybe rhs of + Just (tc, _) + | Just ax' <- tyConFamilyCoercion_maybe tc + , ax' == axiom + -> DataFamilyInst tc + _ -> SynFamilyInst + +{- +************************************************************************ +* * + FamInstEnv +* * +************************************************************************ + +Note [FamInstEnv] +~~~~~~~~~~~~~~~~~ +A FamInstEnv maps a family name to the list of known instances for that family. + +The same FamInstEnv includes both 'data family' and 'type family' instances. +Type families are reduced during type inference, but not data families; +the user explains when to use a data family instance by using constructors +and pattern matching. + +Nevertheless it is still useful to have data families in the FamInstEnv: + + - For finding overlaps and conflicts + + - For finding the representation type...see FamInstEnv.topNormaliseType + and its call site in Simplify + + - In standalone deriving instance Eq (T [Int]) we need to find the + representation type for T [Int] + +Note [Varying number of patterns for data family axioms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For data families, the number of patterns may vary between instances. +For example + data family T a b + data instance T Int a = T1 a | T2 + data instance T Bool [a] = T3 a + +Then we get a data type for each instance, and an axiom: + data TInt a = T1 a | T2 + data TBoolList a = T3 a + + axiom ax7 :: T Int ~ TInt -- Eta-reduced + axiom ax8 a :: T Bool [a] ~ TBoolList a + +These two axioms for T, one with one pattern, one with two; +see Note [Eta reduction for data families] + +Note [FamInstEnv determinism] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We turn FamInstEnvs into a list in some places that don't directly affect +the ABI. That happens in family consistency checks and when producing output +for `:info`. Unfortunately that nondeterminism is nonlocal and it's hard +to tell what it affects without following a chain of functions. It's also +easy to accidentally make that nondeterminism affect the ABI. Furthermore +the envs should be relatively small, so it should be free to use deterministic +maps here. Testing with nofib and validate detected no difference between +UniqFM and UniqDFM. +See Note [Deterministic UniqFM]. +-} + +type FamInstEnv = UniqDFM FamilyInstEnv -- Maps a family to its instances + -- See Note [FamInstEnv] + -- See Note [FamInstEnv determinism] + +type FamInstEnvs = (FamInstEnv, FamInstEnv) + -- External package inst-env, Home-package inst-env + +newtype FamilyInstEnv + = FamIE [FamInst] -- The instances for a particular family, in any order + +instance Outputable FamilyInstEnv where + ppr (FamIE fs) = text "FamIE" <+> vcat (map ppr fs) + +-- INVARIANTS: +-- * The fs_tvs are distinct in each FamInst +-- of a range value of the map (so we can safely unify them) + +emptyFamInstEnvs :: (FamInstEnv, FamInstEnv) +emptyFamInstEnvs = (emptyFamInstEnv, emptyFamInstEnv) + +emptyFamInstEnv :: FamInstEnv +emptyFamInstEnv = emptyUDFM + +famInstEnvElts :: FamInstEnv -> [FamInst] +famInstEnvElts fi = [elt | FamIE elts <- eltsUDFM fi, elt <- elts] + -- See Note [FamInstEnv determinism] + +famInstEnvSize :: FamInstEnv -> Int +famInstEnvSize = nonDetFoldUDFM (\(FamIE elt) sum -> sum + length elt) 0 + -- It's OK to use nonDetFoldUDFM here since we're just computing the + -- size. + +familyInstances :: (FamInstEnv, FamInstEnv) -> TyCon -> [FamInst] +familyInstances (pkg_fie, home_fie) fam + = get home_fie ++ get pkg_fie + where + get env = case lookupUDFM env fam of + Just (FamIE insts) -> insts + Nothing -> [] + +extendFamInstEnvList :: FamInstEnv -> [FamInst] -> FamInstEnv +extendFamInstEnvList inst_env fis = foldl' extendFamInstEnv inst_env fis + +extendFamInstEnv :: FamInstEnv -> FamInst -> FamInstEnv +extendFamInstEnv inst_env + ins_item@(FamInst {fi_fam = cls_nm}) + = addToUDFM_C add inst_env cls_nm (FamIE [ins_item]) + where + add (FamIE items) _ = FamIE (ins_item:items) + +{- +************************************************************************ +* * + Compatibility +* * +************************************************************************ + +Note [Apartness] +~~~~~~~~~~~~~~~~ +In dealing with closed type families, we must be able to check that one type +will never reduce to another. This check is called /apartness/. The check +is always between a target (which may be an arbitrary type) and a pattern. +Here is how we do it: + +apart(target, pattern) = not (unify(flatten(target), pattern)) + +where flatten (implemented in flattenTys, below) converts all type-family +applications into fresh variables. (See Note [Flattening].) + +Note [Compatibility] +~~~~~~~~~~~~~~~~~~~~ +Two patterns are /compatible/ if either of the following conditions hold: +1) The patterns are apart. +2) The patterns unify with a substitution S, and their right hand sides +equal under that substitution. + +For open type families, only compatible instances are allowed. For closed +type families, the story is slightly more complicated. Consider the following: + +type family F a where + F Int = Bool + F a = Int + +g :: Show a => a -> F a +g x = length (show x) + +Should that type-check? No. We need to allow for the possibility that 'a' +might be Int and therefore 'F a' should be Bool. We can simplify 'F a' to Int +only when we can be sure that 'a' is not Int. + +To achieve this, after finding a possible match within the equations, we have to +go back to all previous equations and check that, under the +substitution induced by the match, other branches are surely apart. (See +Note [Apartness].) This is similar to what happens with class +instance selection, when we need to guarantee that there is only a match and +no unifiers. The exact algorithm is different here because the +potentially-overlapping group is closed. + +As another example, consider this: + +type family G x where + G Int = Bool + G a = Double + +type family H y +-- no instances + +Now, we want to simplify (G (H Char)). We can't, because (H Char) might later +simplify to be Int. So, (G (H Char)) is stuck, for now. + +While everything above is quite sound, it isn't as expressive as we'd like. +Consider this: + +type family J a where + J Int = Int + J a = a + +Can we simplify (J b) to b? Sure we can. Yes, the first equation matches if +b is instantiated with Int, but the RHSs coincide there, so it's all OK. + +So, the rule is this: when looking up a branch in a closed type family, we +find a branch that matches the target, but then we make sure that the target +is apart from every previous *incompatible* branch. We don't check the +branches that are compatible with the matching branch, because they are either +irrelevant (clause 1 of compatible) or benign (clause 2 of compatible). + +Note [Compatibility of eta-reduced axioms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In newtype instances of data families we eta-reduce the axioms, +See Note [Eta reduction for data families] in FamInstEnv. This means that +we sometimes need to test compatibility of two axioms that were eta-reduced to +different degrees, e.g.: + + +data family D a b c +newtype instance D a Int c = DInt (Maybe a) + -- D a Int ~ Maybe + -- lhs = [a, Int] +newtype instance D Bool Int Char = DIntChar Float + -- D Bool Int Char ~ Float + -- lhs = [Bool, Int, Char] + +These are obviously incompatible. We could detect this by saturating +(eta-expanding) the shorter LHS with fresh tyvars until the lists are of +equal length, but instead we can just remove the tail of the longer list, as +those types will simply unify with the freshly introduced tyvars. + +By doing this, in case the LHS are unifiable, the yielded substitution won't +mention the tyvars that appear in the tail we dropped off, and we might try +to test equality RHSes of different kinds, but that's fine since this case +occurs only for data families, where the RHS is a unique tycon and the equality +fails anyway. +-} + +-- See Note [Compatibility] +compatibleBranches :: CoAxBranch -> CoAxBranch -> Bool +compatibleBranches (CoAxBranch { cab_lhs = lhs1, cab_rhs = rhs1 }) + (CoAxBranch { cab_lhs = lhs2, cab_rhs = rhs2 }) + = let (commonlhs1, commonlhs2) = zipAndUnzip lhs1 lhs2 + -- See Note [Compatibility of eta-reduced axioms] + in case tcUnifyTysFG (const BindMe) commonlhs1 commonlhs2 of + SurelyApart -> True + Unifiable subst + | Type.substTyAddInScope subst rhs1 `eqType` + Type.substTyAddInScope subst rhs2 + -> True + _ -> False + +-- | Result of testing two type family equations for injectiviy. +data InjectivityCheckResult + = InjectivityAccepted + -- ^ Either RHSs are distinct or unification of RHSs leads to unification of + -- LHSs + | InjectivityUnified CoAxBranch CoAxBranch + -- ^ RHSs unify but LHSs don't unify under that substitution. Relevant for + -- closed type families where equation after unification might be + -- overlpapped (in which case it is OK if they don't unify). Constructor + -- stores axioms after unification. + +-- | Check whether two type family axioms don't violate injectivity annotation. +injectiveBranches :: [Bool] -> CoAxBranch -> CoAxBranch + -> InjectivityCheckResult +injectiveBranches injectivity + ax1@(CoAxBranch { cab_lhs = lhs1, cab_rhs = rhs1 }) + ax2@(CoAxBranch { cab_lhs = lhs2, cab_rhs = rhs2 }) + -- See Note [Verifying injectivity annotation]. This function implements first + -- check described there. + = let getInjArgs = filterByList injectivity + in case tcUnifyTyWithTFs True rhs1 rhs2 of -- True = two-way pre-unification + Nothing -> InjectivityAccepted -- RHS are different, so equations are + -- injective. + Just subst -> -- RHS unify under a substitution + let lhs1Subst = Type.substTys subst (getInjArgs lhs1) + lhs2Subst = Type.substTys subst (getInjArgs lhs2) + -- If LHSs are equal under the substitution used for RHSs then this pair + -- of equations does not violate injectivity annotation. If LHSs are not + -- equal under that substitution then this pair of equations violates + -- injectivity annotation, but for closed type families it still might + -- be the case that one LHS after substitution is unreachable. + in if eqTypes lhs1Subst lhs2Subst + then InjectivityAccepted + else InjectivityUnified ( ax1 { cab_lhs = Type.substTys subst lhs1 + , cab_rhs = Type.substTy subst rhs1 }) + ( ax2 { cab_lhs = Type.substTys subst lhs2 + , cab_rhs = Type.substTy subst rhs2 }) + +-- takes a CoAxiom with unknown branch incompatibilities and computes +-- the compatibilities +-- See Note [Storing compatibility] in CoAxiom +computeAxiomIncomps :: [CoAxBranch] -> [CoAxBranch] +computeAxiomIncomps branches + = snd (mapAccumL go [] branches) + where + go :: [CoAxBranch] -> CoAxBranch -> ([CoAxBranch], CoAxBranch) + go prev_brs cur_br + = (cur_br : prev_brs, new_br) + where + new_br = cur_br { cab_incomps = mk_incomps prev_brs cur_br } + + mk_incomps :: [CoAxBranch] -> CoAxBranch -> [CoAxBranch] + mk_incomps prev_brs cur_br + = filter (not . compatibleBranches cur_br) prev_brs + +{- +************************************************************************ +* * + Constructing axioms + These functions are here because tidyType / tcUnifyTysFG + are not available in CoAxiom + + Also computeAxiomIncomps is too sophisticated for CoAxiom +* * +************************************************************************ + +Note [Tidy axioms when we build them] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Like types and classes, we build axioms fully quantified over all +their variables, and tidy them when we build them. For example, +we print out axioms and don't want to print stuff like + F k k a b = ... +Instead we must tidy those kind variables. See #7524. + +We could instead tidy when we print, but that makes it harder to get +things like injectivity errors to come out right. Danger of + Type family equation violates injectivity annotation. + Kind variable ‘k’ cannot be inferred from the right-hand side. + In the type family equation: + PolyKindVars @[k1] @[k2] ('[] @k1) = '[] @k2 + +Note [Always number wildcard types in CoAxBranch] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following example (from the DataFamilyInstanceLHS test case): + + data family Sing (a :: k) + data instance Sing (_ :: MyKind) where + SingA :: Sing A + SingB :: Sing B + +If we're not careful during tidying, then when this program is compiled with +-ddump-types, we'll get the following information: + + COERCION AXIOMS + axiom DataFamilyInstanceLHS.D:R:SingMyKind_0 :: + Sing _ = DataFamilyInstanceLHS.R:SingMyKind_ _ + +It's misleading to have a wildcard type appearing on the RHS like +that. To avoid this issue, when building a CoAxiom (which is what eventually +gets printed above), we tidy all the variables in an env that already contains +'_'. Thus, any variable named '_' will be renamed, giving us the nicer output +here: + + COERCION AXIOMS + axiom DataFamilyInstanceLHS.D:R:SingMyKind_0 :: + Sing _1 = DataFamilyInstanceLHS.R:SingMyKind_ _1 + +Which is at least legal syntax. + +See also Note [CoAxBranch type variables] in CoAxiom; note that we +are tidying (changing OccNames only), not freshening, in accordance with +that Note. +-} + +-- all axiom roles are Nominal, as this is only used with type families +mkCoAxBranch :: [TyVar] -- original, possibly stale, tyvars + -> [TyVar] -- Extra eta tyvars + -> [CoVar] -- possibly stale covars + -> [Type] -- LHS patterns + -> Type -- RHS + -> [Role] + -> SrcSpan + -> CoAxBranch +mkCoAxBranch tvs eta_tvs cvs lhs rhs roles loc + = CoAxBranch { cab_tvs = tvs' + , cab_eta_tvs = eta_tvs' + , cab_cvs = cvs' + , cab_lhs = tidyTypes env lhs + , cab_roles = roles + , cab_rhs = tidyType env rhs + , cab_loc = loc + , cab_incomps = placeHolderIncomps } + where + (env1, tvs') = tidyVarBndrs init_tidy_env tvs + (env2, eta_tvs') = tidyVarBndrs env1 eta_tvs + (env, cvs') = tidyVarBndrs env2 cvs + -- See Note [Tidy axioms when we build them] + -- See also Note [CoAxBranch type variables] in CoAxiom + + init_occ_env = initTidyOccEnv [mkTyVarOcc "_"] + init_tidy_env = mkEmptyTidyEnv init_occ_env + -- See Note [Always number wildcard types in CoAxBranch] + +-- all of the following code is here to avoid mutual dependencies with +-- Coercion +mkBranchedCoAxiom :: Name -> TyCon -> [CoAxBranch] -> CoAxiom Branched +mkBranchedCoAxiom ax_name fam_tc branches + = CoAxiom { co_ax_unique = nameUnique ax_name + , co_ax_name = ax_name + , co_ax_tc = fam_tc + , co_ax_role = Nominal + , co_ax_implicit = False + , co_ax_branches = manyBranches (computeAxiomIncomps branches) } + +mkUnbranchedCoAxiom :: Name -> TyCon -> CoAxBranch -> CoAxiom Unbranched +mkUnbranchedCoAxiom ax_name fam_tc branch + = CoAxiom { co_ax_unique = nameUnique ax_name + , co_ax_name = ax_name + , co_ax_tc = fam_tc + , co_ax_role = Nominal + , co_ax_implicit = False + , co_ax_branches = unbranched (branch { cab_incomps = [] }) } + +mkSingleCoAxiom :: Role -> Name + -> [TyVar] -> [TyVar] -> [CoVar] + -> TyCon -> [Type] -> Type + -> CoAxiom Unbranched +-- Make a single-branch CoAxiom, incluidng making the branch itself +-- Used for both type family (Nominal) and data family (Representational) +-- axioms, hence passing in the Role +mkSingleCoAxiom role ax_name tvs eta_tvs cvs fam_tc lhs_tys rhs_ty + = CoAxiom { co_ax_unique = nameUnique ax_name + , co_ax_name = ax_name + , co_ax_tc = fam_tc + , co_ax_role = role + , co_ax_implicit = False + , co_ax_branches = unbranched (branch { cab_incomps = [] }) } + where + branch = mkCoAxBranch tvs eta_tvs cvs lhs_tys rhs_ty + (map (const Nominal) tvs) + (getSrcSpan ax_name) + +-- | Create a coercion constructor (axiom) suitable for the given +-- newtype 'TyCon'. The 'Name' should be that of a new coercion +-- 'CoAxiom', the 'TyVar's the arguments expected by the @newtype@ and +-- the type the appropriate right hand side of the @newtype@, with +-- the free variables a subset of those 'TyVar's. +mkNewTypeCoAxiom :: Name -> TyCon -> [TyVar] -> [Role] -> Type -> CoAxiom Unbranched +mkNewTypeCoAxiom name tycon tvs roles rhs_ty + = CoAxiom { co_ax_unique = nameUnique name + , co_ax_name = name + , co_ax_implicit = True -- See Note [Implicit axioms] in TyCon + , co_ax_role = Representational + , co_ax_tc = tycon + , co_ax_branches = unbranched (branch { cab_incomps = [] }) } + where + branch = mkCoAxBranch tvs [] [] (mkTyVarTys tvs) rhs_ty + roles (getSrcSpan name) + +{- +************************************************************************ +* * + Looking up a family instance +* * +************************************************************************ + +@lookupFamInstEnv@ looks up in a @FamInstEnv@, using a one-way match. +Multiple matches are only possible in case of type families (not data +families), and then, it doesn't matter which match we choose (as the +instances are guaranteed confluent). + +We return the matching family instances and the type instance at which it +matches. For example, if we lookup 'T [Int]' and have a family instance + + data instance T [a] = .. + +desugared to + + data :R42T a = .. + coe :Co:R42T a :: T [a] ~ :R42T a + +we return the matching instance '(FamInst{.., fi_tycon = :R42T}, Int)'. +-} + +-- when matching a type family application, we get a FamInst, +-- and the list of types the axiom should be applied to +data FamInstMatch = FamInstMatch { fim_instance :: FamInst + , fim_tys :: [Type] + , fim_cos :: [Coercion] + } + -- See Note [Over-saturated matches] + +instance Outputable FamInstMatch where + ppr (FamInstMatch { fim_instance = inst + , fim_tys = tys + , fim_cos = cos }) + = text "match with" <+> parens (ppr inst) <+> ppr tys <+> ppr cos + +lookupFamInstEnvByTyCon :: FamInstEnvs -> TyCon -> [FamInst] +lookupFamInstEnvByTyCon (pkg_ie, home_ie) fam_tc + = get pkg_ie ++ get home_ie + where + get ie = case lookupUDFM ie fam_tc of + Nothing -> [] + Just (FamIE fis) -> fis + +lookupFamInstEnv + :: FamInstEnvs + -> TyCon -> [Type] -- What we are looking for + -> [FamInstMatch] -- Successful matches +-- Precondition: the tycon is saturated (or over-saturated) + +lookupFamInstEnv + = lookup_fam_inst_env match + where + match _ _ tpl_tys tys = tcMatchTys tpl_tys tys + +lookupFamInstEnvConflicts + :: FamInstEnvs + -> FamInst -- Putative new instance + -> [FamInstMatch] -- Conflicting matches (don't look at the fim_tys field) +-- E.g. when we are about to add +-- f : type instance F [a] = a->a +-- we do (lookupFamInstConflicts f [b]) +-- to find conflicting matches +-- +-- Precondition: the tycon is saturated (or over-saturated) + +lookupFamInstEnvConflicts envs fam_inst@(FamInst { fi_axiom = new_axiom }) + = lookup_fam_inst_env my_unify envs fam tys + where + (fam, tys) = famInstSplitLHS fam_inst + -- In example above, fam tys' = F [b] + + my_unify (FamInst { fi_axiom = old_axiom }) tpl_tvs tpl_tys _ + = ASSERT2( tyCoVarsOfTypes tys `disjointVarSet` tpl_tvs, + (ppr fam <+> ppr tys) $$ + (ppr tpl_tvs <+> ppr tpl_tys) ) + -- Unification will break badly if the variables overlap + -- They shouldn't because we allocate separate uniques for them + if compatibleBranches (coAxiomSingleBranch old_axiom) new_branch + then Nothing + else Just noSubst + -- Note [Family instance overlap conflicts] + + noSubst = panic "lookupFamInstEnvConflicts noSubst" + new_branch = coAxiomSingleBranch new_axiom + +-------------------------------------------------------------------------------- +-- Type family injectivity checking bits -- +-------------------------------------------------------------------------------- + +{- Note [Verifying injectivity annotation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Injectivity means that the RHS of a type family uniquely determines the LHS (see +Note [Type inference for type families with injectivity]). User informs about +injectivity using an injectivity annotation and it is GHC's task to verify that +that annotation is correct wrt. to type family equations. Whenever we see a new +equation of a type family we need to make sure that adding this equation to +already known equations of a type family does not violate injectivity annotation +supplied by the user (see Note [Injectivity annotation]). Of course if the type +family has no injectivity annotation then no check is required. But if a type +family has injectivity annotation we need to make sure that the following +conditions hold: + +1. For each pair of *different* equations of a type family, one of the following + conditions holds: + + A: RHSs are different. + + B1: OPEN TYPE FAMILIES: If the RHSs can be unified under some substitution + then it must be possible to unify the LHSs under the same substitution. + Example: + + type family FunnyId a = r | r -> a + type instance FunnyId Int = Int + type instance FunnyId a = a + + RHSs of these two equations unify under [ a |-> Int ] substitution. + Under this substitution LHSs are equal therefore these equations don't + violate injectivity annotation. + + B2: CLOSED TYPE FAMILIES: If the RHSs can be unified under some + substitution then either the LHSs unify under the same substitution or + the LHS of the latter equation is overlapped by earlier equations. + Example 1: + + type family SwapIntChar a = r | r -> a where + SwapIntChar Int = Char + SwapIntChar Char = Int + SwapIntChar a = a + + Say we are checking the last two equations. RHSs unify under [ a |-> + Int ] substitution but LHSs don't. So we apply the substitution to LHS + of last equation and check whether it is overlapped by any of previous + equations. Since it is overlapped by the first equation we conclude + that pair of last two equations does not violate injectivity + annotation. + + A special case of B is when RHSs unify with an empty substitution ie. they + are identical. + + If any of the above two conditions holds we conclude that the pair of + equations does not violate injectivity annotation. But if we find a pair + of equations where neither of the above holds we report that this pair + violates injectivity annotation because for a given RHS we don't have a + unique LHS. (Note that (B) actually implies (A).) + + Note that we only take into account these LHS patterns that were declared + as injective. + +2. If a RHS of a type family equation is a bare type variable then + all LHS variables (including implicit kind variables) also have to be bare. + In other words, this has to be a sole equation of that type family and it has + to cover all possible patterns. So for example this definition will be + rejected: + + type family W1 a = r | r -> a + type instance W1 [a] = a + + If it were accepted we could call `W1 [W1 Int]`, which would reduce to + `W1 Int` and then by injectivity we could conclude that `[W1 Int] ~ Int`, + which is bogus. + +3. If a RHS of a type family equation is a type family application then the type + family is rejected as not injective. + +4. If a LHS type variable that is declared as injective is not mentioned on + injective position in the RHS then the type family is rejected as not + injective. "Injective position" means either an argument to a type + constructor or argument to a type family on injective position. + +See also Note [Injective type families] in TyCon +-} + + +-- | Check whether an open type family equation can be added to already existing +-- instance environment without causing conflicts with supplied injectivity +-- annotations. Returns list of conflicting axioms (type instance +-- declarations). +lookupFamInstEnvInjectivityConflicts + :: [Bool] -- injectivity annotation for this type family instance + -- INVARIANT: list contains at least one True value + -> FamInstEnvs -- all type instances seens so far + -> FamInst -- new type instance that we're checking + -> [CoAxBranch] -- conflicting instance declarations +lookupFamInstEnvInjectivityConflicts injList (pkg_ie, home_ie) + fam_inst@(FamInst { fi_axiom = new_axiom }) + -- See Note [Verifying injectivity annotation]. This function implements + -- check (1.B1) for open type families described there. + = lookup_inj_fam_conflicts home_ie ++ lookup_inj_fam_conflicts pkg_ie + where + fam = famInstTyCon fam_inst + new_branch = coAxiomSingleBranch new_axiom + + -- filtering function used by `lookup_inj_fam_conflicts` to check whether + -- a pair of equations conflicts with the injectivity annotation. + isInjConflict (FamInst { fi_axiom = old_axiom }) + | InjectivityAccepted <- + injectiveBranches injList (coAxiomSingleBranch old_axiom) new_branch + = False -- no conflict + | otherwise = True + + lookup_inj_fam_conflicts ie + | isOpenFamilyTyCon fam, Just (FamIE insts) <- lookupUDFM ie fam + = map (coAxiomSingleBranch . fi_axiom) $ + filter isInjConflict insts + | otherwise = [] + + +-------------------------------------------------------------------------------- +-- Type family overlap checking bits -- +-------------------------------------------------------------------------------- + +{- +Note [Family instance overlap conflicts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +- In the case of data family instances, any overlap is fundamentally a + conflict (as these instances imply injective type mappings). + +- In the case of type family instances, overlap is admitted as long as + the right-hand sides of the overlapping rules coincide under the + overlap substitution. eg + type instance F a Int = a + type instance F Int b = b + These two overlap on (F Int Int) but then both RHSs are Int, + so all is well. We require that they are syntactically equal; + anything else would be difficult to test for at this stage. +-} + +------------------------------------------------------------ +-- Might be a one-way match or a unifier +type MatchFun = FamInst -- The FamInst template + -> TyVarSet -> [Type] -- fi_tvs, fi_tys of that FamInst + -> [Type] -- Target to match against + -> Maybe TCvSubst + +lookup_fam_inst_env' -- The worker, local to this module + :: MatchFun + -> FamInstEnv + -> TyCon -> [Type] -- What we are looking for + -> [FamInstMatch] +lookup_fam_inst_env' match_fun ie fam match_tys + | isOpenFamilyTyCon fam + , Just (FamIE insts) <- lookupUDFM ie fam + = find insts -- The common case + | otherwise = [] + where + + find [] = [] + find (item@(FamInst { fi_tcs = mb_tcs, fi_tvs = tpl_tvs, fi_cvs = tpl_cvs + , fi_tys = tpl_tys }) : rest) + -- Fast check for no match, uses the "rough match" fields + | instanceCantMatch rough_tcs mb_tcs + = find rest + + -- Proper check + | Just subst <- match_fun item (mkVarSet tpl_tvs) tpl_tys match_tys1 + = (FamInstMatch { fim_instance = item + , fim_tys = substTyVars subst tpl_tvs `chkAppend` match_tys2 + , fim_cos = ASSERT( all (isJust . lookupCoVar subst) tpl_cvs ) + substCoVars subst tpl_cvs + }) + : find rest + + -- No match => try next + | otherwise + = find rest + where + (rough_tcs, match_tys1, match_tys2) = split_tys tpl_tys + + -- Precondition: the tycon is saturated (or over-saturated) + + -- Deal with over-saturation + -- See Note [Over-saturated matches] + split_tys tpl_tys + | isTypeFamilyTyCon fam + = pre_rough_split_tys + + | otherwise + = let (match_tys1, match_tys2) = splitAtList tpl_tys match_tys + rough_tcs = roughMatchTcs match_tys1 + in (rough_tcs, match_tys1, match_tys2) + + (pre_match_tys1, pre_match_tys2) = splitAt (tyConArity fam) match_tys + pre_rough_split_tys + = (roughMatchTcs pre_match_tys1, pre_match_tys1, pre_match_tys2) + +lookup_fam_inst_env -- The worker, local to this module + :: MatchFun + -> FamInstEnvs + -> TyCon -> [Type] -- What we are looking for + -> [FamInstMatch] -- Successful matches + +-- Precondition: the tycon is saturated (or over-saturated) + +lookup_fam_inst_env match_fun (pkg_ie, home_ie) fam tys + = lookup_fam_inst_env' match_fun home_ie fam tys + ++ lookup_fam_inst_env' match_fun pkg_ie fam tys + +{- +Note [Over-saturated matches] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's ok to look up an over-saturated type constructor. E.g. + type family F a :: * -> * + type instance F (a,b) = Either (a->b) + +The type instance gives rise to a newtype TyCon (at a higher kind +which you can't do in Haskell!): + newtype FPair a b = FP (Either (a->b)) + +Then looking up (F (Int,Bool) Char) will return a FamInstMatch + (FPair, [Int,Bool,Char]) +The "extra" type argument [Char] just stays on the end. + +We handle data families and type families separately here: + + * For type families, all instances of a type family must have the + same arity, so we can precompute the split between the match_tys + and the overflow tys. This is done in pre_rough_split_tys. + + * For data family instances, though, we need to re-split for each + instance, because the breakdown might be different for each + instance. Why? Because of eta reduction; see + Note [Eta reduction for data families]. +-} + +-- checks if one LHS is dominated by a list of other branches +-- in other words, if an application would match the first LHS, it is guaranteed +-- to match at least one of the others. The RHSs are ignored. +-- This algorithm is conservative: +-- True -> the LHS is definitely covered by the others +-- False -> no information +-- It is currently (Oct 2012) used only for generating errors for +-- inaccessible branches. If these errors go unreported, no harm done. +-- This is defined here to avoid a dependency from CoAxiom to Unify +isDominatedBy :: CoAxBranch -> [CoAxBranch] -> Bool +isDominatedBy branch branches + = or $ map match branches + where + lhs = coAxBranchLHS branch + match (CoAxBranch { cab_lhs = tys }) + = isJust $ tcMatchTys tys lhs + +{- +************************************************************************ +* * + Choosing an axiom application +* * +************************************************************************ + +The lookupFamInstEnv function does a nice job for *open* type families, +but we also need to handle closed ones when normalising a type: +-} + +reduceTyFamApp_maybe :: FamInstEnvs + -> Role -- Desired role of result coercion + -> TyCon -> [Type] + -> Maybe (Coercion, Type) +-- Attempt to do a *one-step* reduction of a type-family application +-- but *not* newtypes +-- Works on type-synonym families always; data-families only if +-- the role we seek is representational +-- It does *not* normlise the type arguments first, so this may not +-- go as far as you want. If you want normalised type arguments, +-- use normaliseTcArgs first. +-- +-- The TyCon can be oversaturated. +-- Works on both open and closed families +-- +-- Always returns a *homogeneous* coercion -- type family reductions are always +-- homogeneous +reduceTyFamApp_maybe envs role tc tys + | Phantom <- role + = Nothing + + | case role of + Representational -> isOpenFamilyTyCon tc + _ -> isOpenTypeFamilyTyCon tc + -- If we seek a representational coercion + -- (e.g. the call in topNormaliseType_maybe) then we can + -- unwrap data families as well as type-synonym families; + -- otherwise only type-synonym families + , FamInstMatch { fim_instance = FamInst { fi_axiom = ax } + , fim_tys = inst_tys + , fim_cos = inst_cos } : _ <- lookupFamInstEnv envs tc tys + -- NB: Allow multiple matches because of compatible overlap + + = let co = mkUnbranchedAxInstCo role ax inst_tys inst_cos + ty = pSnd (coercionKind co) + in Just (co, ty) + + | Just ax <- isClosedSynFamilyTyConWithAxiom_maybe tc + , Just (ind, inst_tys, inst_cos) <- chooseBranch ax tys + = let co = mkAxInstCo role ax ind inst_tys inst_cos + ty = pSnd (coercionKind co) + in Just (co, ty) + + | Just ax <- isBuiltInSynFamTyCon_maybe tc + , Just (coax,ts,ty) <- sfMatchFam ax tys + = let co = mkAxiomRuleCo coax (zipWith mkReflCo (coaxrAsmpRoles coax) ts) + in Just (co, ty) + + | otherwise + = Nothing + +-- The axiom can be oversaturated. (Closed families only.) +chooseBranch :: CoAxiom Branched -> [Type] + -> Maybe (BranchIndex, [Type], [Coercion]) -- found match, with args +chooseBranch axiom tys + = do { let num_pats = coAxiomNumPats axiom + (target_tys, extra_tys) = splitAt num_pats tys + branches = coAxiomBranches axiom + ; (ind, inst_tys, inst_cos) + <- findBranch (unMkBranches branches) target_tys + ; return ( ind, inst_tys `chkAppend` extra_tys, inst_cos ) } + +-- The axiom must *not* be oversaturated +findBranch :: Array BranchIndex CoAxBranch + -> [Type] + -> Maybe (BranchIndex, [Type], [Coercion]) + -- coercions relate requested types to returned axiom LHS at role N +findBranch branches target_tys + = foldr go Nothing (assocs branches) + where + go :: (BranchIndex, CoAxBranch) + -> Maybe (BranchIndex, [Type], [Coercion]) + -> Maybe (BranchIndex, [Type], [Coercion]) + go (index, branch) other + = let (CoAxBranch { cab_tvs = tpl_tvs, cab_cvs = tpl_cvs + , cab_lhs = tpl_lhs + , cab_incomps = incomps }) = branch + in_scope = mkInScopeSet (unionVarSets $ + map (tyCoVarsOfTypes . coAxBranchLHS) incomps) + -- See Note [Flattening] below + flattened_target = flattenTys in_scope target_tys + in case tcMatchTys tpl_lhs target_tys of + Just subst -- matching worked. now, check for apartness. + | apartnessCheck flattened_target branch + -> -- matching worked & we're apart from all incompatible branches. + -- success + ASSERT( all (isJust . lookupCoVar subst) tpl_cvs ) + Just (index, substTyVars subst tpl_tvs, substCoVars subst tpl_cvs) + + -- failure. keep looking + _ -> other + +-- | Do an apartness check, as described in the "Closed Type Families" paper +-- (POPL '14). This should be used when determining if an equation +-- ('CoAxBranch') of a closed type family can be used to reduce a certain target +-- type family application. +apartnessCheck :: [Type] -- ^ /flattened/ target arguments. Make sure + -- they're flattened! See Note [Flattening]. + -- (NB: This "flat" is a different + -- "flat" than is used in TcFlatten.) + -> CoAxBranch -- ^ the candidate equation we wish to use + -- Precondition: this matches the target + -> Bool -- ^ True <=> equation can fire +apartnessCheck flattened_target (CoAxBranch { cab_incomps = incomps }) + = all (isSurelyApart + . tcUnifyTysFG (const BindMe) flattened_target + . coAxBranchLHS) incomps + where + isSurelyApart SurelyApart = True + isSurelyApart _ = False + +{- +************************************************************************ +* * + Looking up a family instance +* * +************************************************************************ + +Note [Normalising types] +~~~~~~~~~~~~~~~~~~~~~~~~ +The topNormaliseType function removes all occurrences of type families +and newtypes from the top-level structure of a type. normaliseTcApp does +the type family lookup and is fairly straightforward. normaliseType is +a little more involved. + +The complication comes from the fact that a type family might be used in the +kind of a variable bound in a forall. We wish to remove this type family +application, but that means coming up with a fresh variable (with the new +kind). Thus, we need a substitution to be built up as we recur through the +type. However, an ordinary TCvSubst just won't do: when we hit a type variable +whose kind has changed during normalisation, we need both the new type +variable *and* the coercion. We could conjure up a new VarEnv with just this +property, but a usable substitution environment already exists: +LiftingContexts from the liftCoSubst family of functions, defined in Coercion. +A LiftingContext maps a type variable to a coercion and a coercion variable to +a pair of coercions. Let's ignore coercion variables for now. Because the +coercion a type variable maps to contains the destination type (via +coercionKind), we don't need to store that destination type separately. Thus, +a LiftingContext has what we need: a map from type variables to (Coercion, +Type) pairs. + +We also benefit because we can piggyback on the liftCoSubstVarBndr function to +deal with binders. However, I had to modify that function to work with this +application. Thus, we now have liftCoSubstVarBndrUsing, which takes +a function used to process the kind of the binder. We don't wish +to lift the kind, but instead normalise it. So, we pass in a callback function +that processes the kind of the binder. + +After that brilliant explanation of all this, I'm sure you've forgotten the +dangling reference to coercion variables. What do we do with those? Nothing at +all. The point of normalising types is to remove type family applications, but +there's no sense in removing these from coercions. We would just get back a +new coercion witnessing the equality between the same types as the original +coercion. Because coercions are irrelevant anyway, there is no point in doing +this. So, whenever we encounter a coercion, we just say that it won't change. +That's what the CoercionTy case is doing within normalise_type. + +Note [Normalisation and type synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to be a bit careful about normalising in the presence of type +synonyms (#13035). Suppose S is a type synonym, and we have + S t1 t2 +If S is family-free (on its RHS) we can just normalise t1 and t2 and +reconstruct (S t1' t2'). Expanding S could not reveal any new redexes +because type families are saturated. + +But if S has a type family on its RHS we expand /before/ normalising +the args t1, t2. If we normalise t1, t2 first, we'll re-normalise them +after expansion, and that can lead to /exponential/ behavour; see #13035. + +Notice, though, that expanding first can in principle duplicate t1,t2, +which might contain redexes. I'm sure you could conjure up an exponential +case by that route too, but it hasn't happened in practice yet! +-} + +topNormaliseType :: FamInstEnvs -> Type -> Type +topNormaliseType env ty = case topNormaliseType_maybe env ty of + Just (_co, ty') -> ty' + Nothing -> ty + +topNormaliseType_maybe :: FamInstEnvs -> Type -> Maybe (Coercion, Type) + +-- ^ Get rid of *outermost* (or toplevel) +-- * type function redex +-- * data family redex +-- * newtypes +-- returning an appropriate Representational coercion. Specifically, if +-- topNormaliseType_maybe env ty = Just (co, ty') +-- then +-- (a) co :: ty ~R ty' +-- (b) ty' is not a newtype, and is not a type-family or data-family redex +-- +-- However, ty' can be something like (Maybe (F ty)), where +-- (F ty) is a redex. +-- +-- Always operates homogeneously: the returned type has the same kind as the +-- original type, and the returned coercion is always homogeneous. +topNormaliseType_maybe env ty + = do { ((co, mkind_co), nty) <- topNormaliseTypeX stepper combine ty + ; return $ case mkind_co of + MRefl -> (co, nty) + MCo kind_co -> let nty_casted = nty `mkCastTy` mkSymCo kind_co + final_co = mkCoherenceRightCo Representational nty + (mkSymCo kind_co) co + in (final_co, nty_casted) } + where + stepper = unwrapNewTypeStepper' `composeSteppers` tyFamStepper + + combine (c1, mc1) (c2, mc2) = (c1 `mkTransCo` c2, mc1 `mkTransMCo` mc2) + + unwrapNewTypeStepper' :: NormaliseStepper (Coercion, MCoercionN) + unwrapNewTypeStepper' rec_nts tc tys + = mapStepResult (, MRefl) $ unwrapNewTypeStepper rec_nts tc tys + + -- second coercion below is the kind coercion relating the original type's kind + -- to the normalised type's kind + tyFamStepper :: NormaliseStepper (Coercion, MCoercionN) + tyFamStepper rec_nts tc tys -- Try to step a type/data family + = let (args_co, ntys, res_co) = normaliseTcArgs env Representational tc tys in + case reduceTyFamApp_maybe env Representational tc ntys of + Just (co, rhs) -> NS_Step rec_nts rhs (args_co `mkTransCo` co, MCo res_co) + _ -> NS_Done + +--------------- +normaliseTcApp :: FamInstEnvs -> Role -> TyCon -> [Type] -> (Coercion, Type) +-- See comments on normaliseType for the arguments of this function +normaliseTcApp env role tc tys + = initNormM env role (tyCoVarsOfTypes tys) $ + normalise_tc_app tc tys + +-- See Note [Normalising types] about the LiftingContext +normalise_tc_app :: TyCon -> [Type] -> NormM (Coercion, Type) +normalise_tc_app tc tys + | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys + , not (isFamFreeTyCon tc) -- Expand and try again + = -- A synonym with type families in the RHS + -- Expand and try again + -- See Note [Normalisation and type synonyms] + normalise_type (mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys') + + | isFamilyTyCon tc + = -- A type-family application + do { env <- getEnv + ; role <- getRole + ; (args_co, ntys, res_co) <- normalise_tc_args tc tys + ; case reduceTyFamApp_maybe env role tc ntys of + Just (first_co, ty') + -> do { (rest_co,nty) <- normalise_type ty' + ; return (assemble_result role nty + (args_co `mkTransCo` first_co `mkTransCo` rest_co) + res_co) } + _ -> -- No unique matching family instance exists; + -- we do not do anything + return (assemble_result role (mkTyConApp tc ntys) args_co res_co) } + + | otherwise + = -- A synonym with no type families in the RHS; or data type etc + -- Just normalise the arguments and rebuild + do { (args_co, ntys, res_co) <- normalise_tc_args tc tys + ; role <- getRole + ; return (assemble_result role (mkTyConApp tc ntys) args_co res_co) } + + where + assemble_result :: Role -- r, ambient role in NormM monad + -> Type -- nty, result type, possibly of changed kind + -> Coercion -- orig_ty ~r nty, possibly heterogeneous + -> CoercionN -- typeKind(orig_ty) ~N typeKind(nty) + -> (Coercion, Type) -- (co :: orig_ty ~r nty_casted, nty_casted) + -- where nty_casted has same kind as orig_ty + assemble_result r nty orig_to_nty kind_co + = ( final_co, nty_old_kind ) + where + nty_old_kind = nty `mkCastTy` mkSymCo kind_co + final_co = mkCoherenceRightCo r nty (mkSymCo kind_co) orig_to_nty + +--------------- +-- | Normalise arguments to a tycon +normaliseTcArgs :: FamInstEnvs -- ^ env't with family instances + -> Role -- ^ desired role of output coercion + -> TyCon -- ^ tc + -> [Type] -- ^ tys + -> (Coercion, [Type], CoercionN) + -- ^ co :: tc tys ~ tc new_tys + -- NB: co might not be homogeneous + -- last coercion :: kind(tc tys) ~ kind(tc new_tys) +normaliseTcArgs env role tc tys + = initNormM env role (tyCoVarsOfTypes tys) $ + normalise_tc_args tc tys + +normalise_tc_args :: TyCon -> [Type] -- tc tys + -> NormM (Coercion, [Type], CoercionN) + -- (co, new_tys), where + -- co :: tc tys ~ tc new_tys; might not be homogeneous + -- res_co :: typeKind(tc tys) ~N typeKind(tc new_tys) +normalise_tc_args tc tys + = do { role <- getRole + ; (args_cos, nargs, res_co) <- normalise_args (tyConKind tc) (tyConRolesX role tc) tys + ; return (mkTyConAppCo role tc args_cos, nargs, res_co) } + +--------------- +normaliseType :: FamInstEnvs + -> Role -- desired role of coercion + -> Type -> (Coercion, Type) +normaliseType env role ty + = initNormM env role (tyCoVarsOfType ty) $ normalise_type ty + +normalise_type :: Type -- old type + -> NormM (Coercion, Type) -- (coercion, new type), where + -- co :: old-type ~ new_type +-- Normalise the input type, by eliminating *all* type-function redexes +-- but *not* newtypes (which are visible to the programmer) +-- Returns with Refl if nothing happens +-- Does nothing to newtypes +-- The returned coercion *must* be *homogeneous* +-- See Note [Normalising types] +-- Try not to disturb type synonyms if possible + +normalise_type ty + = go ty + where + go (TyConApp tc tys) = normalise_tc_app tc tys + go ty@(LitTy {}) = do { r <- getRole + ; return (mkReflCo r ty, ty) } + + go (AppTy ty1 ty2) = go_app_tys ty1 [ty2] + + go ty@(FunTy { ft_arg = ty1, ft_res = ty2 }) + = do { (co1, nty1) <- go ty1 + ; (co2, nty2) <- go ty2 + ; r <- getRole + ; return (mkFunCo r co1 co2, ty { ft_arg = nty1, ft_res = nty2 }) } + go (ForAllTy (Bndr tcvar vis) ty) + = do { (lc', tv', h, ki') <- normalise_var_bndr tcvar + ; (co, nty) <- withLC lc' $ normalise_type ty + ; let tv2 = setTyVarKind tv' ki' + ; return (mkForAllCo tv' h co, ForAllTy (Bndr tv2 vis) nty) } + go (TyVarTy tv) = normalise_tyvar tv + go (CastTy ty co) + = do { (nco, nty) <- go ty + ; lc <- getLC + ; let co' = substRightCo lc co + ; return (castCoercionKind nco Nominal ty nty co co' + , mkCastTy nty co') } + go (CoercionTy co) + = do { lc <- getLC + ; r <- getRole + ; let right_co = substRightCo lc co + ; return ( mkProofIrrelCo r + (liftCoSubst Nominal lc (coercionType co)) + co right_co + , mkCoercionTy right_co ) } + + go_app_tys :: Type -- function + -> [Type] -- args + -> NormM (Coercion, Type) + -- cf. TcFlatten.flatten_app_ty_args + go_app_tys (AppTy ty1 ty2) tys = go_app_tys ty1 (ty2 : tys) + go_app_tys fun_ty arg_tys + = do { (fun_co, nfun) <- go fun_ty + ; case tcSplitTyConApp_maybe nfun of + Just (tc, xis) -> + do { (second_co, nty) <- go (mkTyConApp tc (xis ++ arg_tys)) + -- flatten_app_ty_args avoids redundantly processing the xis, + -- but that's a much more performance-sensitive function. + -- This type normalisation is not called in a loop. + ; return (mkAppCos fun_co (map mkNomReflCo arg_tys) `mkTransCo` second_co, nty) } + Nothing -> + do { (args_cos, nargs, res_co) <- normalise_args (typeKind nfun) + (repeat Nominal) + arg_tys + ; role <- getRole + ; let nty = mkAppTys nfun nargs + nco = mkAppCos fun_co args_cos + nty_casted = nty `mkCastTy` mkSymCo res_co + final_co = mkCoherenceRightCo role nty (mkSymCo res_co) nco + ; return (final_co, nty_casted) } } + +normalise_args :: Kind -- of the function + -> [Role] -- roles at which to normalise args + -> [Type] -- args + -> NormM ([Coercion], [Type], Coercion) +-- returns (cos, xis, res_co), where each xi is the normalised +-- version of the corresponding type, each co is orig_arg ~ xi, +-- and the res_co :: kind(f orig_args) ~ kind(f xis) +-- NB: The xis might *not* have the same kinds as the input types, +-- but the resulting application *will* be well-kinded +-- cf. TcFlatten.flatten_args_slow +normalise_args fun_ki roles args + = do { normed_args <- zipWithM normalise1 roles args + ; let (xis, cos, res_co) = simplifyArgsWorker ki_binders inner_ki fvs roles normed_args + ; return (map mkSymCo cos, xis, mkSymCo res_co) } + where + (ki_binders, inner_ki) = splitPiTys fun_ki + fvs = tyCoVarsOfTypes args + + -- flattener conventions are different from ours + impedance_match :: NormM (Coercion, Type) -> NormM (Type, Coercion) + impedance_match action = do { (co, ty) <- action + ; return (ty, mkSymCo co) } + + normalise1 role ty + = impedance_match $ withRole role $ normalise_type ty + +normalise_tyvar :: TyVar -> NormM (Coercion, Type) +normalise_tyvar tv + = ASSERT( isTyVar tv ) + do { lc <- getLC + ; r <- getRole + ; return $ case liftCoSubstTyVar lc r tv of + Just co -> (co, pSnd $ coercionKind co) + Nothing -> (mkReflCo r ty, ty) } + where ty = mkTyVarTy tv + +normalise_var_bndr :: TyCoVar -> NormM (LiftingContext, TyCoVar, Coercion, Kind) +normalise_var_bndr tcvar + -- works for both tvar and covar + = do { lc1 <- getLC + ; env <- getEnv + ; let callback lc ki = runNormM (normalise_type ki) env lc Nominal + ; return $ liftCoSubstVarBndrUsing callback lc1 tcvar } + +-- | a monad for the normalisation functions, reading 'FamInstEnvs', +-- a 'LiftingContext', and a 'Role'. +newtype NormM a = NormM { runNormM :: + FamInstEnvs -> LiftingContext -> Role -> a } + +initNormM :: FamInstEnvs -> Role + -> TyCoVarSet -- the in-scope variables + -> NormM a -> a +initNormM env role vars (NormM thing_inside) + = thing_inside env lc role + where + in_scope = mkInScopeSet vars + lc = emptyLiftingContext in_scope + +getRole :: NormM Role +getRole = NormM (\ _ _ r -> r) + +getLC :: NormM LiftingContext +getLC = NormM (\ _ lc _ -> lc) + +getEnv :: NormM FamInstEnvs +getEnv = NormM (\ env _ _ -> env) + +withRole :: Role -> NormM a -> NormM a +withRole r thing = NormM $ \ envs lc _old_r -> runNormM thing envs lc r + +withLC :: LiftingContext -> NormM a -> NormM a +withLC lc thing = NormM $ \ envs _old_lc r -> runNormM thing envs lc r + +instance Monad NormM where + ma >>= fmb = NormM $ \env lc r -> + let a = runNormM ma env lc r in + runNormM (fmb a) env lc r + +instance Functor NormM where + fmap = liftM +instance Applicative NormM where + pure x = NormM $ \ _ _ _ -> x + (<*>) = ap + +{- +************************************************************************ +* * + Flattening +* * +************************************************************************ + +Note [Flattening] +~~~~~~~~~~~~~~~~~ +As described in "Closed type families with overlapping equations" +http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/axioms-extended.pdf +we need to flatten core types before unifying them, when checking for "surely-apart" +against earlier equations of a closed type family. +Flattening means replacing all top-level uses of type functions with +fresh variables, *taking care to preserve sharing*. That is, the type +(Either (F a b) (F a b)) should flatten to (Either c c), never (Either +c d). + +Here is a nice example of why it's all necessary: + + type family F a b where + F Int Bool = Char + F a b = Double + type family G a -- open, no instances + +How do we reduce (F (G Float) (G Float))? The first equation clearly doesn't match, +while the second equation does. But, before reducing, we must make sure that the +target can never become (F Int Bool). Well, no matter what G Float becomes, it +certainly won't become *both* Int and Bool, so indeed we're safe reducing +(F (G Float) (G Float)) to Double. + +This is necessary not only to get more reductions (which we might be +willing to give up on), but for substitutivity. If we have (F x x), we +can see that (F x x) can reduce to Double. So, it had better be the +case that (F blah blah) can reduce to Double, no matter what (blah) +is! Flattening as done below ensures this. + +flattenTys is defined here because of module dependencies. +-} + +data FlattenEnv = FlattenEnv { fe_type_map :: TypeMap TyVar + , fe_subst :: TCvSubst } + +emptyFlattenEnv :: InScopeSet -> FlattenEnv +emptyFlattenEnv in_scope + = FlattenEnv { fe_type_map = emptyTypeMap + , fe_subst = mkEmptyTCvSubst in_scope } + +-- See Note [Flattening] +flattenTys :: InScopeSet -> [Type] -> [Type] +flattenTys in_scope tys = snd $ coreFlattenTys env tys + where + -- when we hit a type function, we replace it with a fresh variable + -- but, we need to make sure that this fresh variable isn't mentioned + -- *anywhere* in the types we're flattening, even if locally-bound in + -- a forall. That way, we can ensure consistency both within and outside + -- of that forall. + all_in_scope = in_scope `extendInScopeSetSet` allTyCoVarsInTys tys + env = emptyFlattenEnv all_in_scope + +coreFlattenTys :: FlattenEnv -> [Type] -> (FlattenEnv, [Type]) +coreFlattenTys = go [] + where + go rtys env [] = (env, reverse rtys) + go rtys env (ty : tys) + = let (env', ty') = coreFlattenTy env ty in + go (ty' : rtys) env' tys + +coreFlattenTy :: FlattenEnv -> Type -> (FlattenEnv, Type) +coreFlattenTy = go + where + go env ty | Just ty' <- coreView ty = go env ty' + + go env (TyVarTy tv) = (env, substTyVar (fe_subst env) tv) + go env (AppTy ty1 ty2) = let (env1, ty1') = go env ty1 + (env2, ty2') = go env1 ty2 in + (env2, AppTy ty1' ty2') + go env (TyConApp tc tys) + -- NB: Don't just check if isFamilyTyCon: this catches *data* families, + -- which are generative and thus can be preserved during flattening + | not (isGenerativeTyCon tc Nominal) + = let (env', tv) = coreFlattenTyFamApp env tc tys in + (env', mkTyVarTy tv) + + | otherwise + = let (env', tys') = coreFlattenTys env tys in + (env', mkTyConApp tc tys') + + go env ty@(FunTy { ft_arg = ty1, ft_res = ty2 }) + = let (env1, ty1') = go env ty1 + (env2, ty2') = go env1 ty2 in + (env2, ty { ft_arg = ty1', ft_res = ty2' }) + + go env (ForAllTy (Bndr tv vis) ty) + = let (env1, tv') = coreFlattenVarBndr env tv + (env2, ty') = go env1 ty in + (env2, ForAllTy (Bndr tv' vis) ty') + + go env ty@(LitTy {}) = (env, ty) + + go env (CastTy ty co) = let (env1, ty') = go env ty + (env2, co') = coreFlattenCo env1 co in + (env2, CastTy ty' co') + + go env (CoercionTy co) = let (env', co') = coreFlattenCo env co in + (env', CoercionTy co') + +-- when flattening, we don't care about the contents of coercions. +-- so, just return a fresh variable of the right (flattened) type +coreFlattenCo :: FlattenEnv -> Coercion -> (FlattenEnv, Coercion) +coreFlattenCo env co + = (env2, mkCoVarCo covar) + where + (env1, kind') = coreFlattenTy env (coercionType co) + fresh_name = mkFlattenFreshCoName + subst1 = fe_subst env1 + in_scope = getTCvInScope subst1 + covar = uniqAway in_scope (mkCoVar fresh_name kind') + env2 = env1 { fe_subst = subst1 `extendTCvInScope` covar } + +coreFlattenVarBndr :: FlattenEnv -> TyCoVar -> (FlattenEnv, TyCoVar) +coreFlattenVarBndr env tv + | kind' `eqType` kind + = ( env { fe_subst = extendTCvSubst old_subst tv (mkTyCoVarTy tv) } + -- override any previous binding for tv + , tv) + + | otherwise + = let new_tv = uniqAway (getTCvInScope old_subst) (setVarType tv kind') + new_subst = extendTCvSubstWithClone old_subst tv new_tv + in + (env' { fe_subst = new_subst }, new_tv) + where + kind = varType tv + (env', kind') = coreFlattenTy env kind + old_subst = fe_subst env + +coreFlattenTyFamApp :: FlattenEnv + -> TyCon -- type family tycon + -> [Type] -- args + -> (FlattenEnv, TyVar) +coreFlattenTyFamApp env fam_tc fam_args + = case lookupTypeMap type_map fam_ty of + Just tv -> (env, tv) + -- we need fresh variables here, but this is called far from + -- any good source of uniques. So, we just use the fam_tc's unique + -- and trust uniqAway to avoid clashes. Recall that the in_scope set + -- contains *all* tyvars, even locally bound ones elsewhere in the + -- overall type, so this really is fresh. + Nothing -> let tyvar_name = mkFlattenFreshTyName fam_tc + tv = uniqAway (getTCvInScope subst) $ + mkTyVar tyvar_name (typeKind fam_ty) + env' = env { fe_type_map = extendTypeMap type_map fam_ty tv + , fe_subst = extendTCvInScope subst tv } + in (env', tv) + where fam_ty = mkTyConApp fam_tc fam_args + FlattenEnv { fe_type_map = type_map + , fe_subst = subst } = env + +-- | Get the set of all type/coercion variables mentioned anywhere in the list +-- of types. These variables are not necessarily free. +allTyCoVarsInTys :: [Type] -> VarSet +allTyCoVarsInTys [] = emptyVarSet +allTyCoVarsInTys (ty:tys) = allTyCoVarsInTy ty `unionVarSet` allTyCoVarsInTys tys + +-- | Get the set of all type/coercion variables mentioned anywhere in a type. +allTyCoVarsInTy :: Type -> VarSet +allTyCoVarsInTy = go + where + go (TyVarTy tv) = unitVarSet tv + go (TyConApp _ tys) = allTyCoVarsInTys tys + go (AppTy ty1 ty2) = (go ty1) `unionVarSet` (go ty2) + go (FunTy _ ty1 ty2) = (go ty1) `unionVarSet` (go ty2) + go (ForAllTy (Bndr tv _) ty) = unitVarSet tv `unionVarSet` + go (tyVarKind tv) `unionVarSet` + go ty + -- Don't remove the tv from the set! + go (LitTy {}) = emptyVarSet + go (CastTy ty co) = go ty `unionVarSet` go_co co + go (CoercionTy co) = go_co co + + go_mco MRefl = emptyVarSet + go_mco (MCo co) = go_co co + + go_co (Refl ty) = go ty + go_co (GRefl _ ty mco) = go ty `unionVarSet` go_mco mco + go_co (TyConAppCo _ _ args) = go_cos args + go_co (AppCo co arg) = go_co co `unionVarSet` go_co arg + go_co (ForAllCo tv h co) + = unionVarSets [unitVarSet tv, go_co co, go_co h] + go_co (FunCo _ c1 c2) = go_co c1 `unionVarSet` go_co c2 + go_co (CoVarCo cv) = unitVarSet cv + go_co (HoleCo h) = unitVarSet (coHoleCoVar h) + go_co (AxiomInstCo _ _ cos) = go_cos cos + go_co (UnivCo p _ t1 t2) = go_prov p `unionVarSet` go t1 `unionVarSet` go t2 + go_co (SymCo co) = go_co co + go_co (TransCo c1 c2) = go_co c1 `unionVarSet` go_co c2 + go_co (NthCo _ _ co) = go_co co + go_co (LRCo _ co) = go_co co + go_co (InstCo co arg) = go_co co `unionVarSet` go_co arg + go_co (KindCo co) = go_co co + go_co (SubCo co) = go_co co + go_co (AxiomRuleCo _ cs) = go_cos cs + + go_cos = foldr (unionVarSet . go_co) emptyVarSet + + go_prov UnsafeCoerceProv = emptyVarSet + go_prov (PhantomProv co) = go_co co + go_prov (ProofIrrelProv co) = go_co co + go_prov (PluginProv _) = emptyVarSet + +mkFlattenFreshTyName :: Uniquable a => a -> Name +mkFlattenFreshTyName unq + = mkSysTvName (getUnique unq) (fsLit "flt") + +mkFlattenFreshCoName :: Name +mkFlattenFreshCoName + = mkSystemVarName (deriveUnique eqPrimTyConKey 71) (fsLit "flc") diff --git a/compiler/types/InstEnv.hs b/compiler/types/InstEnv.hs new file mode 100644 --- /dev/null +++ b/compiler/types/InstEnv.hs @@ -0,0 +1,1027 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[InstEnv]{Utilities for typechecking instance declarations} + +The bits common to TcInstDcls and TcDeriv. +-} + +{-# LANGUAGE CPP, DeriveDataTypeable #-} + +module InstEnv ( + DFunId, InstMatch, ClsInstLookupResult, + OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe, + ClsInst(..), DFunInstType, pprInstance, pprInstanceHdr, pprInstances, + instanceHead, instanceSig, mkLocalInstance, mkImportedInstance, + instanceDFunId, tidyClsInstDFun, instanceRoughTcs, + fuzzyClsInstCmp, orphNamesOfClsInst, + + InstEnvs(..), VisibleOrphanModules, InstEnv, + emptyInstEnv, extendInstEnv, + deleteFromInstEnv, deleteDFunFromInstEnv, + identicalClsInstHead, + extendInstEnvList, lookupUniqueInstEnv, lookupInstEnv, instEnvElts, + memberInstEnv, + instIsVisible, + classInstances, instanceBindFun, + instanceCantMatch, roughMatchTcs, + isOverlappable, isOverlapping, isIncoherent + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import TcType -- InstEnv is really part of the type checker, + -- and depends on TcType in many ways +import CoreSyn ( IsOrphan(..), isOrphan, chooseOrphanAnchor ) +import Module +import Class +import Var +import VarSet +import Name +import NameSet +import Unify +import Outputable +import ErrUtils +import BasicTypes +import UniqDFM +import Util +import Id +import Data.Data ( Data ) +import Data.Maybe ( isJust, isNothing ) + +{- +************************************************************************ +* * + ClsInst: the data type for type-class instances +* * +************************************************************************ +-} + +-- | A type-class instance. Note that there is some tricky laziness at work +-- here. See Note [ClsInst laziness and the rough-match fields] for more +-- details. +data ClsInst + = ClsInst { -- Used for "rough matching"; see + -- Note [ClsInst laziness and the rough-match fields] + -- INVARIANT: is_tcs = roughMatchTcs is_tys + is_cls_nm :: Name -- ^ Class name + , is_tcs :: [Maybe Name] -- ^ Top of type args + + -- | @is_dfun_name = idName . is_dfun@. + -- + -- We use 'is_dfun_name' for the visibility check, + -- 'instIsVisible', which needs to know the 'Module' which the + -- dictionary is defined in. However, we cannot use the 'Module' + -- attached to 'is_dfun' since doing so would mean we would + -- potentially pull in an entire interface file unnecessarily. + -- This was the cause of #12367. + , is_dfun_name :: Name + + -- Used for "proper matching"; see Note [Proper-match fields] + , is_tvs :: [TyVar] -- Fresh template tyvars for full match + -- See Note [Template tyvars are fresh] + , is_cls :: Class -- The real class + , is_tys :: [Type] -- Full arg types (mentioning is_tvs) + -- INVARIANT: is_dfun Id has type + -- forall is_tvs. (...) => is_cls is_tys + -- (modulo alpha conversion) + + , is_dfun :: DFunId -- See Note [Haddock assumptions] + + , is_flag :: OverlapFlag -- See detailed comments with + -- the decl of BasicTypes.OverlapFlag + , is_orphan :: IsOrphan + } + deriving Data + +-- | A fuzzy comparison function for class instances, intended for sorting +-- instances before displaying them to the user. +fuzzyClsInstCmp :: ClsInst -> ClsInst -> Ordering +fuzzyClsInstCmp x y = + stableNameCmp (is_cls_nm x) (is_cls_nm y) `mappend` + mconcat (map cmp (zip (is_tcs x) (is_tcs y))) + where + cmp (Nothing, Nothing) = EQ + cmp (Nothing, Just _) = LT + cmp (Just _, Nothing) = GT + cmp (Just x, Just y) = stableNameCmp x y + +isOverlappable, isOverlapping, isIncoherent :: ClsInst -> Bool +isOverlappable i = hasOverlappableFlag (overlapMode (is_flag i)) +isOverlapping i = hasOverlappingFlag (overlapMode (is_flag i)) +isIncoherent i = hasIncoherentFlag (overlapMode (is_flag i)) + +{- +Note [ClsInst laziness and the rough-match fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we load 'instance A.C B.T' from A.hi, but suppose that the type B.T is +otherwise unused in the program. Then it's stupid to load B.hi, the data type +declaration for B.T -- and perhaps further instance declarations! + +We avoid this as follows: + +* is_cls_nm, is_tcs, is_dfun_name are all Names. We can poke them to our heart's + content. + +* Proper-match fields. is_dfun, and its related fields is_tvs, is_cls, is_tys + contain TyVars, Class, Type, Class etc, and so are all lazy thunks. When we + poke any of these fields we'll typecheck the DFunId declaration, and hence + pull in interfaces that it refers to. See Note [Proper-match fields]. + +* Rough-match fields. During instance lookup, we use the is_cls_nm :: Name and + is_tcs :: [Maybe Name] fields to perform a "rough match", *without* poking + inside the DFunId. The rough-match fields allow us to say "definitely does not + match", based only on Names. + + This laziness is very important; see #12367. Try hard to avoid pulling on + the structured fields unless you really need the instance. + +* Another place to watch is InstEnv.instIsVisible, which needs the module to + which the ClsInst belongs. We can get this from is_dfun_name. + +* In is_tcs, + Nothing means that this type arg is a type variable + + (Just n) means that this type arg is a + TyConApp with a type constructor of n. + This is always a real tycon, never a synonym! + (Two different synonyms might match, but two + different real tycons can't.) + NB: newtypes are not transparent, though! +-} + +{- +Note [Template tyvars are fresh] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The is_tvs field of a ClsInst has *completely fresh* tyvars. +That is, they are + * distinct from any other ClsInst + * distinct from any tyvars free in predicates that may + be looked up in the class instance environment +Reason for freshness: we use unification when checking for overlap +etc, and that requires the tyvars to be distinct. + +The invariant is checked by the ASSERT in lookupInstEnv'. + +Note [Proper-match fields] +~~~~~~~~~~~~~~~~~~~~~~~~~ +The is_tvs, is_cls, is_tys fields are simply cached values, pulled +out (lazily) from the dfun id. They are cached here simply so +that we don't need to decompose the DFunId each time we want +to match it. The hope is that the rough-match fields mean +that we often never poke the proper-match fields. + +However, note that: + * is_tvs must be a superset of the free vars of is_tys + + * is_tvs, is_tys may be alpha-renamed compared to the ones in + the dfun Id + +Note [Haddock assumptions] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +For normal user-written instances, Haddock relies on + + * the SrcSpan of + * the Name of + * the is_dfun of + * an Instance + +being equal to + + * the SrcSpan of + * the instance head type of + * the InstDecl used to construct the Instance. +-} + +instanceDFunId :: ClsInst -> DFunId +instanceDFunId = is_dfun + +tidyClsInstDFun :: (DFunId -> DFunId) -> ClsInst -> ClsInst +tidyClsInstDFun tidy_dfun ispec + = ispec { is_dfun = tidy_dfun (is_dfun ispec) } + +instanceRoughTcs :: ClsInst -> [Maybe Name] +instanceRoughTcs = is_tcs + + +instance NamedThing ClsInst where + getName ispec = getName (is_dfun ispec) + +instance Outputable ClsInst where + ppr = pprInstance + +pprInstance :: ClsInst -> SDoc +-- Prints the ClsInst as an instance declaration +pprInstance ispec + = hang (pprInstanceHdr ispec) + 2 (vcat [ text "--" <+> pprDefinedAt (getName ispec) + , whenPprDebug (ppr (is_dfun ispec)) ]) + +-- * pprInstanceHdr is used in VStudio to populate the ClassView tree +pprInstanceHdr :: ClsInst -> SDoc +-- Prints the ClsInst as an instance declaration +pprInstanceHdr (ClsInst { is_flag = flag, is_dfun = dfun }) + = text "instance" <+> ppr flag <+> pprSigmaType (idType dfun) + +pprInstances :: [ClsInst] -> SDoc +pprInstances ispecs = vcat (map pprInstance ispecs) + +instanceHead :: ClsInst -> ([TyVar], Class, [Type]) +-- Returns the head, using the fresh tyavs from the ClsInst +instanceHead (ClsInst { is_tvs = tvs, is_tys = tys, is_dfun = dfun }) + = (tvs, cls, tys) + where + (_, _, cls, _) = tcSplitDFunTy (idType dfun) + +-- | Collects the names of concrete types and type constructors that make +-- up the head of a class instance. For instance, given `class Foo a b`: +-- +-- `instance Foo (Either (Maybe Int) a) Bool` would yield +-- [Either, Maybe, Int, Bool] +-- +-- Used in the implementation of ":info" in GHCi. +-- +-- The 'tcSplitSigmaTy' is because of +-- instance Foo a => Baz T where ... +-- The decl is an orphan if Baz and T are both not locally defined, +-- even if Foo *is* locally defined +orphNamesOfClsInst :: ClsInst -> NameSet +orphNamesOfClsInst (ClsInst { is_cls_nm = cls_nm, is_tys = tys }) + = orphNamesOfTypes tys `unionNameSet` unitNameSet cls_nm + +instanceSig :: ClsInst -> ([TyVar], [Type], Class, [Type]) +-- Decomposes the DFunId +instanceSig ispec = tcSplitDFunTy (idType (is_dfun ispec)) + +mkLocalInstance :: DFunId -> OverlapFlag + -> [TyVar] -> Class -> [Type] + -> ClsInst +-- Used for local instances, where we can safely pull on the DFunId. +-- Consider using newClsInst instead; this will also warn if +-- the instance is an orphan. +mkLocalInstance dfun oflag tvs cls tys + = ClsInst { is_flag = oflag, is_dfun = dfun + , is_tvs = tvs + , is_dfun_name = dfun_name + , is_cls = cls, is_cls_nm = cls_name + , is_tys = tys, is_tcs = roughMatchTcs tys + , is_orphan = orph + } + where + cls_name = className cls + dfun_name = idName dfun + this_mod = ASSERT( isExternalName dfun_name ) nameModule dfun_name + is_local name = nameIsLocalOrFrom this_mod name + + -- Compute orphanhood. See Note [Orphans] in InstEnv + (cls_tvs, fds) = classTvsFds cls + arg_names = [filterNameSet is_local (orphNamesOfType ty) | ty <- tys] + + -- See Note [When exactly is an instance decl an orphan?] + orph | is_local cls_name = NotOrphan (nameOccName cls_name) + | all notOrphan mb_ns = ASSERT( not (null mb_ns) ) head mb_ns + | otherwise = IsOrphan + + notOrphan NotOrphan{} = True + notOrphan _ = False + + mb_ns :: [IsOrphan] -- One for each fundep; a locally-defined name + -- that is not in the "determined" arguments + mb_ns | null fds = [choose_one arg_names] + | otherwise = map do_one fds + do_one (_ltvs, rtvs) = choose_one [ns | (tv,ns) <- cls_tvs `zip` arg_names + , not (tv `elem` rtvs)] + + choose_one nss = chooseOrphanAnchor (unionNameSets nss) + +mkImportedInstance :: Name -- ^ the name of the class + -> [Maybe Name] -- ^ the types which the class was applied to + -> Name -- ^ the 'Name' of the dictionary binding + -> DFunId -- ^ the 'Id' of the dictionary. + -> OverlapFlag -- ^ may this instance overlap? + -> IsOrphan -- ^ is this instance an orphan? + -> ClsInst +-- Used for imported instances, where we get the rough-match stuff +-- from the interface file +-- The bound tyvars of the dfun are guaranteed fresh, because +-- the dfun has been typechecked out of the same interface file +mkImportedInstance cls_nm mb_tcs dfun_name dfun oflag orphan + = ClsInst { is_flag = oflag, is_dfun = dfun + , is_tvs = tvs, is_tys = tys + , is_dfun_name = dfun_name + , is_cls_nm = cls_nm, is_cls = cls, is_tcs = mb_tcs + , is_orphan = orphan } + where + (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun) + +{- +Note [When exactly is an instance decl an orphan?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + (see MkIface.instanceToIfaceInst, which implements this) +Roughly speaking, an instance is an orphan if its head (after the =>) +mentions nothing defined in this module. + +Functional dependencies complicate the situation though. Consider + + module M where { class C a b | a -> b } + +and suppose we are compiling module X: + + module X where + import M + data T = ... + instance C Int T where ... + +This instance is an orphan, because when compiling a third module Y we +might get a constraint (C Int v), and we'd want to improve v to T. So +we must make sure X's instances are loaded, even if we do not directly +use anything from X. + +More precisely, an instance is an orphan iff + + If there are no fundeps, then at least of the names in + the instance head is locally defined. + + If there are fundeps, then for every fundep, at least one of the + names free in a *non-determined* part of the instance head is + defined in this module. + +(Note that these conditions hold trivially if the class is locally +defined.) + + +************************************************************************ +* * + InstEnv, ClsInstEnv +* * +************************************************************************ + +A @ClsInstEnv@ all the instances of that class. The @Id@ inside a +ClsInstEnv mapping is the dfun for that instance. + +If class C maps to a list containing the item ([a,b], [t1,t2,t3], dfun), then + + forall a b, C t1 t2 t3 can be constructed by dfun + +or, to put it another way, we have + + instance (...) => C t1 t2 t3, witnessed by dfun +-} + +--------------------------------------------------- +{- +Note [InstEnv determinism] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +We turn InstEnvs into a list in some places that don't directly affect +the ABI. That happens when we create output for `:info`. +Unfortunately that nondeterminism is nonlocal and it's hard to tell what it +affects without following a chain of functions. It's also easy to accidentally +make that nondeterminism affect the ABI. Furthermore the envs should be +relatively small, so it should be free to use deterministic maps here. +Testing with nofib and validate detected no difference between UniqFM and +UniqDFM. See also Note [Deterministic UniqFM] +-} + +type InstEnv = UniqDFM ClsInstEnv -- Maps Class to instances for that class + -- See Note [InstEnv determinism] + +-- | 'InstEnvs' represents the combination of the global type class instance +-- environment, the local type class instance environment, and the set of +-- transitively reachable orphan modules (according to what modules have been +-- directly imported) used to test orphan instance visibility. +data InstEnvs = InstEnvs { + ie_global :: InstEnv, -- External-package instances + ie_local :: InstEnv, -- Home-package instances + ie_visible :: VisibleOrphanModules -- Set of all orphan modules transitively + -- reachable from the module being compiled + -- See Note [Instance lookup and orphan instances] + } + +-- | Set of visible orphan modules, according to what modules have been directly +-- imported. This is based off of the dep_orphs field, which records +-- transitively reachable orphan modules (modules that define orphan instances). +type VisibleOrphanModules = ModuleSet + +newtype ClsInstEnv + = ClsIE [ClsInst] -- The instances for a particular class, in any order + +instance Outputable ClsInstEnv where + ppr (ClsIE is) = pprInstances is + +-- INVARIANTS: +-- * The is_tvs are distinct in each ClsInst +-- of a ClsInstEnv (so we can safely unify them) + +-- Thus, the @ClassInstEnv@ for @Eq@ might contain the following entry: +-- [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a] +-- The "a" in the pattern must be one of the forall'd variables in +-- the dfun type. + +emptyInstEnv :: InstEnv +emptyInstEnv = emptyUDFM + +instEnvElts :: InstEnv -> [ClsInst] +instEnvElts ie = [elt | ClsIE elts <- eltsUDFM ie, elt <- elts] + -- See Note [InstEnv determinism] + +-- | Test if an instance is visible, by checking that its origin module +-- is in 'VisibleOrphanModules'. +-- See Note [Instance lookup and orphan instances] +instIsVisible :: VisibleOrphanModules -> ClsInst -> Bool +instIsVisible vis_mods ispec + -- NB: Instances from the interactive package always are visible. We can't + -- add interactive modules to the set since we keep creating new ones + -- as a GHCi session progresses. + = case nameModule_maybe (is_dfun_name ispec) of + Nothing -> True + Just mod | isInteractiveModule mod -> True + | IsOrphan <- is_orphan ispec -> mod `elemModuleSet` vis_mods + | otherwise -> True + +classInstances :: InstEnvs -> Class -> [ClsInst] +classInstances (InstEnvs { ie_global = pkg_ie, ie_local = home_ie, ie_visible = vis_mods }) cls + = get home_ie ++ get pkg_ie + where + get env = case lookupUDFM env cls of + Just (ClsIE insts) -> filter (instIsVisible vis_mods) insts + Nothing -> [] + +-- | Checks for an exact match of ClsInst in the instance environment. +-- We use this when we do signature checking in TcRnDriver +memberInstEnv :: InstEnv -> ClsInst -> Bool +memberInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm } ) = + maybe False (\(ClsIE items) -> any (identicalDFunType ins_item) items) + (lookupUDFM inst_env cls_nm) + where + identicalDFunType cls1 cls2 = + eqType (varType (is_dfun cls1)) (varType (is_dfun cls2)) + +extendInstEnvList :: InstEnv -> [ClsInst] -> InstEnv +extendInstEnvList inst_env ispecs = foldl' extendInstEnv inst_env ispecs + +extendInstEnv :: InstEnv -> ClsInst -> InstEnv +extendInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm }) + = addToUDFM_C add inst_env cls_nm (ClsIE [ins_item]) + where + add (ClsIE cur_insts) _ = ClsIE (ins_item : cur_insts) + +deleteFromInstEnv :: InstEnv -> ClsInst -> InstEnv +deleteFromInstEnv inst_env ins_item@(ClsInst { is_cls_nm = cls_nm }) + = adjustUDFM adjust inst_env cls_nm + where + adjust (ClsIE items) = ClsIE (filterOut (identicalClsInstHead ins_item) items) + +deleteDFunFromInstEnv :: InstEnv -> DFunId -> InstEnv +-- Delete a specific instance fron an InstEnv +deleteDFunFromInstEnv inst_env dfun + = adjustUDFM adjust inst_env cls + where + (_, _, cls, _) = tcSplitDFunTy (idType dfun) + adjust (ClsIE items) = ClsIE (filterOut same_dfun items) + same_dfun (ClsInst { is_dfun = dfun' }) = dfun == dfun' + +identicalClsInstHead :: ClsInst -> ClsInst -> Bool +-- ^ True when when the instance heads are the same +-- e.g. both are Eq [(a,b)] +-- Used for overriding in GHCi +-- Obviously should be insenstive to alpha-renaming +identicalClsInstHead (ClsInst { is_cls_nm = cls_nm1, is_tcs = rough1, is_tys = tys1 }) + (ClsInst { is_cls_nm = cls_nm2, is_tcs = rough2, is_tys = tys2 }) + = cls_nm1 == cls_nm2 + && not (instanceCantMatch rough1 rough2) -- Fast check for no match, uses the "rough match" fields + && isJust (tcMatchTys tys1 tys2) + && isJust (tcMatchTys tys2 tys1) + +{- +************************************************************************ +* * + Looking up an instance +* * +************************************************************************ + +@lookupInstEnv@ looks up in a @InstEnv@, using a one-way match. Since +the env is kept ordered, the first match must be the only one. The +thing we are looking up can have an arbitrary "flexi" part. + +Note [Instance lookup and orphan instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we are compiling a module M, and we have a zillion packages +loaded, and we are looking up an instance for C (T W). If we find a +match in module 'X' from package 'p', should be "in scope"; that is, + + is p:X in the transitive closure of modules imported from M? + +The difficulty is that the "zillion packages" might include ones loaded +through earlier invocations of the GHC API, or earlier module loads in GHCi. +They might not be in the dependencies of M itself; and if not, the instances +in them should not be visible. #2182, #8427. + +There are two cases: + * If the instance is *not an orphan*, then module X defines C, T, or W. + And in order for those types to be involved in typechecking M, it + must be that X is in the transitive closure of M's imports. So we + can use the instance. + + * If the instance *is an orphan*, the above reasoning does not apply. + So we keep track of the set of orphan modules transitively below M; + this is the ie_visible field of InstEnvs, of type VisibleOrphanModules. + + If module p:X is in this set, then we can use the instance, otherwise + we can't. + +Note [Rules for instance lookup] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +These functions implement the carefully-written rules in the user +manual section on "overlapping instances". At risk of duplication, +here are the rules. If the rules change, change this text and the +user manual simultaneously. The link may be this: +http://www.haskell.org/ghc/docs/latest/html/users_guide/glasgow_exts.html#instance-overlap + +The willingness to be overlapped or incoherent is a property of the +instance declaration itself, controlled as follows: + + * An instance is "incoherent" + if it has an INCOHERENT pragma, or + if it appears in a module compiled with -XIncoherentInstances. + + * An instance is "overlappable" + if it has an OVERLAPPABLE or OVERLAPS pragma, or + if it appears in a module compiled with -XOverlappingInstances, or + if the instance is incoherent. + + * An instance is "overlapping" + if it has an OVERLAPPING or OVERLAPS pragma, or + if it appears in a module compiled with -XOverlappingInstances, or + if the instance is incoherent. + compiled with -XOverlappingInstances. + +Now suppose that, in some client module, we are searching for an instance +of the target constraint (C ty1 .. tyn). The search works like this. + +* Find all instances `I` that *match* the target constraint; that is, the + target constraint is a substitution instance of `I`. These instance + declarations are the *candidates*. + +* Eliminate any candidate `IX` for which both of the following hold: + + - There is another candidate `IY` that is strictly more specific; that + is, `IY` is a substitution instance of `IX` but not vice versa. + + - Either `IX` is *overlappable*, or `IY` is *overlapping*. (This + "either/or" design, rather than a "both/and" design, allow a + client to deliberately override an instance from a library, + without requiring a change to the library.) + +- If exactly one non-incoherent candidate remains, select it. If all + remaining candidates are incoherent, select an arbitrary one. + Otherwise the search fails (i.e. when more than one surviving + candidate is not incoherent). + +- If the selected candidate (from the previous step) is incoherent, the + search succeeds, returning that candidate. + +- If not, find all instances that *unify* with the target constraint, + but do not *match* it. Such non-candidate instances might match when + the target constraint is further instantiated. If all of them are + incoherent, the search succeeds, returning the selected candidate; if + not, the search fails. + +Notice that these rules are not influenced by flag settings in the +client module, where the instances are *used*. These rules make it +possible for a library author to design a library that relies on +overlapping instances without the client having to know. + +Note [Overlapping instances] (NB: these notes are quite old) +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Overlap is permitted, but only in such a way that one can make +a unique choice when looking up. That is, overlap is only permitted if +one template matches the other, or vice versa. So this is ok: + + [a] [Int] + +but this is not + + (Int,a) (b,Int) + +If overlap is permitted, the list is kept most specific first, so that +the first lookup is the right choice. + + +For now we just use association lists. + +\subsection{Avoiding a problem with overlapping} + +Consider this little program: + +\begin{pseudocode} + class C a where c :: a + class C a => D a where d :: a + + instance C Int where c = 17 + instance D Int where d = 13 + + instance C a => C [a] where c = [c] + instance ({- C [a], -} D a) => D [a] where d = c + + instance C [Int] where c = [37] + + main = print (d :: [Int]) +\end{pseudocode} + +What do you think `main' prints (assuming we have overlapping instances, and +all that turned on)? Well, the instance for `D' at type `[a]' is defined to +be `c' at the same type, and we've got an instance of `C' at `[Int]', so the +answer is `[37]', right? (the generic `C [a]' instance shouldn't apply because +the `C [Int]' instance is more specific). + +Ghc-4.04 gives `[37]', while ghc-4.06 gives `[17]', so 4.06 is wrong. That +was easy ;-) Let's just consult hugs for good measure. Wait - if I use old +hugs (pre-September99), I get `[17]', and stranger yet, if I use hugs98, it +doesn't even compile! What's going on!? + +What hugs complains about is the `D [a]' instance decl. + +\begin{pseudocode} + ERROR "mj.hs" (line 10): Cannot build superclass instance + *** Instance : D [a] + *** Context supplied : D a + *** Required superclass : C [a] +\end{pseudocode} + +You might wonder what hugs is complaining about. It's saying that you +need to add `C [a]' to the context of the `D [a]' instance (as appears +in comments). But there's that `C [a]' instance decl one line above +that says that I can reduce the need for a `C [a]' instance to the +need for a `C a' instance, and in this case, I already have the +necessary `C a' instance (since we have `D a' explicitly in the +context, and `C' is a superclass of `D'). + +Unfortunately, the above reasoning indicates a premature commitment to the +generic `C [a]' instance. I.e., it prematurely rules out the more specific +instance `C [Int]'. This is the mistake that ghc-4.06 makes. The fix is to +add the context that hugs suggests (uncomment the `C [a]'), effectively +deferring the decision about which instance to use. + +Now, interestingly enough, 4.04 has this same bug, but it's covered up +in this case by a little known `optimization' that was disabled in +4.06. Ghc-4.04 silently inserts any missing superclass context into +an instance declaration. In this case, it silently inserts the `C +[a]', and everything happens to work out. + +(See `basicTypes/MkId:mkDictFunId' for the code in question. Search for +`Mark Jones', although Mark claims no credit for the `optimization' in +question, and would rather it stopped being called the `Mark Jones +optimization' ;-) + +So, what's the fix? I think hugs has it right. Here's why. Let's try +something else out with ghc-4.04. Let's add the following line: + + d' :: D a => [a] + d' = c + +Everyone raise their hand who thinks that `d :: [Int]' should give a +different answer from `d' :: [Int]'. Well, in ghc-4.04, it does. The +`optimization' only applies to instance decls, not to regular +bindings, giving inconsistent behavior. + +Old hugs had this same bug. Here's how we fixed it: like GHC, the +list of instances for a given class is ordered, so that more specific +instances come before more generic ones. For example, the instance +list for C might contain: + ..., C Int, ..., C a, ... +When we go to look for a `C Int' instance we'll get that one first. +But what if we go looking for a `C b' (`b' is unconstrained)? We'll +pass the `C Int' instance, and keep going. But if `b' is +unconstrained, then we don't know yet if the more specific instance +will eventually apply. GHC keeps going, and matches on the generic `C +a'. The fix is to, at each step, check to see if there's a reverse +match, and if so, abort the search. This prevents hugs from +prematurely chosing a generic instance when a more specific one +exists. + +--Jeff + +BUT NOTE [Nov 2001]: we must actually *unify* not reverse-match in +this test. Suppose the instance envt had + ..., forall a b. C a a b, ..., forall a b c. C a b c, ... +(still most specific first) +Now suppose we are looking for (C x y Int), where x and y are unconstrained. + C x y Int doesn't match the template {a,b} C a a b +but neither does + C a a b match the template {x,y} C x y Int +But still x and y might subsequently be unified so they *do* match. + +Simple story: unify, don't match. +-} + +type DFunInstType = Maybe Type + -- Just ty => Instantiate with this type + -- Nothing => Instantiate with any type of this tyvar's kind + -- See Note [DFunInstType: instantiating types] + +type InstMatch = (ClsInst, [DFunInstType]) + +type ClsInstLookupResult + = ( [InstMatch] -- Successful matches + , [ClsInst] -- These don't match but do unify + , [InstMatch] ) -- Unsafe overlapped instances under Safe Haskell + -- (see Note [Safe Haskell Overlapping Instances] in + -- TcSimplify). + +{- +Note [DFunInstType: instantiating types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A successful match is a ClsInst, together with the types at which + the dfun_id in the ClsInst should be instantiated +The instantiating types are (Either TyVar Type)s because the dfun +might have some tyvars that *only* appear in arguments + dfun :: forall a b. C a b, Ord b => D [a] +When we match this against D [ty], we return the instantiating types + [Just ty, Nothing] +where the 'Nothing' indicates that 'b' can be freely instantiated. +(The caller instantiates it to a flexi type variable, which will + presumably later become fixed via functional dependencies.) +-} + +-- |Look up an instance in the given instance environment. The given class application must match exactly +-- one instance and the match may not contain any flexi type variables. If the lookup is unsuccessful, +-- yield 'Left errorMessage'. +lookupUniqueInstEnv :: InstEnvs + -> Class -> [Type] + -> Either MsgDoc (ClsInst, [Type]) +lookupUniqueInstEnv instEnv cls tys + = case lookupInstEnv False instEnv cls tys of + ([(inst, inst_tys)], _, _) + | noFlexiVar -> Right (inst, inst_tys') + | otherwise -> Left $ text "flexible type variable:" <+> + (ppr $ mkTyConApp (classTyCon cls) tys) + where + inst_tys' = [ty | Just ty <- inst_tys] + noFlexiVar = all isJust inst_tys + _other -> Left $ text "instance not found" <+> + (ppr $ mkTyConApp (classTyCon cls) tys) + +lookupInstEnv' :: InstEnv -- InstEnv to look in + -> VisibleOrphanModules -- But filter against this + -> Class -> [Type] -- What we are looking for + -> ([InstMatch], -- Successful matches + [ClsInst]) -- These don't match but do unify + -- (no incoherent ones in here) +-- The second component of the result pair happens when we look up +-- Foo [a] +-- in an InstEnv that has entries for +-- Foo [Int] +-- Foo [b] +-- Then which we choose would depend on the way in which 'a' +-- is instantiated. So we report that Foo [b] is a match (mapping b->a) +-- but Foo [Int] is a unifier. This gives the caller a better chance of +-- giving a suitable error message + +lookupInstEnv' ie vis_mods cls tys + = lookup ie + where + rough_tcs = roughMatchTcs tys + all_tvs = all isNothing rough_tcs + + -------------- + lookup env = case lookupUDFM env cls of + Nothing -> ([],[]) -- No instances for this class + Just (ClsIE insts) -> find [] [] insts + + -------------- + find ms us [] = (ms, us) + find ms us (item@(ClsInst { is_tcs = mb_tcs, is_tvs = tpl_tvs + , is_tys = tpl_tys }) : rest) + | not (instIsVisible vis_mods item) + = find ms us rest -- See Note [Instance lookup and orphan instances] + + -- Fast check for no match, uses the "rough match" fields + | instanceCantMatch rough_tcs mb_tcs + = find ms us rest + + | Just subst <- tcMatchTys tpl_tys tys + = find ((item, map (lookupTyVar subst) tpl_tvs) : ms) us rest + + -- Does not match, so next check whether the things unify + -- See Note [Overlapping instances] + -- Ignore ones that are incoherent: Note [Incoherent instances] + | isIncoherent item + = find ms us rest + + | otherwise + = ASSERT2( tyCoVarsOfTypes tys `disjointVarSet` tpl_tv_set, + (ppr cls <+> ppr tys <+> ppr all_tvs) $$ + (ppr tpl_tvs <+> ppr tpl_tys) + ) + -- Unification will break badly if the variables overlap + -- They shouldn't because we allocate separate uniques for them + -- See Note [Template tyvars are fresh] + case tcUnifyTys instanceBindFun tpl_tys tys of + Just _ -> find ms (item:us) rest + Nothing -> find ms us rest + where + tpl_tv_set = mkVarSet tpl_tvs + +--------------- +-- This is the common way to call this function. +lookupInstEnv :: Bool -- Check Safe Haskell overlap restrictions + -> InstEnvs -- External and home package inst-env + -> Class -> [Type] -- What we are looking for + -> ClsInstLookupResult +-- ^ See Note [Rules for instance lookup] +-- ^ See Note [Safe Haskell Overlapping Instances] in TcSimplify +-- ^ See Note [Safe Haskell Overlapping Instances Implementation] in TcSimplify +lookupInstEnv check_overlap_safe + (InstEnvs { ie_global = pkg_ie + , ie_local = home_ie + , ie_visible = vis_mods }) + cls + tys + = -- pprTrace "lookupInstEnv" (ppr cls <+> ppr tys $$ ppr home_ie) $ + (final_matches, final_unifs, unsafe_overlapped) + where + (home_matches, home_unifs) = lookupInstEnv' home_ie vis_mods cls tys + (pkg_matches, pkg_unifs) = lookupInstEnv' pkg_ie vis_mods cls tys + all_matches = home_matches ++ pkg_matches + all_unifs = home_unifs ++ pkg_unifs + final_matches = foldr insert_overlapping [] all_matches + -- Even if the unifs is non-empty (an error situation) + -- we still prune the matches, so that the error message isn't + -- misleading (complaining of multiple matches when some should be + -- overlapped away) + + unsafe_overlapped + = case final_matches of + [match] -> check_safe match + _ -> [] + + -- If the selected match is incoherent, discard all unifiers + final_unifs = case final_matches of + (m:_) | isIncoherent (fst m) -> [] + _ -> all_unifs + + -- NOTE [Safe Haskell isSafeOverlap] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- We restrict code compiled in 'Safe' mode from overriding code + -- compiled in any other mode. The rationale is that code compiled + -- in 'Safe' mode is code that is untrusted by the ghc user. So + -- we shouldn't let that code change the behaviour of code the + -- user didn't compile in 'Safe' mode since that's the code they + -- trust. So 'Safe' instances can only overlap instances from the + -- same module. A same instance origin policy for safe compiled + -- instances. + check_safe (inst,_) + = case check_overlap_safe && unsafeTopInstance inst of + -- make sure it only overlaps instances from the same module + True -> go [] all_matches + -- most specific is from a trusted location. + False -> [] + where + go bad [] = bad + go bad (i@(x,_):unchecked) = + if inSameMod x || isOverlappable x + then go bad unchecked + else go (i:bad) unchecked + + inSameMod b = + let na = getName $ getName inst + la = isInternalName na + nb = getName $ getName b + lb = isInternalName nb + in (la && lb) || (nameModule na == nameModule nb) + + -- We consider the most specific instance unsafe when it both: + -- (1) Comes from a module compiled as `Safe` + -- (2) Is an orphan instance, OR, an instance for a MPTC + unsafeTopInstance inst = isSafeOverlap (is_flag inst) && + (isOrphan (is_orphan inst) || classArity (is_cls inst) > 1) + +--------------- +insert_overlapping :: InstMatch -> [InstMatch] -> [InstMatch] +-- ^ Add a new solution, knocking out strictly less specific ones +-- See Note [Rules for instance lookup] +insert_overlapping new_item [] = [new_item] +insert_overlapping new_item@(new_inst,_) (old_item@(old_inst,_) : old_items) + | new_beats_old -- New strictly overrides old + , not old_beats_new + , new_inst `can_override` old_inst + = insert_overlapping new_item old_items + + | old_beats_new -- Old strictly overrides new + , not new_beats_old + , old_inst `can_override` new_inst + = old_item : old_items + + -- Discard incoherent instances; see Note [Incoherent instances] + | isIncoherent old_inst -- Old is incoherent; discard it + = insert_overlapping new_item old_items + | isIncoherent new_inst -- New is incoherent; discard it + = old_item : old_items + + -- Equal or incomparable, and neither is incoherent; keep both + | otherwise + = old_item : insert_overlapping new_item old_items + where + + new_beats_old = new_inst `more_specific_than` old_inst + old_beats_new = old_inst `more_specific_than` new_inst + + -- `instB` can be instantiated to match `instA` + -- or the two are equal + instA `more_specific_than` instB + = isJust (tcMatchTys (is_tys instB) (is_tys instA)) + + instA `can_override` instB + = isOverlapping instA || isOverlappable instB + -- Overlap permitted if either the more specific instance + -- is marked as overlapping, or the more general one is + -- marked as overlappable. + -- Latest change described in: #9242. + -- Previous change: #3877, Dec 10. + +{- +Note [Incoherent instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For some classes, the choice of a particular instance does not matter, any one +is good. E.g. consider + + class D a b where { opD :: a -> b -> String } + instance D Int b where ... + instance D a Int where ... + + g (x::Int) = opD x x -- Wanted: D Int Int + +For such classes this should work (without having to add an "instance D Int +Int", and using -XOverlappingInstances, which would then work). This is what +-XIncoherentInstances is for: Telling GHC "I don't care which instance you use; +if you can use one, use it." + +Should this logic only work when *all* candidates have the incoherent flag, or +even when all but one have it? The right choice is the latter, which can be +justified by comparing the behaviour with how -XIncoherentInstances worked when +it was only about the unify-check (note [Overlapping instances]): + +Example: + class C a b c where foo :: (a,b,c) + instance C [a] b Int + instance [incoherent] [Int] b c + instance [incoherent] C a Int c +Thanks to the incoherent flags, + [Wanted] C [a] b Int +works: Only instance one matches, the others just unify, but are marked +incoherent. + +So I can write + (foo :: ([a],b,Int)) :: ([Int], Int, Int). +but if that works then I really want to be able to write + foo :: ([Int], Int, Int) +as well. Now all three instances from above match. None is more specific than +another, so none is ruled out by the normal overlapping rules. One of them is +not incoherent, but we still want this to compile. Hence the +"all-but-one-logic". + +The implementation is in insert_overlapping, where we remove matching +incoherent instances as long as there are others. + + + +************************************************************************ +* * + Binding decisions +* * +************************************************************************ +-} + +instanceBindFun :: TyCoVar -> BindFlag +instanceBindFun tv | isOverlappableTyVar tv = Skolem + | otherwise = BindMe + -- Note [Binding when looking up instances] + +{- +Note [Binding when looking up instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When looking up in the instance environment, or family-instance environment, +we are careful about multiple matches, as described above in +Note [Overlapping instances] + +The key_tys can contain skolem constants, and we can guarantee that those +are never going to be instantiated to anything, so we should not involve +them in the unification test. Example: + class Foo a where { op :: a -> Int } + instance Foo a => Foo [a] -- NB overlap + instance Foo [Int] -- NB overlap + data T = forall a. Foo a => MkT a + f :: T -> Int + f (MkT x) = op [x,x] +The op [x,x] means we need (Foo [a]). Without the filterVarSet we'd +complain, saying that the choice of instance depended on the instantiation +of 'a'; but of course it isn't *going* to be instantiated. + +We do this only for isOverlappableTyVar skolems. For example we reject + g :: forall a => [a] -> Int + g x = op x +on the grounds that the correct instance depends on the instantiation of 'a' +-} diff --git a/compiler/types/Kind.hs b/compiler/types/Kind.hs new file mode 100644 --- /dev/null +++ b/compiler/types/Kind.hs @@ -0,0 +1,97 @@ +-- (c) The University of Glasgow 2006-2012 + +{-# LANGUAGE CPP #-} +module Kind ( + -- * Main data type + Kind, + + -- ** Predicates on Kinds + isLiftedTypeKind, isUnliftedTypeKind, + isConstraintKindCon, + + classifiesTypeWithValues, + isKindLevPoly + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import {-# SOURCE #-} Type ( coreView ) + +import TyCoRep +import TyCon +import PrelNames + +import Outputable +import Util +import Data.Maybe( isJust ) + +{- +************************************************************************ +* * + Functions over Kinds +* * +************************************************************************ + +Note [Kind Constraint and kind Type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The kind Constraint is the kind of classes and other type constraints. +The special thing about types of kind Constraint is that + * They are displayed with double arrow: + f :: Ord a => a -> a + * They are implicitly instantiated at call sites; so the type inference + engine inserts an extra argument of type (Ord a) at every call site + to f. + +However, once type inference is over, there is *no* distinction between +Constraint and Type. Indeed we can have coercions between the two. Consider + class C a where + op :: a -> a +For this single-method class we may generate a newtype, which in turn +generates an axiom witnessing + C a ~ (a -> a) +so on the left we have Constraint, and on the right we have Type. +See #7451. + +Bottom line: although 'Type' and 'Constraint' are distinct TyCons, with +distinct uniques, they are treated as equal at all times except +during type inference. +-} + +isConstraintKindCon :: TyCon -> Bool +isConstraintKindCon tc = tyConUnique tc == constraintKindTyConKey + +-- | Tests whether the given kind (which should look like @TYPE x@) +-- is something other than a constructor tree (that is, constructors at every node). +-- E.g. True of TYPE k, TYPE (F Int) +-- False of TYPE 'LiftedRep +isKindLevPoly :: Kind -> Bool +isKindLevPoly k = ASSERT2( isLiftedTypeKind k || _is_type, ppr k ) + -- the isLiftedTypeKind check is necessary b/c of Constraint + go k + where + go ty | Just ty' <- coreView ty = go ty' + go TyVarTy{} = True + go AppTy{} = True -- it can't be a TyConApp + go (TyConApp tc tys) = isFamilyTyCon tc || any go tys + go ForAllTy{} = True + go (FunTy _ t1 t2) = go t1 || go t2 + go LitTy{} = False + go CastTy{} = True + go CoercionTy{} = True + + _is_type = classifiesTypeWithValues k + +----------------------------------------- +-- Subkinding +-- The tc variants are used during type-checking, where ConstraintKind +-- is distinct from all other kinds +-- After type-checking (in core), Constraint and liftedTypeKind are +-- indistinguishable + +-- | Does this classify a type allowed to have values? Responds True to things +-- like *, #, TYPE Lifted, TYPE v, Constraint. +classifiesTypeWithValues :: Kind -> Bool +-- ^ True of any sub-kind of OpenTypeKind +classifiesTypeWithValues k = isJust (kindRep_maybe k) diff --git a/compiler/types/OptCoercion.hs b/compiler/types/OptCoercion.hs new file mode 100644 --- /dev/null +++ b/compiler/types/OptCoercion.hs @@ -0,0 +1,1204 @@ +-- (c) The University of Glasgow 2006 + +{-# LANGUAGE CPP #-} + +module OptCoercion ( optCoercion, checkAxInstCo ) where + +#include "HsVersions.h" + +import GhcPrelude + +import DynFlags +import TyCoRep +import Coercion +import Type hiding( substTyVarBndr, substTy ) +import TcType ( exactTyCoVarsOfType ) +import TyCon +import CoAxiom +import VarSet +import VarEnv +import Outputable +import FamInstEnv ( flattenTys ) +import Pair +import ListSetOps ( getNth ) +import Util +import Unify +import InstEnv +import Control.Monad ( zipWithM ) + +{- +%************************************************************************ +%* * + Optimising coercions +%* * +%************************************************************************ + +Note [Optimising coercion optimisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Looking up a coercion's role or kind is linear in the size of the +coercion. Thus, doing this repeatedly during the recursive descent +of coercion optimisation is disastrous. We must be careful to avoid +doing this if at all possible. + +Because it is generally easy to know a coercion's components' roles +from the role of the outer coercion, we pass down the known role of +the input in the algorithm below. We also keep functions opt_co2 +and opt_co3 separate from opt_co4, so that the former two do Phantom +checks that opt_co4 can avoid. This is a big win because Phantom coercions +rarely appear within non-phantom coercions -- only in some TyConAppCos +and some AxiomInstCos. We handle these cases specially by calling +opt_co2. + +Note [Optimising InstCo] +~~~~~~~~~~~~~~~~~~~~~~~~ +(1) tv is a type variable +When we have (InstCo (ForAllCo tv h g) g2), we want to optimise. + +Let's look at the typing rules. + +h : k1 ~ k2 +tv:k1 |- g : t1 ~ t2 +----------------------------- +ForAllCo tv h g : (all tv:k1.t1) ~ (all tv:k2.t2[tv |-> tv |> sym h]) + +g1 : (all tv:k1.t1') ~ (all tv:k2.t2') +g2 : s1 ~ s2 +-------------------- +InstCo g1 g2 : t1'[tv |-> s1] ~ t2'[tv |-> s2] + +We thus want some coercion proving this: + + (t1[tv |-> s1]) ~ (t2[tv |-> s2 |> sym h]) + +If we substitute the *type* tv for the *coercion* +(g2 ; t2 ~ t2 |> sym h) in g, we'll get this result exactly. +This is bizarre, +though, because we're substituting a type variable with a coercion. However, +this operation already exists: it's called *lifting*, and defined in Coercion. +We just need to enhance the lifting operation to be able to deal with +an ambient substitution, which is why a LiftingContext stores a TCvSubst. + +(2) cv is a coercion variable +Now consider we have (InstCo (ForAllCo cv h g) g2), we want to optimise. + +h : (t1 ~r t2) ~N (t3 ~r t4) +cv : t1 ~r t2 |- g : t1' ~r2 t2' +n1 = nth r 2 (downgradeRole r N h) :: t1 ~r t3 +n2 = nth r 3 (downgradeRole r N h) :: t2 ~r t4 +------------------------------------------------ +ForAllCo cv h g : (all cv:t1 ~r t2. t1') ~r2 + (all cv:t3 ~r t4. t2'[cv |-> n1 ; cv ; sym n2]) + +g1 : (all cv:t1 ~r t2. t1') ~ (all cv: t3 ~r t4. t2') +g2 : h1 ~N h2 +h1 : t1 ~r t2 +h2 : t3 ~r t4 +------------------------------------------------ +InstCo g1 g2 : t1'[cv |-> h1] ~ t2'[cv |-> h2] + +We thus want some coercion proving this: + + t1'[cv |-> h1] ~ t2'[cv |-> n1 ; h2; sym n2] + +So we substitute the coercion variable c for the coercion +(h1 ~N (n1; h2; sym n2)) in g. +-} + +optCoercion :: DynFlags -> TCvSubst -> Coercion -> NormalCo +-- ^ optCoercion applies a substitution to a coercion, +-- *and* optimises it to reduce its size +optCoercion dflags env co + | hasNoOptCoercion dflags = substCo env co + | otherwise = optCoercion' env co + +optCoercion' :: TCvSubst -> Coercion -> NormalCo +optCoercion' env co + | debugIsOn + = let out_co = opt_co1 lc False co + (Pair in_ty1 in_ty2, in_role) = coercionKindRole co + (Pair out_ty1 out_ty2, out_role) = coercionKindRole out_co + in + ASSERT2( substTy env in_ty1 `eqType` out_ty1 && + substTy env in_ty2 `eqType` out_ty2 && + in_role == out_role + , text "optCoercion changed types!" + $$ hang (text "in_co:") 2 (ppr co) + $$ hang (text "in_ty1:") 2 (ppr in_ty1) + $$ hang (text "in_ty2:") 2 (ppr in_ty2) + $$ hang (text "out_co:") 2 (ppr out_co) + $$ hang (text "out_ty1:") 2 (ppr out_ty1) + $$ hang (text "out_ty2:") 2 (ppr out_ty2) + $$ hang (text "subst:") 2 (ppr env) ) + out_co + + | otherwise = opt_co1 lc False co + where + lc = mkSubstLiftingContext env + +type NormalCo = Coercion + -- Invariants: + -- * The substitution has been fully applied + -- * For trans coercions (co1 `trans` co2) + -- co1 is not a trans, and neither co1 nor co2 is identity + +type NormalNonIdCo = NormalCo -- Extra invariant: not the identity + +-- | Do we apply a @sym@ to the result? +type SymFlag = Bool + +-- | Do we force the result to be representational? +type ReprFlag = Bool + +-- | Optimize a coercion, making no assumptions. All coercions in +-- the lifting context are already optimized (and sym'd if nec'y) +opt_co1 :: LiftingContext + -> SymFlag + -> Coercion -> NormalCo +opt_co1 env sym co = opt_co2 env sym (coercionRole co) co + +-- See Note [Optimising coercion optimisation] +-- | Optimize a coercion, knowing the coercion's role. No other assumptions. +opt_co2 :: LiftingContext + -> SymFlag + -> Role -- ^ The role of the input coercion + -> Coercion -> NormalCo +opt_co2 env sym Phantom co = opt_phantom env sym co +opt_co2 env sym r co = opt_co3 env sym Nothing r co + +-- See Note [Optimising coercion optimisation] +-- | Optimize a coercion, knowing the coercion's non-Phantom role. +opt_co3 :: LiftingContext -> SymFlag -> Maybe Role -> Role -> Coercion -> NormalCo +opt_co3 env sym (Just Phantom) _ co = opt_phantom env sym co +opt_co3 env sym (Just Representational) r co = opt_co4_wrap env sym True r co + -- if mrole is Just Nominal, that can't be a downgrade, so we can ignore +opt_co3 env sym _ r co = opt_co4_wrap env sym False r co + +-- See Note [Optimising coercion optimisation] +-- | Optimize a non-phantom coercion. +opt_co4, opt_co4_wrap :: LiftingContext -> SymFlag -> ReprFlag -> Role -> Coercion -> NormalCo + +opt_co4_wrap = opt_co4 +{- +opt_co4_wrap env sym rep r co + = pprTrace "opt_co4_wrap {" + ( vcat [ text "Sym:" <+> ppr sym + , text "Rep:" <+> ppr rep + , text "Role:" <+> ppr r + , text "Co:" <+> ppr co ]) $ + ASSERT( r == coercionRole co ) + let result = opt_co4 env sym rep r co in + pprTrace "opt_co4_wrap }" (ppr co $$ text "---" $$ ppr result) $ + result +-} + +opt_co4 env _ rep r (Refl ty) + = ASSERT2( r == Nominal, text "Expected role:" <+> ppr r $$ + text "Found role:" <+> ppr Nominal $$ + text "Type:" <+> ppr ty ) + liftCoSubst (chooseRole rep r) env ty + +opt_co4 env _ rep r (GRefl _r ty MRefl) + = ASSERT2( r == _r, text "Expected role:" <+> ppr r $$ + text "Found role:" <+> ppr _r $$ + text "Type:" <+> ppr ty ) + liftCoSubst (chooseRole rep r) env ty + +opt_co4 env sym rep r (GRefl _r ty (MCo co)) + = ASSERT2( r == _r, text "Expected role:" <+> ppr r $$ + text "Found role:" <+> ppr _r $$ + text "Type:" <+> ppr ty ) + if isGReflCo co || isGReflCo co' + then liftCoSubst r' env ty + else wrapSym sym $ mkCoherenceRightCo r' ty' co' (liftCoSubst r' env ty) + where + r' = chooseRole rep r + ty' = substTy (lcSubstLeft env) ty + co' = opt_co4 env False False Nominal co + +opt_co4 env sym rep r (SymCo co) = opt_co4_wrap env (not sym) rep r co + -- surprisingly, we don't have to do anything to the env here. This is + -- because any "lifting" substitutions in the env are tied to ForAllCos, + -- which treat their left and right sides differently. We don't want to + -- exchange them. + +opt_co4 env sym rep r g@(TyConAppCo _r tc cos) + = ASSERT( r == _r ) + case (rep, r) of + (True, Nominal) -> + mkTyConAppCo Representational tc + (zipWith3 (opt_co3 env sym) + (map Just (tyConRolesRepresentational tc)) + (repeat Nominal) + cos) + (False, Nominal) -> + mkTyConAppCo Nominal tc (map (opt_co4_wrap env sym False Nominal) cos) + (_, Representational) -> + -- must use opt_co2 here, because some roles may be P + -- See Note [Optimising coercion optimisation] + mkTyConAppCo r tc (zipWith (opt_co2 env sym) + (tyConRolesRepresentational tc) -- the current roles + cos) + (_, Phantom) -> pprPanic "opt_co4 sees a phantom!" (ppr g) + +opt_co4 env sym rep r (AppCo co1 co2) + = mkAppCo (opt_co4_wrap env sym rep r co1) + (opt_co4_wrap env sym False Nominal co2) + +opt_co4 env sym rep r (ForAllCo tv k_co co) + = case optForAllCoBndr env sym tv k_co of + (env', tv', k_co') -> mkForAllCo tv' k_co' $ + opt_co4_wrap env' sym rep r co + -- Use the "mk" functions to check for nested Refls + +opt_co4 env sym rep r (FunCo _r co1 co2) + = ASSERT( r == _r ) + if rep + then mkFunCo Representational co1' co2' + else mkFunCo r co1' co2' + where + co1' = opt_co4_wrap env sym rep r co1 + co2' = opt_co4_wrap env sym rep r co2 + +opt_co4 env sym rep r (CoVarCo cv) + | Just co <- lookupCoVar (lcTCvSubst env) cv + = opt_co4_wrap (zapLiftingContext env) sym rep r co + + | ty1 `eqType` ty2 -- See Note [Optimise CoVarCo to Refl] + = mkReflCo (chooseRole rep r) ty1 + + | otherwise + = ASSERT( isCoVar cv1 ) + wrapRole rep r $ wrapSym sym $ + CoVarCo cv1 + + where + Pair ty1 ty2 = coVarTypes cv1 + + cv1 = case lookupInScope (lcInScopeSet env) cv of + Just cv1 -> cv1 + Nothing -> WARN( True, text "opt_co: not in scope:" + <+> ppr cv $$ ppr env) + cv + -- cv1 might have a substituted kind! + +opt_co4 _ _ _ _ (HoleCo h) + = pprPanic "opt_univ fell into a hole" (ppr h) + +opt_co4 env sym rep r (AxiomInstCo con ind cos) + -- Do *not* push sym inside top-level axioms + -- e.g. if g is a top-level axiom + -- g a : f a ~ a + -- then (sym (g ty)) /= g (sym ty) !! + = ASSERT( r == coAxiomRole con ) + wrapRole rep (coAxiomRole con) $ + wrapSym sym $ + -- some sub-cos might be P: use opt_co2 + -- See Note [Optimising coercion optimisation] + AxiomInstCo con ind (zipWith (opt_co2 env False) + (coAxBranchRoles (coAxiomNthBranch con ind)) + cos) + -- Note that the_co does *not* have sym pushed into it + +opt_co4 env sym rep r (UnivCo prov _r t1 t2) + = ASSERT( r == _r ) + opt_univ env sym prov (chooseRole rep r) t1 t2 + +opt_co4 env sym rep r (TransCo co1 co2) + -- sym (g `o` h) = sym h `o` sym g + | sym = opt_trans in_scope co2' co1' + | otherwise = opt_trans in_scope co1' co2' + where + co1' = opt_co4_wrap env sym rep r co1 + co2' = opt_co4_wrap env sym rep r co2 + in_scope = lcInScopeSet env + +opt_co4 env _sym rep r (NthCo _r n co) + | Just (ty, _) <- isReflCo_maybe co + , Just (_tc, args) <- ASSERT( r == _r ) + splitTyConApp_maybe ty + = liftCoSubst (chooseRole rep r) env (args `getNth` n) + | Just (ty, _) <- isReflCo_maybe co + , n == 0 + , Just (tv, _) <- splitForAllTy_maybe ty + -- works for both tyvar and covar + = liftCoSubst (chooseRole rep r) env (varType tv) + +opt_co4 env sym rep r (NthCo r1 n (TyConAppCo _ _ cos)) + = ASSERT( r == r1 ) + opt_co4_wrap env sym rep r (cos `getNth` n) + +opt_co4 env sym rep r (NthCo _r n (ForAllCo _ eta _)) + -- works for both tyvar and covar + = ASSERT( r == _r ) + ASSERT( n == 0 ) + opt_co4_wrap env sym rep Nominal eta + +opt_co4 env sym rep r (NthCo _r n co) + | TyConAppCo _ _ cos <- co' + , let nth_co = cos `getNth` n + = if rep && (r == Nominal) + -- keep propagating the SubCo + then opt_co4_wrap (zapLiftingContext env) False True Nominal nth_co + else nth_co + + | ForAllCo _ eta _ <- co' + = if rep + then opt_co4_wrap (zapLiftingContext env) False True Nominal eta + else eta + + | otherwise + = wrapRole rep r $ NthCo r n co' + where + co' = opt_co1 env sym co + +opt_co4 env sym rep r (LRCo lr co) + | Just pr_co <- splitAppCo_maybe co + = ASSERT( r == Nominal ) + opt_co4_wrap env sym rep Nominal (pick_lr lr pr_co) + | Just pr_co <- splitAppCo_maybe co' + = ASSERT( r == Nominal ) + if rep + then opt_co4_wrap (zapLiftingContext env) False True Nominal (pick_lr lr pr_co) + else pick_lr lr pr_co + | otherwise + = wrapRole rep Nominal $ LRCo lr co' + where + co' = opt_co4_wrap env sym False Nominal co + + pick_lr CLeft (l, _) = l + pick_lr CRight (_, r) = r + +-- See Note [Optimising InstCo] +opt_co4 env sym rep r (InstCo co1 arg) + -- forall over type... + | Just (tv, kind_co, co_body) <- splitForAllCo_ty_maybe co1 + = opt_co4_wrap (extendLiftingContext env tv + (mkCoherenceRightCo Nominal t2 (mkSymCo kind_co) sym_arg)) + -- mkSymCo kind_co :: k1 ~ k2 + -- sym_arg :: (t1 :: k1) ~ (t2 :: k2) + -- tv |-> (t1 :: k1) ~ (((t2 :: k2) |> (sym kind_co)) :: k1) + sym rep r co_body + + -- forall over coercion... + | Just (cv, kind_co, co_body) <- splitForAllCo_co_maybe co1 + , CoercionTy h1 <- t1 + , CoercionTy h2 <- t2 + = let new_co = mk_new_co cv (opt_co4_wrap env sym False Nominal kind_co) h1 h2 + in opt_co4_wrap (extendLiftingContext env cv new_co) sym rep r co_body + + -- See if it is a forall after optimization + -- If so, do an inefficient one-variable substitution, then re-optimize + + -- forall over type... + | Just (tv', kind_co', co_body') <- splitForAllCo_ty_maybe co1' + = opt_co4_wrap (extendLiftingContext (zapLiftingContext env) tv' + (mkCoherenceRightCo Nominal t2' (mkSymCo kind_co') arg')) + False False r' co_body' + + -- forall over coercion... + | Just (cv', kind_co', co_body') <- splitForAllCo_co_maybe co1' + , CoercionTy h1' <- t1' + , CoercionTy h2' <- t2' + = let new_co = mk_new_co cv' kind_co' h1' h2' + in opt_co4_wrap (extendLiftingContext (zapLiftingContext env) cv' new_co) + False False r' co_body' + + | otherwise = InstCo co1' arg' + where + co1' = opt_co4_wrap env sym rep r co1 + r' = chooseRole rep r + arg' = opt_co4_wrap env sym False Nominal arg + sym_arg = wrapSym sym arg' + + -- Performance note: don't be alarmed by the two calls to coercionKind + -- here, as only one call to coercionKind is actually demanded per guard. + -- t1/t2 are used when checking if co1 is a forall, and t1'/t2' are used + -- when checking if co1' (i.e., co1 post-optimization) is a forall. + -- + -- t1/t2 must come from sym_arg, not arg', since it's possible that arg' + -- might have an extra Sym at the front (after being optimized) that co1 + -- lacks, so we need to use sym_arg to balance the number of Syms. (#15725) + Pair t1 t2 = coercionKind sym_arg + Pair t1' t2' = coercionKind arg' + + mk_new_co cv kind_co h1 h2 + = let -- h1 :: (t1 ~ t2) + -- h2 :: (t3 ~ t4) + -- kind_co :: (t1 ~ t2) ~ (t3 ~ t4) + -- n1 :: t1 ~ t3 + -- n2 :: t2 ~ t4 + -- new_co = (h1 :: t1 ~ t2) ~ ((n1;h2;sym n2) :: t1 ~ t2) + r2 = coVarRole cv + kind_co' = downgradeRole r2 Nominal kind_co + n1 = mkNthCo r2 2 kind_co' + n2 = mkNthCo r2 3 kind_co' + in mkProofIrrelCo Nominal (Refl (coercionType h1)) h1 + (n1 `mkTransCo` h2 `mkTransCo` (mkSymCo n2)) + +opt_co4 env sym _rep r (KindCo co) + = ASSERT( r == Nominal ) + let kco' = promoteCoercion co in + case kco' of + KindCo co' -> promoteCoercion (opt_co1 env sym co') + _ -> opt_co4_wrap env sym False Nominal kco' + -- This might be able to be optimized more to do the promotion + -- and substitution/optimization at the same time + +opt_co4 env sym _ r (SubCo co) + = ASSERT( r == Representational ) + opt_co4_wrap env sym True Nominal co + +-- This could perhaps be optimized more. +opt_co4 env sym rep r (AxiomRuleCo co cs) + = ASSERT( r == coaxrRole co ) + wrapRole rep r $ + wrapSym sym $ + AxiomRuleCo co (zipWith (opt_co2 env False) (coaxrAsmpRoles co) cs) + +{- Note [Optimise CoVarCo to Refl] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have (c :: t~t) we can optimise it to Refl. That increases the +chances of floating the Refl upwards; e.g. Maybe c --> Refl (Maybe t) + +We do so here in optCoercion, not in mkCoVarCo; see Note [mkCoVarCo] +in Coercion. +-} + +------------- +-- | Optimize a phantom coercion. The input coercion may not necessarily +-- be a phantom, but the output sure will be. +opt_phantom :: LiftingContext -> SymFlag -> Coercion -> NormalCo +opt_phantom env sym co + = opt_univ env sym (PhantomProv (mkKindCo co)) Phantom ty1 ty2 + where + Pair ty1 ty2 = coercionKind co + +{- Note [Differing kinds] + ~~~~~~~~~~~~~~~~~~~~~~ +The two types may not have the same kind (although that would be very unusual). +But even if they have the same kind, and the same type constructor, the number +of arguments in a `CoTyConApp` can differ. Consider + + Any :: forall k. k + + Any * Int :: * + Any (*->*) Maybe Int :: * + +Hence the need to compare argument lengths; see #13658 + -} + +opt_univ :: LiftingContext -> SymFlag -> UnivCoProvenance -> Role + -> Type -> Type -> Coercion +opt_univ env sym (PhantomProv h) _r ty1 ty2 + | sym = mkPhantomCo h' ty2' ty1' + | otherwise = mkPhantomCo h' ty1' ty2' + where + h' = opt_co4 env sym False Nominal h + ty1' = substTy (lcSubstLeft env) ty1 + ty2' = substTy (lcSubstRight env) ty2 + +opt_univ env sym prov role oty1 oty2 + | Just (tc1, tys1) <- splitTyConApp_maybe oty1 + , Just (tc2, tys2) <- splitTyConApp_maybe oty2 + , tc1 == tc2 + , equalLength tys1 tys2 -- see Note [Differing kinds] + -- NB: prov must not be the two interesting ones (ProofIrrel & Phantom); + -- Phantom is already taken care of, and ProofIrrel doesn't relate tyconapps + = let roles = tyConRolesX role tc1 + arg_cos = zipWith3 (mkUnivCo prov') roles tys1 tys2 + arg_cos' = zipWith (opt_co4 env sym False) roles arg_cos + in + mkTyConAppCo role tc1 arg_cos' + + -- can't optimize the AppTy case because we can't build the kind coercions. + + | Just (tv1, ty1) <- splitForAllTy_ty_maybe oty1 + , Just (tv2, ty2) <- splitForAllTy_ty_maybe oty2 + -- NB: prov isn't interesting here either + = let k1 = tyVarKind tv1 + k2 = tyVarKind tv2 + eta = mkUnivCo prov' Nominal k1 k2 + -- eta gets opt'ed soon, but not yet. + ty2' = substTyWith [tv2] [TyVarTy tv1 `mkCastTy` eta] ty2 + + (env', tv1', eta') = optForAllCoBndr env sym tv1 eta + in + mkForAllCo tv1' eta' (opt_univ env' sym prov' role ty1 ty2') + + | Just (cv1, ty1) <- splitForAllTy_co_maybe oty1 + , Just (cv2, ty2) <- splitForAllTy_co_maybe oty2 + -- NB: prov isn't interesting here either + = let k1 = varType cv1 + k2 = varType cv2 + r' = coVarRole cv1 + eta = mkUnivCo prov' Nominal k1 k2 + eta_d = downgradeRole r' Nominal eta + -- eta gets opt'ed soon, but not yet. + n_co = (mkSymCo $ mkNthCo r' 2 eta_d) `mkTransCo` + (mkCoVarCo cv1) `mkTransCo` + (mkNthCo r' 3 eta_d) + ty2' = substTyWithCoVars [cv2] [n_co] ty2 + + (env', cv1', eta') = optForAllCoBndr env sym cv1 eta + in + mkForAllCo cv1' eta' (opt_univ env' sym prov' role ty1 ty2') + + | otherwise + = let ty1 = substTyUnchecked (lcSubstLeft env) oty1 + ty2 = substTyUnchecked (lcSubstRight env) oty2 + (a, b) | sym = (ty2, ty1) + | otherwise = (ty1, ty2) + in + mkUnivCo prov' role a b + + where + prov' = case prov of + UnsafeCoerceProv -> prov + PhantomProv kco -> PhantomProv $ opt_co4_wrap env sym False Nominal kco + ProofIrrelProv kco -> ProofIrrelProv $ opt_co4_wrap env sym False Nominal kco + PluginProv _ -> prov + +------------- +opt_transList :: InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo] +opt_transList is = zipWith (opt_trans is) + +opt_trans :: InScopeSet -> NormalCo -> NormalCo -> NormalCo +opt_trans is co1 co2 + | isReflCo co1 = co2 + -- optimize when co1 is a Refl Co + | otherwise = opt_trans1 is co1 co2 + +opt_trans1 :: InScopeSet -> NormalNonIdCo -> NormalCo -> NormalCo +-- First arg is not the identity +opt_trans1 is co1 co2 + | isReflCo co2 = co1 + -- optimize when co2 is a Refl Co + | otherwise = opt_trans2 is co1 co2 + +opt_trans2 :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> NormalCo +-- Neither arg is the identity +opt_trans2 is (TransCo co1a co1b) co2 + -- Don't know whether the sub-coercions are the identity + = opt_trans is co1a (opt_trans is co1b co2) + +opt_trans2 is co1 co2 + | Just co <- opt_trans_rule is co1 co2 + = co + +opt_trans2 is co1 (TransCo co2a co2b) + | Just co1_2a <- opt_trans_rule is co1 co2a + = if isReflCo co1_2a + then co2b + else opt_trans1 is co1_2a co2b + +opt_trans2 _ co1 co2 + = mkTransCo co1 co2 + +------ +-- Optimize coercions with a top-level use of transitivity. +opt_trans_rule :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo + +opt_trans_rule is in_co1@(GRefl r1 t1 (MCo co1)) in_co2@(GRefl r2 _ (MCo co2)) + = ASSERT( r1 == r2 ) + fireTransRule "GRefl" in_co1 in_co2 $ + mkGReflRightCo r1 t1 (opt_trans is co1 co2) + +-- Push transitivity through matching destructors +opt_trans_rule is in_co1@(NthCo r1 d1 co1) in_co2@(NthCo r2 d2 co2) + | d1 == d2 + , coercionRole co1 == coercionRole co2 + , co1 `compatible_co` co2 + = ASSERT( r1 == r2 ) + fireTransRule "PushNth" in_co1 in_co2 $ + mkNthCo r1 d1 (opt_trans is co1 co2) + +opt_trans_rule is in_co1@(LRCo d1 co1) in_co2@(LRCo d2 co2) + | d1 == d2 + , co1 `compatible_co` co2 + = fireTransRule "PushLR" in_co1 in_co2 $ + mkLRCo d1 (opt_trans is co1 co2) + +-- Push transitivity inside instantiation +opt_trans_rule is in_co1@(InstCo co1 ty1) in_co2@(InstCo co2 ty2) + | ty1 `eqCoercion` ty2 + , co1 `compatible_co` co2 + = fireTransRule "TrPushInst" in_co1 in_co2 $ + mkInstCo (opt_trans is co1 co2) ty1 + +opt_trans_rule is in_co1@(UnivCo p1 r1 tyl1 _tyr1) + in_co2@(UnivCo p2 r2 _tyl2 tyr2) + | Just prov' <- opt_trans_prov p1 p2 + = ASSERT( r1 == r2 ) + fireTransRule "UnivCo" in_co1 in_co2 $ + mkUnivCo prov' r1 tyl1 tyr2 + where + -- if the provenances are different, opt'ing will be very confusing + opt_trans_prov UnsafeCoerceProv UnsafeCoerceProv = Just UnsafeCoerceProv + opt_trans_prov (PhantomProv kco1) (PhantomProv kco2) + = Just $ PhantomProv $ opt_trans is kco1 kco2 + opt_trans_prov (ProofIrrelProv kco1) (ProofIrrelProv kco2) + = Just $ ProofIrrelProv $ opt_trans is kco1 kco2 + opt_trans_prov (PluginProv str1) (PluginProv str2) | str1 == str2 = Just p1 + opt_trans_prov _ _ = Nothing + +-- Push transitivity down through matching top-level constructors. +opt_trans_rule is in_co1@(TyConAppCo r1 tc1 cos1) in_co2@(TyConAppCo r2 tc2 cos2) + | tc1 == tc2 + = ASSERT( r1 == r2 ) + fireTransRule "PushTyConApp" in_co1 in_co2 $ + mkTyConAppCo r1 tc1 (opt_transList is cos1 cos2) + +opt_trans_rule is in_co1@(FunCo r1 co1a co1b) in_co2@(FunCo r2 co2a co2b) + = ASSERT( r1 == r2 ) -- Just like the TyConAppCo/TyConAppCo case + fireTransRule "PushFun" in_co1 in_co2 $ + mkFunCo r1 (opt_trans is co1a co2a) (opt_trans is co1b co2b) + +opt_trans_rule is in_co1@(AppCo co1a co1b) in_co2@(AppCo co2a co2b) + -- Must call opt_trans_rule_app; see Note [EtaAppCo] + = opt_trans_rule_app is in_co1 in_co2 co1a [co1b] co2a [co2b] + +-- Eta rules +opt_trans_rule is co1@(TyConAppCo r tc cos1) co2 + | Just cos2 <- etaTyConAppCo_maybe tc co2 + = ASSERT( cos1 `equalLength` cos2 ) + fireTransRule "EtaCompL" co1 co2 $ + mkTyConAppCo r tc (opt_transList is cos1 cos2) + +opt_trans_rule is co1 co2@(TyConAppCo r tc cos2) + | Just cos1 <- etaTyConAppCo_maybe tc co1 + = ASSERT( cos1 `equalLength` cos2 ) + fireTransRule "EtaCompR" co1 co2 $ + mkTyConAppCo r tc (opt_transList is cos1 cos2) + +opt_trans_rule is co1@(AppCo co1a co1b) co2 + | Just (co2a,co2b) <- etaAppCo_maybe co2 + = opt_trans_rule_app is co1 co2 co1a [co1b] co2a [co2b] + +opt_trans_rule is co1 co2@(AppCo co2a co2b) + | Just (co1a,co1b) <- etaAppCo_maybe co1 + = opt_trans_rule_app is co1 co2 co1a [co1b] co2a [co2b] + +-- Push transitivity inside forall +-- forall over types. +opt_trans_rule is co1 co2 + | Just (tv1, eta1, r1) <- splitForAllCo_ty_maybe co1 + , Just (tv2, eta2, r2) <- etaForAllCo_ty_maybe co2 + = push_trans tv1 eta1 r1 tv2 eta2 r2 + + | Just (tv2, eta2, r2) <- splitForAllCo_ty_maybe co2 + , Just (tv1, eta1, r1) <- etaForAllCo_ty_maybe co1 + = push_trans tv1 eta1 r1 tv2 eta2 r2 + + where + push_trans tv1 eta1 r1 tv2 eta2 r2 + -- Given: + -- co1 = /\ tv1 : eta1. r1 + -- co2 = /\ tv2 : eta2. r2 + -- Wanted: + -- /\tv1 : (eta1;eta2). (r1; r2[tv2 |-> tv1 |> eta1]) + = fireTransRule "EtaAllTy_ty" co1 co2 $ + mkForAllCo tv1 (opt_trans is eta1 eta2) (opt_trans is' r1 r2') + where + is' = is `extendInScopeSet` tv1 + r2' = substCoWithUnchecked [tv2] [mkCastTy (TyVarTy tv1) eta1] r2 + +-- Push transitivity inside forall +-- forall over coercions. +opt_trans_rule is co1 co2 + | Just (cv1, eta1, r1) <- splitForAllCo_co_maybe co1 + , Just (cv2, eta2, r2) <- etaForAllCo_co_maybe co2 + = push_trans cv1 eta1 r1 cv2 eta2 r2 + + | Just (cv2, eta2, r2) <- splitForAllCo_co_maybe co2 + , Just (cv1, eta1, r1) <- etaForAllCo_co_maybe co1 + = push_trans cv1 eta1 r1 cv2 eta2 r2 + + where + push_trans cv1 eta1 r1 cv2 eta2 r2 + -- Given: + -- co1 = /\ cv1 : eta1. r1 + -- co2 = /\ cv2 : eta2. r2 + -- Wanted: + -- n1 = nth 2 eta1 + -- n2 = nth 3 eta1 + -- nco = /\ cv1 : (eta1;eta2). (r1; r2[cv2 |-> (sym n1);cv1;n2]) + = fireTransRule "EtaAllTy_co" co1 co2 $ + mkForAllCo cv1 (opt_trans is eta1 eta2) (opt_trans is' r1 r2') + where + is' = is `extendInScopeSet` cv1 + role = coVarRole cv1 + eta1' = downgradeRole role Nominal eta1 + n1 = mkNthCo role 2 eta1' + n2 = mkNthCo role 3 eta1' + r2' = substCo (zipCvSubst [cv2] [(mkSymCo n1) `mkTransCo` + (mkCoVarCo cv1) `mkTransCo` n2]) + r2 + +-- Push transitivity inside axioms +opt_trans_rule is co1 co2 + + -- See Note [Why call checkAxInstCo during optimisation] + -- TrPushSymAxR + | Just (sym, con, ind, cos1) <- co1_is_axiom_maybe + , True <- sym + , Just cos2 <- matchAxiom sym con ind co2 + , let newAxInst = AxiomInstCo con ind (opt_transList is (map mkSymCo cos2) cos1) + , Nothing <- checkAxInstCo newAxInst + = fireTransRule "TrPushSymAxR" co1 co2 $ SymCo newAxInst + + -- TrPushAxR + | Just (sym, con, ind, cos1) <- co1_is_axiom_maybe + , False <- sym + , Just cos2 <- matchAxiom sym con ind co2 + , let newAxInst = AxiomInstCo con ind (opt_transList is cos1 cos2) + , Nothing <- checkAxInstCo newAxInst + = fireTransRule "TrPushAxR" co1 co2 newAxInst + + -- TrPushSymAxL + | Just (sym, con, ind, cos2) <- co2_is_axiom_maybe + , True <- sym + , Just cos1 <- matchAxiom (not sym) con ind co1 + , let newAxInst = AxiomInstCo con ind (opt_transList is cos2 (map mkSymCo cos1)) + , Nothing <- checkAxInstCo newAxInst + = fireTransRule "TrPushSymAxL" co1 co2 $ SymCo newAxInst + + -- TrPushAxL + | Just (sym, con, ind, cos2) <- co2_is_axiom_maybe + , False <- sym + , Just cos1 <- matchAxiom (not sym) con ind co1 + , let newAxInst = AxiomInstCo con ind (opt_transList is cos1 cos2) + , Nothing <- checkAxInstCo newAxInst + = fireTransRule "TrPushAxL" co1 co2 newAxInst + + -- TrPushAxSym/TrPushSymAx + | Just (sym1, con1, ind1, cos1) <- co1_is_axiom_maybe + , Just (sym2, con2, ind2, cos2) <- co2_is_axiom_maybe + , con1 == con2 + , ind1 == ind2 + , sym1 == not sym2 + , let branch = coAxiomNthBranch con1 ind1 + qtvs = coAxBranchTyVars branch ++ coAxBranchCoVars branch + lhs = coAxNthLHS con1 ind1 + rhs = coAxBranchRHS branch + pivot_tvs = exactTyCoVarsOfType (if sym2 then rhs else lhs) + , all (`elemVarSet` pivot_tvs) qtvs + = fireTransRule "TrPushAxSym" co1 co2 $ + if sym2 + -- TrPushAxSym + then liftCoSubstWith role qtvs (opt_transList is cos1 (map mkSymCo cos2)) lhs + -- TrPushSymAx + else liftCoSubstWith role qtvs (opt_transList is (map mkSymCo cos1) cos2) rhs + where + co1_is_axiom_maybe = isAxiom_maybe co1 + co2_is_axiom_maybe = isAxiom_maybe co2 + role = coercionRole co1 -- should be the same as coercionRole co2! + +opt_trans_rule _ co1 co2 -- Identity rule + | (Pair ty1 _, r) <- coercionKindRole co1 + , Pair _ ty2 <- coercionKind co2 + , ty1 `eqType` ty2 + = fireTransRule "RedTypeDirRefl" co1 co2 $ + mkReflCo r ty2 + +opt_trans_rule _ _ _ = Nothing + +-- See Note [EtaAppCo] +opt_trans_rule_app :: InScopeSet + -> Coercion -- original left-hand coercion (printing only) + -> Coercion -- original right-hand coercion (printing only) + -> Coercion -- left-hand coercion "function" + -> [Coercion] -- left-hand coercion "args" + -> Coercion -- right-hand coercion "function" + -> [Coercion] -- right-hand coercion "args" + -> Maybe Coercion +opt_trans_rule_app is orig_co1 orig_co2 co1a co1bs co2a co2bs + | AppCo co1aa co1ab <- co1a + , Just (co2aa, co2ab) <- etaAppCo_maybe co2a + = opt_trans_rule_app is orig_co1 orig_co2 co1aa (co1ab:co1bs) co2aa (co2ab:co2bs) + + | AppCo co2aa co2ab <- co2a + , Just (co1aa, co1ab) <- etaAppCo_maybe co1a + = opt_trans_rule_app is orig_co1 orig_co2 co1aa (co1ab:co1bs) co2aa (co2ab:co2bs) + + | otherwise + = ASSERT( co1bs `equalLength` co2bs ) + fireTransRule ("EtaApps:" ++ show (length co1bs)) orig_co1 orig_co2 $ + let Pair _ rt1a = coercionKind co1a + (Pair lt2a _, rt2a) = coercionKindRole co2a + + Pair _ rt1bs = traverse coercionKind co1bs + Pair lt2bs _ = traverse coercionKind co2bs + rt2bs = map coercionRole co2bs + + kcoa = mkKindCo $ buildCoercion lt2a rt1a + kcobs = map mkKindCo $ zipWith buildCoercion lt2bs rt1bs + + co2a' = mkCoherenceLeftCo rt2a lt2a kcoa co2a + co2bs' = zipWith3 mkGReflLeftCo rt2bs lt2bs kcobs + co2bs'' = zipWith mkTransCo co2bs' co2bs + in + mkAppCos (opt_trans is co1a co2a') + (zipWith (opt_trans is) co1bs co2bs'') + +fireTransRule :: String -> Coercion -> Coercion -> Coercion -> Maybe Coercion +fireTransRule _rule _co1 _co2 res + = Just res + +{- +Note [Conflict checking with AxiomInstCo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider the following type family and axiom: + +type family Equal (a :: k) (b :: k) :: Bool +type instance where + Equal a a = True + Equal a b = False +-- +Equal :: forall k::*. k -> k -> Bool +axEqual :: { forall k::*. forall a::k. Equal k a a ~ True + ; forall k::*. forall a::k. forall b::k. Equal k a b ~ False } + +We wish to disallow (axEqual[1] <*> ) :: (Equal * Int Int ~ +False) and that all is OK. But, all is not OK: we want to use the first branch +of the axiom in this case, not the second. The problem is that the parameters +of the first branch can unify with the supplied coercions, thus meaning that +the first branch should be taken. See also Note [Apartness] in +types/FamInstEnv.hs. + +Note [Why call checkAxInstCo during optimisation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It is possible that otherwise-good-looking optimisations meet with disaster +in the presence of axioms with multiple equations. Consider + +type family Equal (a :: *) (b :: *) :: Bool where + Equal a a = True + Equal a b = False +type family Id (a :: *) :: * where + Id a = a + +axEq :: { [a::*]. Equal a a ~ True + ; [a::*, b::*]. Equal a b ~ False } +axId :: [a::*]. Id a ~ a + +co1 = Equal (axId[0] Int) (axId[0] Bool) + :: Equal (Id Int) (Id Bool) ~ Equal Int Bool +co2 = axEq[1] + :: Equal Int Bool ~ False + +We wish to optimise (co1 ; co2). We end up in rule TrPushAxL, noting that +co2 is an axiom and that matchAxiom succeeds when looking at co1. But, what +happens when we push the coercions inside? We get + +co3 = axEq[1] (axId[0] Int) (axId[0] Bool) + :: Equal (Id Int) (Id Bool) ~ False + +which is bogus! This is because the type system isn't smart enough to know +that (Id Int) and (Id Bool) are Surely Apart, as they're headed by type +families. At the time of writing, I (Richard Eisenberg) couldn't think of +a way of detecting this any more efficient than just building the optimised +coercion and checking. + +Note [EtaAppCo] +~~~~~~~~~~~~~~~ +Suppose we're trying to optimize (co1a co1b ; co2a co2b). Ideally, we'd +like to rewrite this to (co1a ; co2a) (co1b ; co2b). The problem is that +the resultant coercions might not be well kinded. Here is an example (things +labeled with x don't matter in this example): + + k1 :: Type + k2 :: Type + + a :: k1 -> Type + b :: k1 + + h :: k1 ~ k2 + + co1a :: x1 ~ (a |> (h -> ) + co1b :: x2 ~ (b |> h) + + co2a :: a ~ x3 + co2b :: b ~ x4 + +First, convince yourself of the following: + + co1a co1b :: x1 x2 ~ (a |> (h -> )) (b |> h) + co2a co2b :: a b ~ x3 x4 + + (a |> (h -> )) (b |> h) `eqType` a b + +That last fact is due to Note [Non-trivial definitional equality] in TyCoRep, +where we ignore coercions in types as long as two types' kinds are the same. +In our case, we meet this last condition, because + + (a |> (h -> )) (b |> h) :: Type + and + a b :: Type + +So the input coercion (co1a co1b ; co2a co2b) is well-formed. But the +suggested output coercions (co1a ; co2a) and (co1b ; co2b) are not -- the +kinds don't match up. + +The solution here is to twiddle the kinds in the output coercions. First, we +need to find coercions + + ak :: kind(a |> (h -> )) ~ kind(a) + bk :: kind(b |> h) ~ kind(b) + +This can be done with mkKindCo and buildCoercion. The latter assumes two +types are identical modulo casts and builds a coercion between them. + +Then, we build (co1a ; co2a |> sym ak) and (co1b ; co2b |> sym bk) as the +output coercions. These are well-kinded. + +Also, note that all of this is done after accumulated any nested AppCo +parameters. This step is to avoid quadratic behavior in calling coercionKind. + +The problem described here was first found in dependent/should_compile/dynamic-paper. + +-} + +-- | Check to make sure that an AxInstCo is internally consistent. +-- Returns the conflicting branch, if it exists +-- See Note [Conflict checking with AxiomInstCo] +checkAxInstCo :: Coercion -> Maybe CoAxBranch +-- defined here to avoid dependencies in Coercion +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] in CoreLint +checkAxInstCo (AxiomInstCo ax ind cos) + = let branch = coAxiomNthBranch ax ind + tvs = coAxBranchTyVars branch + cvs = coAxBranchCoVars branch + incomps = coAxBranchIncomps branch + (tys, cotys) = splitAtList tvs (map (pFst . coercionKind) cos) + co_args = map stripCoercionTy cotys + subst = zipTvSubst tvs tys `composeTCvSubst` + zipCvSubst cvs co_args + target = Type.substTys subst (coAxBranchLHS branch) + in_scope = mkInScopeSet $ + unionVarSets (map (tyCoVarsOfTypes . coAxBranchLHS) incomps) + flattened_target = flattenTys in_scope target in + check_no_conflict flattened_target incomps + where + check_no_conflict :: [Type] -> [CoAxBranch] -> Maybe CoAxBranch + check_no_conflict _ [] = Nothing + check_no_conflict flat (b@CoAxBranch { cab_lhs = lhs_incomp } : rest) + -- See Note [Apartness] in FamInstEnv + | SurelyApart <- tcUnifyTysFG instanceBindFun flat lhs_incomp + = check_no_conflict flat rest + | otherwise + = Just b +checkAxInstCo _ = Nothing + + +----------- +wrapSym :: SymFlag -> Coercion -> Coercion +wrapSym sym co | sym = mkSymCo co + | otherwise = co + +-- | Conditionally set a role to be representational +wrapRole :: ReprFlag + -> Role -- ^ current role + -> Coercion -> Coercion +wrapRole False _ = id +wrapRole True current = downgradeRole Representational current + +-- | If we require a representational role, return that. Otherwise, +-- return the "default" role provided. +chooseRole :: ReprFlag + -> Role -- ^ "default" role + -> Role +chooseRole True _ = Representational +chooseRole _ r = r + +----------- +isAxiom_maybe :: Coercion -> Maybe (Bool, CoAxiom Branched, Int, [Coercion]) +isAxiom_maybe (SymCo co) + | Just (sym, con, ind, cos) <- isAxiom_maybe co + = Just (not sym, con, ind, cos) +isAxiom_maybe (AxiomInstCo con ind cos) + = Just (False, con, ind, cos) +isAxiom_maybe _ = Nothing + +matchAxiom :: Bool -- True = match LHS, False = match RHS + -> CoAxiom br -> Int -> Coercion -> Maybe [Coercion] +matchAxiom sym ax@(CoAxiom { co_ax_tc = tc }) ind co + | CoAxBranch { cab_tvs = qtvs + , cab_cvs = [] -- can't infer these, so fail if there are any + , cab_roles = roles + , cab_lhs = lhs + , cab_rhs = rhs } <- coAxiomNthBranch ax ind + , Just subst <- liftCoMatch (mkVarSet qtvs) + (if sym then (mkTyConApp tc lhs) else rhs) + co + , all (`isMappedByLC` subst) qtvs + = zipWithM (liftCoSubstTyVar subst) roles qtvs + + | otherwise + = Nothing + +------------- +compatible_co :: Coercion -> Coercion -> Bool +-- Check whether (co1 . co2) will be well-kinded +compatible_co co1 co2 + = x1 `eqType` x2 + where + Pair _ x1 = coercionKind co1 + Pair x2 _ = coercionKind co2 + +------------- +{- +etaForAllCo +~~~~~~~~~~~~~~~~~ +(1) etaForAllCo_ty_maybe +Suppose we have + + g : all a1:k1.t1 ~ all a2:k2.t2 + +but g is *not* a ForAllCo. We want to eta-expand it. So, we do this: + + g' = all a1:(ForAllKindCo g).(InstCo g (a1 ~ a1 |> ForAllKindCo g)) + +Call the kind coercion h1 and the body coercion h2. We can see that + + h2 : t1 ~ t2[a2 |-> (a1 |> h1)] + +According to the typing rule for ForAllCo, we get that + + g' : all a1:k1.t1 ~ all a1:k2.(t2[a2 |-> (a1 |> h1)][a1 |-> a1 |> sym h1]) + +or + + g' : all a1:k1.t1 ~ all a1:k2.(t2[a2 |-> a1]) + +as desired. + +(2) etaForAllCo_co_maybe +Suppose we have + + g : all c1:(s1~s2). t1 ~ all c2:(s3~s4). t2 + +Similarly, we do this + + g' = all c1:h1. h2 + : all c1:(s1~s2). t1 ~ all c1:(s3~s4). t2[c2 |-> (sym eta1;c1;eta2)] + [c1 |-> eta1;c1;sym eta2] + +Here, + + h1 = mkNthCo Nominal 0 g :: (s1~s2)~(s3~s4) + eta1 = mkNthCo r 2 h1 :: (s1 ~ s3) + eta2 = mkNthCo r 3 h1 :: (s2 ~ s4) + h2 = mkInstCo g (cv1 ~ (sym eta1;c1;eta2)) +-} +etaForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, Coercion, Coercion) +-- Try to make the coercion be of form (forall tv:kind_co. co) +etaForAllCo_ty_maybe co + | Just (tv, kind_co, r) <- splitForAllCo_ty_maybe co + = Just (tv, kind_co, r) + + | Pair ty1 ty2 <- coercionKind co + , Just (tv1, _) <- splitForAllTy_ty_maybe ty1 + , isForAllTy_ty ty2 + , let kind_co = mkNthCo Nominal 0 co + = Just ( tv1, kind_co + , mkInstCo co (mkGReflRightCo Nominal (TyVarTy tv1) kind_co)) + + | otherwise + = Nothing + +etaForAllCo_co_maybe :: Coercion -> Maybe (CoVar, Coercion, Coercion) +-- Try to make the coercion be of form (forall cv:kind_co. co) +etaForAllCo_co_maybe co + | Just (cv, kind_co, r) <- splitForAllCo_co_maybe co + = Just (cv, kind_co, r) + + | Pair ty1 ty2 <- coercionKind co + , Just (cv1, _) <- splitForAllTy_co_maybe ty1 + , isForAllTy_co ty2 + = let kind_co = mkNthCo Nominal 0 co + r = coVarRole cv1 + l_co = mkCoVarCo cv1 + kind_co' = downgradeRole r Nominal kind_co + r_co = (mkSymCo (mkNthCo r 2 kind_co')) `mkTransCo` + l_co `mkTransCo` + (mkNthCo r 3 kind_co') + in Just ( cv1, kind_co + , mkInstCo co (mkProofIrrelCo Nominal kind_co l_co r_co)) + + | otherwise + = Nothing + +etaAppCo_maybe :: Coercion -> Maybe (Coercion,Coercion) +-- If possible, split a coercion +-- g :: t1a t1b ~ t2a t2b +-- into a pair of coercions (left g, right g) +etaAppCo_maybe co + | Just (co1,co2) <- splitAppCo_maybe co + = Just (co1,co2) + | (Pair ty1 ty2, Nominal) <- coercionKindRole co + , Just (_,t1) <- splitAppTy_maybe ty1 + , Just (_,t2) <- splitAppTy_maybe ty2 + , let isco1 = isCoercionTy t1 + , let isco2 = isCoercionTy t2 + , isco1 == isco2 + = Just (LRCo CLeft co, LRCo CRight co) + | otherwise + = Nothing + +etaTyConAppCo_maybe :: TyCon -> Coercion -> Maybe [Coercion] +-- If possible, split a coercion +-- g :: T s1 .. sn ~ T t1 .. tn +-- into [ Nth 0 g :: s1~t1, ..., Nth (n-1) g :: sn~tn ] +etaTyConAppCo_maybe tc (TyConAppCo _ tc2 cos2) + = ASSERT( tc == tc2 ) Just cos2 + +etaTyConAppCo_maybe tc co + | not (mustBeSaturated tc) + , (Pair ty1 ty2, r) <- coercionKindRole co + , Just (tc1, tys1) <- splitTyConApp_maybe ty1 + , Just (tc2, tys2) <- splitTyConApp_maybe ty2 + , tc1 == tc2 + , isInjectiveTyCon tc r -- See Note [NthCo and newtypes] in TyCoRep + , let n = length tys1 + , tys2 `lengthIs` n -- This can fail in an erroneous progam + -- E.g. T a ~# T a b + -- #14607 + = ASSERT( tc == tc1 ) + Just (decomposeCo n co (tyConRolesX r tc1)) + -- NB: n might be <> tyConArity tc + -- e.g. data family T a :: * -> * + -- g :: T a b ~ T c d + + | otherwise + = Nothing + +{- +Note [Eta for AppCo] +~~~~~~~~~~~~~~~~~~~~ +Suppose we have + g :: s1 t1 ~ s2 t2 + +Then we can't necessarily make + left g :: s1 ~ s2 + right g :: t1 ~ t2 +because it's possible that + s1 :: * -> * t1 :: * + s2 :: (*->*) -> * t2 :: * -> * +and in that case (left g) does not have the same +kind on either side. + +It's enough to check that + kind t1 = kind t2 +because if g is well-kinded then + kind (s1 t2) = kind (s2 t2) +and these two imply + kind s1 = kind s2 + +-} + +optForAllCoBndr :: LiftingContext -> Bool + -> TyCoVar -> Coercion -> (LiftingContext, TyCoVar, Coercion) +optForAllCoBndr env sym + = substForAllCoBndrUsingLC sym (opt_co4_wrap env sym False Nominal) env diff --git a/compiler/types/TyCoRep.hs b/compiler/types/TyCoRep.hs new file mode 100644 --- /dev/null +++ b/compiler/types/TyCoRep.hs @@ -0,0 +1,4142 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1998 +\section[TyCoRep]{Type and Coercion - friends' interface} + +Note [The Type-related module hierarchy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + Class + CoAxiom + TyCon imports Class, CoAxiom + TyCoRep imports Class, CoAxiom, TyCon + TysPrim imports TyCoRep ( including mkTyConTy ) + Kind imports TysPrim ( mainly for primitive kinds ) + Type imports Kind + Coercion imports Type +-} + +-- We expose the relevant stuff from this module via the Type module +{-# OPTIONS_HADDOCK not-home #-} +{-# LANGUAGE CPP, DeriveDataTypeable, MultiWayIf, PatternSynonyms, BangPatterns #-} + +module TyCoRep ( + TyThing(..), tyThingCategory, pprTyThingCategory, pprShortTyThing, + + -- * Types + Type( TyVarTy, AppTy, TyConApp, ForAllTy + , LitTy, CastTy, CoercionTy + , FunTy, ft_arg, ft_res, ft_af + ), -- Export the type synonym FunTy too + + TyLit(..), + KindOrType, Kind, + KnotTied, + PredType, ThetaType, -- Synonyms + ArgFlag(..), AnonArgFlag(..), ForallVisFlag(..), + + -- * Coercions + Coercion(..), + UnivCoProvenance(..), + CoercionHole(..), coHoleCoVar, setCoHoleCoVar, + CoercionN, CoercionR, CoercionP, KindCoercion, + MCoercion(..), MCoercionR, MCoercionN, + + -- * Functions over types + mkTyConTy, mkTyVarTy, mkTyVarTys, + mkTyCoVarTy, mkTyCoVarTys, + mkFunTy, mkVisFunTy, mkInvisFunTy, mkVisFunTys, mkInvisFunTys, + mkForAllTy, mkForAllTys, + mkPiTy, mkPiTys, + + kindRep_maybe, kindRep, + isLiftedTypeKind, isUnliftedTypeKind, + isLiftedRuntimeRep, isUnliftedRuntimeRep, + isRuntimeRepTy, isRuntimeRepVar, + sameVis, + + -- * Functions over binders + TyCoBinder(..), TyCoVarBinder, TyBinder, + binderVar, binderVars, binderType, binderArgFlag, + delBinderVar, + isInvisibleArgFlag, isVisibleArgFlag, + isInvisibleBinder, isVisibleBinder, + isTyBinder, isNamedBinder, + + -- * Functions over coercions + pickLR, + + -- * Pretty-printing + pprType, pprParendType, pprPrecType, pprPrecTypeX, + pprTypeApp, pprTCvBndr, pprTCvBndrs, + pprSigmaType, + pprTheta, pprParendTheta, pprForAll, pprUserForAll, + pprTyVar, pprTyVars, + pprThetaArrowTy, pprClassPred, + pprKind, pprParendKind, pprTyLit, + PprPrec(..), topPrec, sigPrec, opPrec, funPrec, appPrec, maybeParen, + pprDataCons, pprWithExplicitKindsWhen, + + pprCo, pprParendCo, + + debugPprType, + + -- * Free variables + tyCoVarsOfType, tyCoVarsOfTypeDSet, tyCoVarsOfTypes, tyCoVarsOfTypesDSet, + tyCoFVsBndr, tyCoFVsVarBndr, tyCoFVsVarBndrs, + tyCoFVsOfType, tyCoVarsOfTypeList, + tyCoFVsOfTypes, tyCoVarsOfTypesList, + coVarsOfType, coVarsOfTypes, + coVarsOfCo, coVarsOfCos, + tyCoVarsOfCo, tyCoVarsOfCos, + tyCoVarsOfCoDSet, + tyCoFVsOfCo, tyCoFVsOfCos, + tyCoVarsOfCoList, tyCoVarsOfProv, + almostDevoidCoVarOfCo, + injectiveVarsOfType, tyConAppNeedsKindSig, + + noFreeVarsOfType, noFreeVarsOfCo, + + -- * Substitutions + TCvSubst(..), TvSubstEnv, CvSubstEnv, + emptyTvSubstEnv, emptyCvSubstEnv, composeTCvSubstEnv, composeTCvSubst, + emptyTCvSubst, mkEmptyTCvSubst, isEmptyTCvSubst, + mkTCvSubst, mkTvSubst, mkCvSubst, + getTvSubstEnv, + getCvSubstEnv, getTCvInScope, getTCvSubstRangeFVs, + isInScope, notElemTCvSubst, + setTvSubstEnv, setCvSubstEnv, zapTCvSubst, + extendTCvInScope, extendTCvInScopeList, extendTCvInScopeSet, + extendTCvSubst, extendTCvSubstWithClone, + extendCvSubst, extendCvSubstWithClone, + extendTvSubst, extendTvSubstBinderAndInScope, extendTvSubstWithClone, + extendTvSubstList, extendTvSubstAndInScope, + extendTCvSubstList, + unionTCvSubst, zipTyEnv, zipCoEnv, mkTyCoInScopeSet, + zipTvSubst, zipCvSubst, + zipTCvSubst, + mkTvSubstPrs, + + substTyWith, substTyWithCoVars, substTysWith, substTysWithCoVars, + substCoWith, + substTy, substTyAddInScope, + substTyUnchecked, substTysUnchecked, substThetaUnchecked, + substTyWithUnchecked, + substCoUnchecked, substCoWithUnchecked, + substTyWithInScope, + substTys, substTheta, + lookupTyVar, + substCo, substCos, substCoVar, substCoVars, lookupCoVar, + cloneTyVarBndr, cloneTyVarBndrs, + substVarBndr, substVarBndrs, + substTyVarBndr, substTyVarBndrs, + substCoVarBndr, + substTyVar, substTyVars, substTyCoVars, + substForAllCoBndr, + substVarBndrUsing, substForAllCoBndrUsing, + checkValidSubst, isValidTCvSubst, + + -- * Tidying type related things up for printing + tidyType, tidyTypes, + tidyOpenType, tidyOpenTypes, + tidyOpenKind, + tidyVarBndr, tidyVarBndrs, tidyFreeTyCoVars, avoidNameClashes, + tidyOpenTyCoVar, tidyOpenTyCoVars, + tidyTyCoVarOcc, + tidyTopType, + tidyKind, + tidyCo, tidyCos, + tidyTyCoVarBinder, tidyTyCoVarBinders, + + -- * Sizes + typeSize, coercionSize, provSize + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import {-# SOURCE #-} DataCon( dataConFullSig + , dataConUserTyVarBinders + , DataCon ) +import {-# SOURCE #-} Type( isCoercionTy, mkAppTy, mkCastTy + , tyCoVarsOfTypeWellScoped + , tyCoVarsOfTypesWellScoped + , scopedSort + , coreView ) + -- Transitively pulls in a LOT of stuff, better to break the loop + +import {-# SOURCE #-} Coercion +import {-# SOURCE #-} ConLike ( ConLike(..), conLikeName ) +import {-# SOURCE #-} ToIface( toIfaceTypeX, toIfaceTyLit, toIfaceForAllBndr + , toIfaceTyCon, toIfaceTcArgs, toIfaceCoercionX ) + +-- friends: +import IfaceType +import Var +import VarEnv +import VarSet +import Name hiding ( varName ) +import TyCon +import Class +import CoAxiom +import FV + +-- others +import BasicTypes ( LeftOrRight(..), PprPrec(..), topPrec, sigPrec, opPrec + , funPrec, appPrec, maybeParen, pickLR ) +import PrelNames +import Outputable +import DynFlags +import FastString +import Pair +import UniqSupply +import Util +import UniqFM +import UniqSet + +-- libraries +import qualified Data.Data as Data hiding ( TyCon ) +import Data.List +import Data.IORef ( IORef ) -- for CoercionHole + +{- +%************************************************************************ +%* * + TyThing +%* * +%************************************************************************ + +Despite the fact that DataCon has to be imported via a hi-boot route, +this module seems the right place for TyThing, because it's needed for +funTyCon and all the types in TysPrim. + +It is also SOURCE-imported into Name.hs + + +Note [ATyCon for classes] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Both classes and type constructors are represented in the type environment +as ATyCon. You can tell the difference, and get to the class, with + isClassTyCon :: TyCon -> Bool + tyConClass_maybe :: TyCon -> Maybe Class +The Class and its associated TyCon have the same Name. +-} + +-- | A global typecheckable-thing, essentially anything that has a name. +-- Not to be confused with a 'TcTyThing', which is also a typecheckable +-- thing but in the *local* context. See 'TcEnv' for how to retrieve +-- a 'TyThing' given a 'Name'. +data TyThing + = AnId Id + | AConLike ConLike + | ATyCon TyCon -- TyCons and classes; see Note [ATyCon for classes] + | ACoAxiom (CoAxiom Branched) + +instance Outputable TyThing where + ppr = pprShortTyThing + +instance NamedThing TyThing where -- Can't put this with the type + getName (AnId id) = getName id -- decl, because the DataCon instance + getName (ATyCon tc) = getName tc -- isn't visible there + getName (ACoAxiom cc) = getName cc + getName (AConLike cl) = conLikeName cl + +pprShortTyThing :: TyThing -> SDoc +-- c.f. PprTyThing.pprTyThing, which prints all the details +pprShortTyThing thing + = pprTyThingCategory thing <+> quotes (ppr (getName thing)) + +pprTyThingCategory :: TyThing -> SDoc +pprTyThingCategory = text . capitalise . tyThingCategory + +tyThingCategory :: TyThing -> String +tyThingCategory (ATyCon tc) + | isClassTyCon tc = "class" + | otherwise = "type constructor" +tyThingCategory (ACoAxiom _) = "coercion axiom" +tyThingCategory (AnId _) = "identifier" +tyThingCategory (AConLike (RealDataCon _)) = "data constructor" +tyThingCategory (AConLike (PatSynCon _)) = "pattern synonym" + + +{- ********************************************************************** +* * + Type +* * +********************************************************************** -} + +-- | The key representation of types within the compiler + +type KindOrType = Type -- See Note [Arguments to type constructors] + +-- | The key type representing kinds in the compiler. +type Kind = Type + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in coreSyn/CoreLint.hs +data Type + -- See Note [Non-trivial definitional equality] + = TyVarTy Var -- ^ Vanilla type or kind variable (*never* a coercion variable) + + | AppTy + Type + Type -- ^ Type application to something other than a 'TyCon'. Parameters: + -- + -- 1) Function: must /not/ be a 'TyConApp' or 'CastTy', + -- must be another 'AppTy', or 'TyVarTy' + -- See Note [Respecting definitional equality] (EQ1) about the + -- no 'CastTy' requirement + -- + -- 2) Argument type + + | TyConApp + TyCon + [KindOrType] -- ^ Application of a 'TyCon', including newtypes /and/ synonyms. + -- Invariant: saturated applications of 'FunTyCon' must + -- use 'FunTy' and saturated synonyms must use their own + -- constructors. However, /unsaturated/ 'FunTyCon's + -- do appear as 'TyConApp's. + -- Parameters: + -- + -- 1) Type constructor being applied to. + -- + -- 2) Type arguments. Might not have enough type arguments + -- here to saturate the constructor. + -- Even type synonyms are not necessarily saturated; + -- for example unsaturated type synonyms + -- can appear as the right hand side of a type synonym. + + | ForAllTy + {-# UNPACK #-} !TyCoVarBinder + Type -- ^ A Π type. + + | FunTy -- ^ t1 -> t2 Very common, so an important special case + -- See Note [Function types] + { ft_af :: AnonArgFlag -- Is this (->) or (=>)? + , ft_arg :: Type -- Argument type + , ft_res :: Type } -- Result type + + | LitTy TyLit -- ^ Type literals are similar to type constructors. + + | CastTy + Type + KindCoercion -- ^ A kind cast. The coercion is always nominal. + -- INVARIANT: The cast is never refl. + -- INVARIANT: The Type is not a CastTy (use TransCo instead) + -- See Note [Respecting definitional equality] (EQ2) and (EQ3) + + | CoercionTy + Coercion -- ^ Injection of a Coercion into a type + -- This should only ever be used in the RHS of an AppTy, + -- in the list of a TyConApp, when applying a promoted + -- GADT data constructor + + deriving Data.Data + +-- NOTE: Other parts of the code assume that type literals do not contain +-- types or type variables. +data TyLit + = NumTyLit Integer + | StrTyLit FastString + deriving (Eq, Ord, Data.Data) + + +{- Note [Function types] +~~~~~~~~~~~~~~~~~~~~~~~~ +FFunTy is the constructor for a function type. Lots of things to say +about it! + +* FFunTy is the data constructor, meaning "full function type". + +* The function type constructor (->) has kind + (->) :: forall r1 r2. TYPE r1 -> TYPE r2 -> Type LiftedRep + mkTyConApp ensure that we convert a saturated application + TyConApp (->) [r1,r2,t1,t2] into FunTy t1 t2 + dropping the 'r1' and 'r2' arguments; they are easily recovered + from 't1' and 't2'. + +* The ft_af field says whether or not this is an invisible argument + VisArg: t1 -> t2 Ordinary function type + InvisArg: t1 => t2 t1 is guaranteed to be a predicate type, + i.e. t1 :: Constraint + See Note [Types for coercions, predicates, and evidence] + + This visibility info makes no difference in Core; it matters + only when we regard the type as a Haskell source type. + +* FunTy is a (unidirectional) pattern synonym that allows + positional pattern matching (FunTy arg res), ignoring the + ArgFlag. +-} + +{- ----------------------- + Commented out until the pattern match + checker can handle it; see #16185 + + For now we use the CPP macro #define FunTy FFunTy _ + (see HsVersions.h) to allow pattern matching on a + (positional) FunTy constructor. + +{-# COMPLETE FunTy, TyVarTy, AppTy, TyConApp + , ForAllTy, LitTy, CastTy, CoercionTy :: Type #-} + +-- | 'FunTy' is a (uni-directional) pattern synonym for the common +-- case where we want to match on the argument/result type, but +-- ignoring the AnonArgFlag +pattern FunTy :: Type -> Type -> Type +pattern FunTy arg res <- FFunTy { ft_arg = arg, ft_res = res } + + End of commented out block +---------------------------------- -} + +{- Note [Types for coercions, predicates, and evidence] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We treat differently: + + (a) Predicate types + Test: isPredTy + Binders: DictIds + Kind: Constraint + Examples: (Eq a), and (a ~ b) + + (b) Coercion types are primitive, unboxed equalities + Test: isCoVarTy + Binders: CoVars (can appear in coercions) + Kind: TYPE (TupleRep []) + Examples: (t1 ~# t2) or (t1 ~R# t2) + + (c) Evidence types is the type of evidence manipulated by + the type constraint solver. + Test: isEvVarType + Binders: EvVars + Kind: Constraint or TYPE (TupleRep []) + Examples: all coercion types and predicate types + +Coercion types and predicate types are mutually exclusive, +but evidence types are a superset of both. + +When treated as a user type, + + - Predicates (of kind Constraint) are invisible and are + implicitly instantiated + + - Coercion types, and non-pred evidence types (i.e. not + of kind Constrain), are just regular old types, are + visible, and are not implicitly instantiated. + +In a FunTy { ft_af = InvisArg }, the argument type is always +a Predicate type. + +Note [Constraints in kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Do we allow a type constructor to have a kind like + S :: Eq a => a -> Type + +No, we do not. Doing so would mean would need a TyConApp like + S @k @(d :: Eq k) (ty :: k) + and we have no way to build, or decompose, evidence like + (d :: Eq k) at the type level. + +But we admit one exception: equality. We /do/ allow, say, + MkT :: (a ~ b) => a -> b -> Type a b + +Why? Because we can, without much difficulty. Moreover +we can promote a GADT data constructor (see TyCon +Note [Promoted data constructors]), like + data GT a b where + MkGT : a -> a -> GT a a +so programmers might reasonably expect to be able to +promote MkT as well. + +How does this work? + +* In TcValidity.checkConstraintsOK we reject kinds that + have constraints other than (a~b) and (a~~b). + +* In Inst.tcInstInvisibleTyBinder we instantiate a call + of MkT by emitting + [W] co :: alpha ~# beta + and producing the elaborated term + MkT @alpha @beta (Eq# alpha beta co) + We don't generate a boxed "Wanted"; we generate only a + regular old /unboxed/ primitive-equality Wanted, and build + the box on the spot. + +* How can we get such a MkT? By promoting a GADT-style data + constructor + data T a b where + MkT :: (a~b) => a -> b -> T a b + See DataCon.mkPromotedDataCon + and Note [Promoted data constructors] in TyCon + +* We support both homogeneous (~) and heterogeneous (~~) + equality. (See Note [The equality types story] + in TysPrim for a primer on these equality types.) + +* How do we prevent a MkT having an illegal constraint like + Eq a? We check for this at use-sites; see TcHsType.tcTyVar, + specifically dc_theta_illegal_constraint. + +* Notice that nothing special happens if + K :: (a ~# b) => blah + because (a ~# b) is not a predicate type, and is never + implicitly instantiated. (Mind you, it's not clear how you + could creates a type constructor with such a kind.) See + Note [Types for coercions, predicates, and evidence] + +* The existence of promoted MkT with an equality-constraint + argument is the (only) reason that the AnonTCB constructor + of TyConBndrVis carries an AnonArgFlag (VisArg/InvisArg). + For example, when we promote the data constructor + MkT :: forall a b. (a~b) => a -> b -> T a b + we get a PromotedDataCon with tyConBinders + Bndr (a :: Type) (NamedTCB Inferred) + Bndr (b :: Type) (NamedTCB Inferred) + Bndr (_ :: a ~ b) (AnonTCB InvisArg) + Bndr (_ :: a) (AnonTCB VisArg)) + Bndr (_ :: b) (AnonTCB VisArg)) + +* One might reasonably wonder who *unpacks* these boxes once they are + made. After all, there is no type-level `case` construct. The + surprising answer is that no one ever does. Instead, if a GADT + constructor is used on the left-hand side of a type family equation, + that occurrence forces GHC to unify the types in question. For + example: + + data G a where + MkG :: G Bool + + type family F (x :: G a) :: a where + F MkG = False + + When checking the LHS `F MkG`, GHC sees the MkG constructor and then must + unify F's implicit parameter `a` with Bool. This succeeds, making the equation + + F Bool (MkG @Bool ) = False + + Note that we never need unpack the coercion. This is because type + family equations are *not* parametric in their kind variables. That + is, we could have just said + + type family H (x :: G a) :: a where + H _ = False + + The presence of False on the RHS also forces `a` to become Bool, + giving us + + H Bool _ = False + + The fact that any of this works stems from the lack of phase + separation between types and kinds (unlike the very present phase + separation between terms and types). + + Once we have the ability to pattern-match on types below top-level, + this will no longer cut it, but it seems fine for now. + + +Note [Arguments to type constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Because of kind polymorphism, in addition to type application we now +have kind instantiation. We reuse the same notations to do so. + +For example: + + Just (* -> *) Maybe + Right * Nat Zero + +are represented by: + + TyConApp (PromotedDataCon Just) [* -> *, Maybe] + TyConApp (PromotedDataCon Right) [*, Nat, (PromotedDataCon Zero)] + +Important note: Nat is used as a *kind* and not as a type. This can be +confusing, since type-level Nat and kind-level Nat are identical. We +use the kind of (PromotedDataCon Right) to know if its arguments are +kinds or types. + +This kind instantiation only happens in TyConApp currently. + +Note [Non-trivial definitional equality] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Is Int |> <*> the same as Int? YES! In order to reduce headaches, +we decide that any reflexive casts in types are just ignored. +(Indeed they must be. See Note [Respecting definitional equality].) +More generally, the `eqType` function, which defines Core's type equality +relation, ignores casts and coercion arguments, as long as the +two types have the same kind. This allows us to be a little sloppier +in keeping track of coercions, which is a good thing. It also means +that eqType does not depend on eqCoercion, which is also a good thing. + +Why is this sensible? That is, why is something different than α-equivalence +appropriate for the implementation of eqType? + +Anything smaller than ~ and homogeneous is an appropriate definition for +equality. The type safety of FC depends only on ~. Let's say η : τ ~ σ. Any +expression of type τ can be transmuted to one of type σ at any point by +casting. The same is true of expressions of type σ. So in some sense, τ and σ +are interchangeable. + +But let's be more precise. If we examine the typing rules of FC (say, those in +https://cs.brynmawr.edu/~rae/papers/2015/equalities/equalities.pdf) +there are several places where the same metavariable is used in two different +premises to a rule. (For example, see Ty_App.) There is an implicit equality +check here. What definition of equality should we use? By convention, we use +α-equivalence. Take any rule with one (or more) of these implicit equality +checks. Then there is an admissible rule that uses ~ instead of the implicit +check, adding in casts as appropriate. + +The only problem here is that ~ is heterogeneous. To make the kinds work out +in the admissible rule that uses ~, it is necessary to homogenize the +coercions. That is, if we have η : (τ : κ1) ~ (σ : κ2), then we don't use η; +we use η |> kind η, which is homogeneous. + +The effect of this all is that eqType, the implementation of the implicit +equality check, can use any homogeneous relation that is smaller than ~, as +those rules must also be admissible. + +A more drawn out argument around all of this is presented in Section 7.2 of +Richard E's thesis (http://cs.brynmawr.edu/~rae/papers/2016/thesis/eisenberg-thesis.pdf). + +What would go wrong if we insisted on the casts matching? See the beginning of +Section 8 in the unpublished paper above. Theoretically, nothing at all goes +wrong. But in practical terms, getting the coercions right proved to be +nightmarish. And types would explode: during kind-checking, we often produce +reflexive kind coercions. When we try to cast by these, mkCastTy just discards +them. But if we used an eqType that distinguished between Int and Int |> <*>, +then we couldn't discard -- the output of kind-checking would be enormous, +and we would need enormous casts with lots of CoherenceCo's to straighten +them out. + +Would anything go wrong if eqType respected type families? No, not at all. But +that makes eqType rather hard to implement. + +Thus, the guideline for eqType is that it should be the largest +easy-to-implement relation that is still smaller than ~ and homogeneous. The +precise choice of relation is somewhat incidental, as long as the smart +constructors and destructors in Type respect whatever relation is chosen. + +Another helpful principle with eqType is this: + + (EQ) If (t1 `eqType` t2) then I can replace t1 by t2 anywhere. + +This principle also tells us that eqType must relate only types with the +same kinds. + +Note [Respecting definitional equality] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Non-trivial definitional equality] introduces the property (EQ). +How is this upheld? + +Any function that pattern matches on all the constructors will have to +consider the possibility of CastTy. Presumably, those functions will handle +CastTy appropriately and we'll be OK. + +More dangerous are the splitXXX functions. Let's focus on splitTyConApp. +We don't want it to fail on (T a b c |> co). Happily, if we have + (T a b c |> co) `eqType` (T d e f) +then co must be reflexive. Why? eqType checks that the kinds are equal, as +well as checking that (a `eqType` d), (b `eqType` e), and (c `eqType` f). +By the kind check, we know that (T a b c |> co) and (T d e f) have the same +kind. So the only way that co could be non-reflexive is for (T a b c) to have +a different kind than (T d e f). But because T's kind is closed (all tycon kinds +are closed), the only way for this to happen is that one of the arguments has +to differ, leading to a contradiction. Thus, co is reflexive. + +Accordingly, by eliminating reflexive casts, splitTyConApp need not worry +about outermost casts to uphold (EQ). Eliminating reflexive casts is done +in mkCastTy. + +Unforunately, that's not the end of the story. Consider comparing + (T a b c) =? (T a b |> (co -> )) (c |> co) +These two types have the same kind (Type), but the left type is a TyConApp +while the right type is not. To handle this case, we say that the right-hand +type is ill-formed, requiring an AppTy never to have a casted TyConApp +on its left. It is easy enough to pull around the coercions to maintain +this invariant, as done in Type.mkAppTy. In the example above, trying to +form the right-hand type will instead yield (T a b (c |> co |> sym co) |> ). +Both the casts there are reflexive and will be dropped. Huzzah. + +This idea of pulling coercions to the right works for splitAppTy as well. + +However, there is one hiccup: it's possible that a coercion doesn't relate two +Pi-types. For example, if we have @type family Fun a b where Fun a b = a -> b@, +then we might have (T :: Fun Type Type) and (T |> axFun) Int. That axFun can't +be pulled to the right. But we don't need to pull it: (T |> axFun) Int is not +`eqType` to any proper TyConApp -- thus, leaving it where it is doesn't violate +our (EQ) property. + +Lastly, in order to detect reflexive casts reliably, we must make sure not +to have nested casts: we update (t |> co1 |> co2) to (t |> (co1 `TransCo` co2)). + +In sum, in order to uphold (EQ), we need the following three invariants: + + (EQ1) No decomposable CastTy to the left of an AppTy, where a decomposable + cast is one that relates either a FunTy to a FunTy or a + ForAllTy to a ForAllTy. + (EQ2) No reflexive casts in CastTy. + (EQ3) No nested CastTys. + (EQ4) No CastTy over (ForAllTy (Bndr tyvar vis) body). + See Note [Weird typing rule for ForAllTy] in Type. + +These invariants are all documented above, in the declaration for Type. + +Note [Unused coercion variable in ForAllTy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + \(co:t1 ~ t2). e + +What type should we give to this expression? + (1) forall (co:t1 ~ t2) -> t + (2) (t1 ~ t2) -> t + +If co is used in t, (1) should be the right choice. +if co is not used in t, we would like to have (1) and (2) equivalent. + +However, we want to keep eqType simple and don't want eqType (1) (2) to return +True in any case. + +We decide to always construct (2) if co is not used in t. + +Thus in mkLamType, we check whether the variable is a coercion +variable (of type (t1 ~# t2), and whether it is un-used in the +body. If so, it returns a FunTy instead of a ForAllTy. + +There are cases we want to skip the check. For example, the check is +unnecessary when it is known from the context that the input variable +is a type variable. In those cases, we use mkForAllTy. + +-} + +-- | A type labeled 'KnotTied' might have knot-tied tycons in it. See +-- Note [Type checking recursive type and class declarations] in +-- TcTyClsDecls +type KnotTied ty = ty + +{- ********************************************************************** +* * + TyCoBinder and ArgFlag +* * +********************************************************************** -} + +-- | A 'TyCoBinder' represents an argument to a function. TyCoBinders can be +-- dependent ('Named') or nondependent ('Anon'). They may also be visible or +-- not. See Note [TyCoBinders] +data TyCoBinder + = Named TyCoVarBinder -- A type-lambda binder + | Anon AnonArgFlag Type -- A term-lambda binder. Type here can be CoercionTy. + -- Visibility is determined by the AnonArgFlag + deriving Data.Data + +-- | 'TyBinder' is like 'TyCoBinder', but there can only be 'TyVarBinder' +-- in the 'Named' field. +type TyBinder = TyCoBinder + +-- | Remove the binder's variable from the set, if the binder has +-- a variable. +delBinderVar :: VarSet -> TyCoVarBinder -> VarSet +delBinderVar vars (Bndr tv _) = vars `delVarSet` tv + +-- | Does this binder bind an invisible argument? +isInvisibleBinder :: TyCoBinder -> Bool +isInvisibleBinder (Named (Bndr _ vis)) = isInvisibleArgFlag vis +isInvisibleBinder (Anon InvisArg _) = True +isInvisibleBinder (Anon VisArg _) = False + +-- | Does this binder bind a visible argument? +isVisibleBinder :: TyCoBinder -> Bool +isVisibleBinder = not . isInvisibleBinder + +isNamedBinder :: TyCoBinder -> Bool +isNamedBinder (Named {}) = True +isNamedBinder (Anon {}) = False + +-- | If its a named binder, is the binder a tyvar? +-- Returns True for nondependent binder. +-- This check that we're really returning a *Ty*Binder (as opposed to a +-- coercion binder). That way, if/when we allow coercion quantification +-- in more places, we'll know we missed updating some function. +isTyBinder :: TyCoBinder -> Bool +isTyBinder (Named bnd) = isTyVarBinder bnd +isTyBinder _ = True + +{- Note [TyCoBinders] +~~~~~~~~~~~~~~~~~~~ +A ForAllTy contains a TyCoVarBinder. But a type can be decomposed +to a telescope consisting of a [TyCoBinder] + +A TyCoBinder represents the type of binders -- that is, the type of an +argument to a Pi-type. GHC Core currently supports two different +Pi-types: + + * A non-dependent function type, + written with ->, e.g. ty1 -> ty2 + represented as FunTy ty1 ty2. These are + lifted to Coercions with the corresponding FunCo. + + * A dependent compile-time-only polytype, + written with forall, e.g. forall (a:*). ty + represented as ForAllTy (Bndr a v) ty + +Both Pi-types classify terms/types that take an argument. In other +words, if `x` is either a function or a polytype, `x arg` makes sense +(for an appropriate `arg`). + + +Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* A ForAllTy (used for both types and kinds) contains a TyCoVarBinder. + Each TyCoVarBinder + Bndr a tvis + is equipped with tvis::ArgFlag, which says whether or not arguments + for this binder should be visible (explicit) in source Haskell. + +* A TyCon contains a list of TyConBinders. Each TyConBinder + Bndr a cvis + is equipped with cvis::TyConBndrVis, which says whether or not type + and kind arguments for this TyCon should be visible (explicit) in + source Haskell. + +This table summarises the visibility rules: +--------------------------------------------------------------------------------------- +| Occurrences look like this +| GHC displays type as in Haskell source code +|-------------------------------------------------------------------------------------- +| Bndr a tvis :: TyCoVarBinder, in the binder of ForAllTy for a term +| tvis :: ArgFlag +| tvis = Inferred: f :: forall {a}. type Arg not allowed: f + f :: forall {co}. type Arg not allowed: f +| tvis = Specified: f :: forall a. type Arg optional: f or f @Int +| tvis = Required: T :: forall k -> type Arg required: T * +| This last form is illegal in terms: See Note [No Required TyCoBinder in terms] +| +| Bndr k cvis :: TyConBinder, in the TyConBinders of a TyCon +| cvis :: TyConBndrVis +| cvis = AnonTCB: T :: kind -> kind Required: T * +| cvis = NamedTCB Inferred: T :: forall {k}. kind Arg not allowed: T +| T :: forall {co}. kind Arg not allowed: T +| cvis = NamedTCB Specified: T :: forall k. kind Arg not allowed[1]: T +| cvis = NamedTCB Required: T :: forall k -> kind Required: T * +--------------------------------------------------------------------------------------- + +[1] In types, in the Specified case, it would make sense to allow + optional kind applications, thus (T @*), but we have not + yet implemented that + +---- In term declarations ---- + +* Inferred. Function defn, with no signature: f1 x = x + We infer f1 :: forall {a}. a -> a, with 'a' Inferred + It's Inferred because it doesn't appear in any + user-written signature for f1 + +* Specified. Function defn, with signature (implicit forall): + f2 :: a -> a; f2 x = x + So f2 gets the type f2 :: forall a. a -> a, with 'a' Specified + even though 'a' is not bound in the source code by an explicit forall + +* Specified. Function defn, with signature (explicit forall): + f3 :: forall a. a -> a; f3 x = x + So f3 gets the type f3 :: forall a. a -> a, with 'a' Specified + +* Inferred/Specified. Function signature with inferred kind polymorphism. + f4 :: a b -> Int + So 'f4' gets the type f4 :: forall {k} (a:k->*) (b:k). a b -> Int + Here 'k' is Inferred (it's not mentioned in the type), + but 'a' and 'b' are Specified. + +* Specified. Function signature with explicit kind polymorphism + f5 :: a (b :: k) -> Int + This time 'k' is Specified, because it is mentioned explicitly, + so we get f5 :: forall (k:*) (a:k->*) (b:k). a b -> Int + +* Similarly pattern synonyms: + Inferred - from inferred types (e.g. no pattern type signature) + - or from inferred kind polymorphism + +---- In type declarations ---- + +* Inferred (k) + data T1 a b = MkT1 (a b) + Here T1's kind is T1 :: forall {k:*}. (k->*) -> k -> * + The kind variable 'k' is Inferred, since it is not mentioned + + Note that 'a' and 'b' correspond to /Anon/ TyCoBinders in T1's kind, + and Anon binders don't have a visibility flag. (Or you could think + of Anon having an implicit Required flag.) + +* Specified (k) + data T2 (a::k->*) b = MkT (a b) + Here T's kind is T :: forall (k:*). (k->*) -> k -> * + The kind variable 'k' is Specified, since it is mentioned in + the signature. + +* Required (k) + data T k (a::k->*) b = MkT (a b) + Here T's kind is T :: forall k:* -> (k->*) -> k -> * + The kind is Required, since it bound in a positional way in T's declaration + Every use of T must be explicitly applied to a kind + +* Inferred (k1), Specified (k) + data T a b (c :: k) = MkT (a b) (Proxy c) + Here T's kind is T :: forall {k1:*} (k:*). (k1->*) -> k1 -> k -> * + So 'k' is Specified, because it appears explicitly, + but 'k1' is Inferred, because it does not + +Generally, in the list of TyConBinders for a TyCon, + +* Inferred arguments always come first +* Specified, Anon and Required can be mixed + +e.g. + data Foo (a :: Type) :: forall b. (a -> b -> Type) -> Type where ... + +Here Foo's TyConBinders are + [Required 'a', Specified 'b', Anon] +and its kind prints as + Foo :: forall a -> forall b. (a -> b -> Type) -> Type + +See also Note [Required, Specified, and Inferred for types] in TcTyClsDecls + +---- Printing ----- + + We print forall types with enough syntax to tell you their visibility + flag. But this is not source Haskell, and these types may not all + be parsable. + + Specified: a list of Specified binders is written between `forall` and `.`: + const :: forall a b. a -> b -> a + + Inferred: with -fprint-explicit-foralls, Inferred binders are written + in braces: + f :: forall {k} (a:k). S k a -> Int + Otherwise, they are printed like Specified binders. + + Required: binders are put between `forall` and `->`: + T :: forall k -> * + +---- Other points ----- + +* In classic Haskell, all named binders (that is, the type variables in + a polymorphic function type f :: forall a. a -> a) have been Inferred. + +* Inferred variables correspond to "generalized" variables from the + Visible Type Applications paper (ESOP'16). + +Note [No Required TyCoBinder in terms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't allow Required foralls for term variables, including pattern +synonyms and data constructors. Why? Because then an application +would need a /compulsory/ type argument (possibly without an "@"?), +thus (f Int); and we don't have concrete syntax for that. + +We could change this decision, but Required, Named TyCoBinders are rare +anyway. (Most are Anons.) + +However the type of a term can (just about) have a required quantifier; +see Note [Required quantifiers in the type of a term] in TcExpr. +-} + + +{- ********************************************************************** +* * + PredType +* * +********************************************************************** -} + + +-- | A type of the form @p@ of kind @Constraint@ represents a value whose type is +-- the Haskell predicate @p@, where a predicate is what occurs before +-- the @=>@ in a Haskell type. +-- +-- We use 'PredType' as documentation to mark those types that we guarantee to have +-- this kind. +-- +-- It can be expanded into its representation, but: +-- +-- * The type checker must treat it as opaque +-- +-- * The rest of the compiler treats it as transparent +-- +-- Consider these examples: +-- +-- > f :: (Eq a) => a -> Int +-- > g :: (?x :: Int -> Int) => a -> Int +-- > h :: (r\l) => {r} => {l::Int | r} +-- +-- Here the @Eq a@ and @?x :: Int -> Int@ and @r\l@ are all called \"predicates\" +type PredType = Type + +-- | A collection of 'PredType's +type ThetaType = [PredType] + +{- +(We don't support TREX records yet, but the setup is designed +to expand to allow them.) + +A Haskell qualified type, such as that for f,g,h above, is +represented using + * a FunTy for the double arrow + * with a type of kind Constraint as the function argument + +The predicate really does turn into a real extra argument to the +function. If the argument has type (p :: Constraint) then the predicate p is +represented by evidence of type p. + + +%************************************************************************ +%* * + Simple constructors +%* * +%************************************************************************ + +These functions are here so that they can be used by TysPrim, +which in turn is imported by Type +-} + +mkTyVarTy :: TyVar -> Type +mkTyVarTy v = ASSERT2( isTyVar v, ppr v <+> dcolon <+> ppr (tyVarKind v) ) + TyVarTy v + +mkTyVarTys :: [TyVar] -> [Type] +mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy + +mkTyCoVarTy :: TyCoVar -> Type +mkTyCoVarTy v + | isTyVar v + = TyVarTy v + | otherwise + = CoercionTy (CoVarCo v) + +mkTyCoVarTys :: [TyCoVar] -> [Type] +mkTyCoVarTys = map mkTyCoVarTy + +infixr 3 `mkFunTy`, `mkVisFunTy`, `mkInvisFunTy` -- Associates to the right + +mkFunTy :: AnonArgFlag -> Type -> Type -> Type +mkFunTy af arg res = FunTy { ft_af = af, ft_arg = arg, ft_res = res } + +mkVisFunTy, mkInvisFunTy :: Type -> Type -> Type +mkVisFunTy = mkFunTy VisArg +mkInvisFunTy = mkFunTy InvisArg + +-- | Make nested arrow types +mkVisFunTys, mkInvisFunTys :: [Type] -> Type -> Type +mkVisFunTys tys ty = foldr mkVisFunTy ty tys +mkInvisFunTys tys ty = foldr mkInvisFunTy ty tys + +-- | Like 'mkTyCoForAllTy', but does not check the occurrence of the binder +-- See Note [Unused coercion variable in ForAllTy] +mkForAllTy :: TyCoVar -> ArgFlag -> Type -> Type +mkForAllTy tv vis ty = ForAllTy (Bndr tv vis) ty + +-- | Wraps foralls over the type using the provided 'TyCoVar's from left to right +mkForAllTys :: [TyCoVarBinder] -> Type -> Type +mkForAllTys tyvars ty = foldr ForAllTy ty tyvars + +mkPiTy:: TyCoBinder -> Type -> Type +mkPiTy (Anon af ty1) ty2 = FunTy { ft_af = af, ft_arg = ty1, ft_res = ty2 } +mkPiTy (Named (Bndr tv vis)) ty = mkForAllTy tv vis ty + +mkPiTys :: [TyCoBinder] -> Type -> Type +mkPiTys tbs ty = foldr mkPiTy ty tbs + +-- | Create the plain type constructor type which has been applied to no type arguments at all. +mkTyConTy :: TyCon -> Type +mkTyConTy tycon = TyConApp tycon [] + +{- +Some basic functions, put here to break loops eg with the pretty printer +-} + +-- | Extract the RuntimeRep classifier of a type from its kind. For example, +-- @kindRep * = LiftedRep@; Panics if this is not possible. +-- Treats * and Constraint as the same +kindRep :: HasDebugCallStack => Kind -> Type +kindRep k = case kindRep_maybe k of + Just r -> r + Nothing -> pprPanic "kindRep" (ppr k) + +-- | Given a kind (TYPE rr), extract its RuntimeRep classifier rr. +-- For example, @kindRep_maybe * = Just LiftedRep@ +-- Returns 'Nothing' if the kind is not of form (TYPE rr) +-- Treats * and Constraint as the same +kindRep_maybe :: HasDebugCallStack => Kind -> Maybe Type +kindRep_maybe kind + | Just kind' <- coreView kind = kindRep_maybe kind' + | TyConApp tc [arg] <- kind + , tc `hasKey` tYPETyConKey = Just arg + | otherwise = Nothing + +-- | This version considers Constraint to be the same as *. Returns True +-- if the argument is equivalent to Type/Constraint and False otherwise. +-- See Note [Kind Constraint and kind Type] +isLiftedTypeKind :: Kind -> Bool +isLiftedTypeKind kind + = case kindRep_maybe kind of + Just rep -> isLiftedRuntimeRep rep + Nothing -> False + +-- | Returns True if the kind classifies unlifted types and False otherwise. +-- Note that this returns False for levity-polymorphic kinds, which may +-- be specialized to a kind that classifies unlifted types. +isUnliftedTypeKind :: Kind -> Bool +isUnliftedTypeKind kind + = case kindRep_maybe kind of + Just rep -> isUnliftedRuntimeRep rep + Nothing -> False + +isLiftedRuntimeRep :: Type -> Bool +-- isLiftedRuntimeRep is true of LiftedRep :: RuntimeRep +-- False of type variables (a :: RuntimeRep) +-- and of other reps e.g. (IntRep :: RuntimeRep) +isLiftedRuntimeRep rep + | Just rep' <- coreView rep = isLiftedRuntimeRep rep' + | TyConApp rr_tc args <- rep + , rr_tc `hasKey` liftedRepDataConKey = ASSERT( null args ) True + | otherwise = False + +isUnliftedRuntimeRep :: Type -> Bool +-- True of definitely-unlifted RuntimeReps +-- False of (LiftedRep :: RuntimeRep) +-- and of variables (a :: RuntimeRep) +isUnliftedRuntimeRep rep + | Just rep' <- coreView rep = isUnliftedRuntimeRep rep' + | TyConApp rr_tc _ <- rep -- NB: args might be non-empty + -- e.g. TupleRep [r1, .., rn] + = isPromotedDataCon rr_tc && not (rr_tc `hasKey` liftedRepDataConKey) + -- Avoid searching all the unlifted RuntimeRep type cons + -- In the RuntimeRep data type, only LiftedRep is lifted + -- But be careful of type families (F tys) :: RuntimeRep + | otherwise {- Variables, applications -} + = False + +-- | Is this the type 'RuntimeRep'? +isRuntimeRepTy :: Type -> Bool +isRuntimeRepTy ty | Just ty' <- coreView ty = isRuntimeRepTy ty' +isRuntimeRepTy (TyConApp tc args) + | tc `hasKey` runtimeRepTyConKey = ASSERT( null args ) True +isRuntimeRepTy _ = False + +-- | Is a tyvar of type 'RuntimeRep'? +isRuntimeRepVar :: TyVar -> Bool +isRuntimeRepVar = isRuntimeRepTy . tyVarKind + +{- +%************************************************************************ +%* * + Coercions +%* * +%************************************************************************ +-} + +-- | A 'Coercion' is concrete evidence of the equality/convertibility +-- of two types. + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in coreSyn/CoreLint.hs +data Coercion + -- Each constructor has a "role signature", indicating the way roles are + -- propagated through coercions. + -- - P, N, and R stand for coercions of the given role + -- - e stands for a coercion of a specific unknown role + -- (think "role polymorphism") + -- - "e" stands for an explicit role parameter indicating role e. + -- - _ stands for a parameter that is not a Role or Coercion. + + -- These ones mirror the shape of types + = -- Refl :: _ -> N + Refl Type -- See Note [Refl invariant] + -- Invariant: applications of (Refl T) to a bunch of identity coercions + -- always show up as Refl. + -- For example (Refl T) (Refl a) (Refl b) shows up as (Refl (T a b)). + + -- Applications of (Refl T) to some coercions, at least one of + -- which is NOT the identity, show up as TyConAppCo. + -- (They may not be fully saturated however.) + -- ConAppCo coercions (like all coercions other than Refl) + -- are NEVER the identity. + + -- Use (GRefl Representational ty MRefl), not (SubCo (Refl ty)) + + -- GRefl :: "e" -> _ -> Maybe N -> e + -- See Note [Generalized reflexive coercion] + | GRefl Role Type MCoercionN -- See Note [Refl invariant] + -- Use (Refl ty), not (GRefl Nominal ty MRefl) + -- Use (GRefl Representational _ _), not (SubCo (GRefl Nominal _ _)) + + -- These ones simply lift the correspondingly-named + -- Type constructors into Coercions + + -- TyConAppCo :: "e" -> _ -> ?? -> e + -- See Note [TyConAppCo roles] + | TyConAppCo Role TyCon [Coercion] -- lift TyConApp + -- The TyCon is never a synonym; + -- we expand synonyms eagerly + -- But it can be a type function + + | AppCo Coercion CoercionN -- lift AppTy + -- AppCo :: e -> N -> e + + -- See Note [Forall coercions] + | ForAllCo TyCoVar KindCoercion Coercion + -- ForAllCo :: _ -> N -> e -> e + + | FunCo Role Coercion Coercion -- lift FunTy + -- FunCo :: "e" -> e -> e -> e + -- Note: why doesn't FunCo have a AnonArgFlag, like FunTy? + -- Because the AnonArgFlag has no impact on Core; it is only + -- there to guide implicit instantiation of Haskell source + -- types, and that is irrelevant for coercions, which are + -- Core-only. + + -- These are special + | CoVarCo CoVar -- :: _ -> (N or R) + -- result role depends on the tycon of the variable's type + + -- AxiomInstCo :: e -> _ -> [N] -> e + | AxiomInstCo (CoAxiom Branched) BranchIndex [Coercion] + -- See also [CoAxiom index] + -- The coercion arguments always *precisely* saturate + -- arity of (that branch of) the CoAxiom. If there are + -- any left over, we use AppCo. + -- See [Coercion axioms applied to coercions] + + | AxiomRuleCo CoAxiomRule [Coercion] + -- AxiomRuleCo is very like AxiomInstCo, but for a CoAxiomRule + -- The number coercions should match exactly the expectations + -- of the CoAxiomRule (i.e., the rule is fully saturated). + + | UnivCo UnivCoProvenance Role Type Type + -- :: _ -> "e" -> _ -> _ -> e + + | SymCo Coercion -- :: e -> e + | TransCo Coercion Coercion -- :: e -> e -> e + + | NthCo Role Int Coercion -- Zero-indexed; decomposes (T t0 ... tn) + -- :: "e" -> _ -> e0 -> e (inverse of TyConAppCo, see Note [TyConAppCo roles]) + -- Using NthCo on a ForAllCo gives an N coercion always + -- See Note [NthCo and newtypes] + -- + -- Invariant: (NthCo r i co), it is always the case that r = role of (Nth i co) + -- That is: the role of the entire coercion is redundantly cached here. + -- See Note [NthCo Cached Roles] + + | LRCo LeftOrRight CoercionN -- Decomposes (t_left t_right) + -- :: _ -> N -> N + | InstCo Coercion CoercionN + -- :: e -> N -> e + -- See Note [InstCo roles] + + -- Extract a kind coercion from a (heterogeneous) type coercion + -- NB: all kind coercions are Nominal + | KindCo Coercion + -- :: e -> N + + | SubCo CoercionN -- Turns a ~N into a ~R + -- :: N -> R + + | HoleCo CoercionHole -- ^ See Note [Coercion holes] + -- Only present during typechecking + deriving Data.Data + +type CoercionN = Coercion -- always nominal +type CoercionR = Coercion -- always representational +type CoercionP = Coercion -- always phantom +type KindCoercion = CoercionN -- always nominal + +-- | A semantically more meaningful type to represent what may or may not be a +-- useful 'Coercion'. +data MCoercion + = MRefl + -- A trivial Reflexivity coercion + | MCo Coercion + -- Other coercions + deriving Data.Data +type MCoercionR = MCoercion +type MCoercionN = MCoercion + +instance Outputable MCoercion where + ppr MRefl = text "MRefl" + ppr (MCo co) = text "MCo" <+> ppr co + +{- +Note [Refl invariant] +~~~~~~~~~~~~~~~~~~~~~ +Invariant 1: + +Coercions have the following invariant + Refl (similar for GRefl r ty MRefl) is always lifted as far as possible. + +You might think that a consequencs is: + Every identity coercions has Refl at the root + +But that's not quite true because of coercion variables. Consider + g where g :: Int~Int + Left h where h :: Maybe Int ~ Maybe Int +etc. So the consequence is only true of coercions that +have no coercion variables. + +Note [Generalized reflexive coercion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +GRefl is a generalized reflexive coercion (see #15192). It wraps a kind +coercion, which might be reflexive (MRefl) or any coercion (MCo co). The typing +rules for GRefl: + + ty : k1 + ------------------------------------ + GRefl r ty MRefl: ty ~r ty + + ty : k1 co :: k1 ~ k2 + ------------------------------------ + GRefl r ty (MCo co) : ty ~r ty |> co + +Consider we have + + g1 :: s ~r t + s :: k1 + g2 :: k1 ~ k2 + +and we want to construct a coercions co which has type + + (s |> g2) ~r t + +We can define + + co = Sym (GRefl r s g2) ; g1 + +It is easy to see that + + Refl == GRefl Nominal ty MRefl :: ty ~n ty + +A nominal reflexive coercion is quite common, so we keep the special form Refl to +save allocation. + +Note [Coercion axioms applied to coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The reason coercion axioms can be applied to coercions and not just +types is to allow for better optimization. There are some cases where +we need to be able to "push transitivity inside" an axiom in order to +expose further opportunities for optimization. + +For example, suppose we have + + C a : t[a] ~ F a + g : b ~ c + +and we want to optimize + + sym (C b) ; t[g] ; C c + +which has the kind + + F b ~ F c + +(stopping through t[b] and t[c] along the way). + +We'd like to optimize this to just F g -- but how? The key is +that we need to allow axioms to be instantiated by *coercions*, +not just by types. Then we can (in certain cases) push +transitivity inside the axiom instantiations, and then react +opposite-polarity instantiations of the same axiom. In this +case, e.g., we match t[g] against the LHS of (C c)'s kind, to +obtain the substitution a |-> g (note this operation is sort +of the dual of lifting!) and hence end up with + + C g : t[b] ~ F c + +which indeed has the same kind as t[g] ; C c. + +Now we have + + sym (C b) ; C g + +which can be optimized to F g. + +Note [CoAxiom index] +~~~~~~~~~~~~~~~~~~~~ +A CoAxiom has 1 or more branches. Each branch has contains a list +of the free type variables in that branch, the LHS type patterns, +and the RHS type for that branch. When we apply an axiom to a list +of coercions, we must choose which branch of the axiom we wish to +use, as the different branches may have different numbers of free +type variables. (The number of type patterns is always the same +among branches, but that doesn't quite concern us here.) + +The Int in the AxiomInstCo constructor is the 0-indexed number +of the chosen branch. + +Note [Forall coercions] +~~~~~~~~~~~~~~~~~~~~~~~ +Constructing coercions between forall-types can be a bit tricky, +because the kinds of the bound tyvars can be different. + +The typing rule is: + + + kind_co : k1 ~ k2 + tv1:k1 |- co : t1 ~ t2 + ------------------------------------------------------------------- + ForAllCo tv1 kind_co co : all tv1:k1. t1 ~ + all tv1:k2. (t2[tv1 |-> tv1 |> sym kind_co]) + +First, the TyCoVar stored in a ForAllCo is really an optimisation: this field +should be a Name, as its kind is redundant. Thinking of the field as a Name +is helpful in understanding what a ForAllCo means. +The kind of TyCoVar always matches the left-hand kind of the coercion. + +The idea is that kind_co gives the two kinds of the tyvar. See how, in the +conclusion, tv1 is assigned kind k1 on the left but kind k2 on the right. + +Of course, a type variable can't have different kinds at the same time. So, +we arbitrarily prefer the first kind when using tv1 in the inner coercion +co, which shows that t1 equals t2. + +The last wrinkle is that we need to fix the kinds in the conclusion. In +t2, tv1 is assumed to have kind k1, but it has kind k2 in the conclusion of +the rule. So we do a kind-fixing substitution, replacing (tv1:k1) with +(tv1:k2) |> sym kind_co. This substitution is slightly bizarre, because it +mentions the same name with different kinds, but it *is* well-kinded, noting +that `(tv1:k2) |> sym kind_co` has kind k1. + +This all really would work storing just a Name in the ForAllCo. But we can't +add Names to, e.g., VarSets, and there generally is just an impedance mismatch +in a bunch of places. So we use tv1. When we need tv2, we can use +setTyVarKind. + +Note [Predicate coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + g :: a~b +How can we coerce between types + ([c]~a) => [a] -> c +and + ([c]~b) => [b] -> c +where the equality predicate *itself* differs? + +Answer: we simply treat (~) as an ordinary type constructor, so these +types really look like + + ((~) [c] a) -> [a] -> c + ((~) [c] b) -> [b] -> c + +So the coercion between the two is obviously + + ((~) [c] g) -> [g] -> c + +Another way to see this to say that we simply collapse predicates to +their representation type (see Type.coreView and Type.predTypeRep). + +This collapse is done by mkPredCo; there is no PredCo constructor +in Coercion. This is important because we need Nth to work on +predicates too: + Nth 1 ((~) [c] g) = g +See Simplify.simplCoercionF, which generates such selections. + +Note [Roles] +~~~~~~~~~~~~ +Roles are a solution to the GeneralizedNewtypeDeriving problem, articulated +in #1496. The full story is in docs/core-spec/core-spec.pdf. Also, see +https://gitlab.haskell.org/ghc/ghc/wikis/roles-implementation + +Here is one way to phrase the problem: + +Given: +newtype Age = MkAge Int +type family F x +type instance F Age = Bool +type instance F Int = Char + +This compiles down to: +axAge :: Age ~ Int +axF1 :: F Age ~ Bool +axF2 :: F Int ~ Char + +Then, we can make: +(sym (axF1) ; F axAge ; axF2) :: Bool ~ Char + +Yikes! + +The solution is _roles_, as articulated in "Generative Type Abstraction and +Type-level Computation" (POPL 2010), available at +http://www.seas.upenn.edu/~sweirich/papers/popl163af-weirich.pdf + +The specification for roles has evolved somewhat since that paper. For the +current full details, see the documentation in docs/core-spec. Here are some +highlights. + +We label every equality with a notion of type equivalence, of which there are +three options: Nominal, Representational, and Phantom. A ground type is +nominally equivalent only with itself. A newtype (which is considered a ground +type in Haskell) is representationally equivalent to its representation. +Anything is "phantomly" equivalent to anything else. We use "N", "R", and "P" +to denote the equivalences. + +The axioms above would be: +axAge :: Age ~R Int +axF1 :: F Age ~N Bool +axF2 :: F Age ~N Char + +Then, because transitivity applies only to coercions proving the same notion +of equivalence, the above construction is impossible. + +However, there is still an escape hatch: we know that any two types that are +nominally equivalent are representationally equivalent as well. This is what +the form SubCo proves -- it "demotes" a nominal equivalence into a +representational equivalence. So, it would seem the following is possible: + +sub (sym axF1) ; F axAge ; sub axF2 :: Bool ~R Char -- WRONG + +What saves us here is that the arguments to a type function F, lifted into a +coercion, *must* prove nominal equivalence. So, (F axAge) is ill-formed, and +we are safe. + +Roles are attached to parameters to TyCons. When lifting a TyCon into a +coercion (through TyConAppCo), we need to ensure that the arguments to the +TyCon respect their roles. For example: + +data T a b = MkT a (F b) + +If we know that a1 ~R a2, then we know (T a1 b) ~R (T a2 b). But, if we know +that b1 ~R b2, we know nothing about (T a b1) and (T a b2)! This is because +the type function F branches on b's *name*, not representation. So, we say +that 'a' has role Representational and 'b' has role Nominal. The third role, +Phantom, is for parameters not used in the type's definition. Given the +following definition + +data Q a = MkQ Int + +the Phantom role allows us to say that (Q Bool) ~R (Q Char), because we +can construct the coercion Bool ~P Char (using UnivCo). + +See the paper cited above for more examples and information. + +Note [TyConAppCo roles] +~~~~~~~~~~~~~~~~~~~~~~~ +The TyConAppCo constructor has a role parameter, indicating the role at +which the coercion proves equality. The choice of this parameter affects +the required roles of the arguments of the TyConAppCo. To help explain +it, assume the following definition: + + type instance F Int = Bool -- Axiom axF : F Int ~N Bool + newtype Age = MkAge Int -- Axiom axAge : Age ~R Int + data Foo a = MkFoo a -- Role on Foo's parameter is Representational + +TyConAppCo Nominal Foo axF : Foo (F Int) ~N Foo Bool + For (TyConAppCo Nominal) all arguments must have role Nominal. Why? + So that Foo Age ~N Foo Int does *not* hold. + +TyConAppCo Representational Foo (SubCo axF) : Foo (F Int) ~R Foo Bool +TyConAppCo Representational Foo axAge : Foo Age ~R Foo Int + For (TyConAppCo Representational), all arguments must have the roles + corresponding to the result of tyConRoles on the TyCon. This is the + whole point of having roles on the TyCon to begin with. So, we can + have Foo Age ~R Foo Int, if Foo's parameter has role R. + + If a Representational TyConAppCo is over-saturated (which is otherwise fine), + the spill-over arguments must all be at Nominal. This corresponds to the + behavior for AppCo. + +TyConAppCo Phantom Foo (UnivCo Phantom Int Bool) : Foo Int ~P Foo Bool + All arguments must have role Phantom. This one isn't strictly + necessary for soundness, but this choice removes ambiguity. + +The rules here dictate the roles of the parameters to mkTyConAppCo +(should be checked by Lint). + +Note [NthCo and newtypes] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + + newtype N a = MkN Int + type role N representational + +This yields axiom + + NTCo:N :: forall a. N a ~R Int + +We can then build + + co :: forall a b. N a ~R N b + co = NTCo:N a ; sym (NTCo:N b) + +for any `a` and `b`. Because of the role annotation on N, if we use +NthCo, we'll get out a representational coercion. That is: + + NthCo r 0 co :: forall a b. a ~R b + +Yikes! Clearly, this is terrible. The solution is simple: forbid +NthCo to be used on newtypes if the internal coercion is representational. + +This is not just some corner case discovered by a segfault somewhere; +it was discovered in the proof of soundness of roles and described +in the "Safe Coercions" paper (ICFP '14). + +Note [NthCo Cached Roles] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Why do we cache the role of NthCo in the NthCo constructor? +Because computing role(Nth i co) involves figuring out that + + co :: T tys1 ~ T tys2 + +using coercionKind, and finding (coercionRole co), and then looking +at the tyConRoles of T. Avoiding bad asymptotic behaviour here means +we have to compute the kind and role of a coercion simultaneously, +which makes the code complicated and inefficient. + +This only happens for NthCo. Caching the role solves the problem, and +allows coercionKind and coercionRole to be simple. + +See #11735 + +Note [InstCo roles] +~~~~~~~~~~~~~~~~~~~ +Here is (essentially) the typing rule for InstCo: + +g :: (forall a. t1) ~r (forall a. t2) +w :: s1 ~N s2 +------------------------------- InstCo +InstCo g w :: (t1 [a |-> s1]) ~r (t2 [a |-> s2]) + +Note that the Coercion w *must* be nominal. This is necessary +because the variable a might be used in a "nominal position" +(that is, a place where role inference would require a nominal +role) in t1 or t2. If we allowed w to be representational, we +could get bogus equalities. + +A more nuanced treatment might be able to relax this condition +somewhat, by checking if t1 and/or t2 use their bound variables +in nominal ways. If not, having w be representational is OK. + + +%************************************************************************ +%* * + UnivCoProvenance +%* * +%************************************************************************ + +A UnivCo is a coercion whose proof does not directly express its role +and kind (indeed for some UnivCos, like UnsafeCoerceProv, there /is/ +no proof). + +The different kinds of UnivCo are described by UnivCoProvenance. Really +each is entirely separate, but they all share the need to represent their +role and kind, which is done in the UnivCo constructor. + +-} + +-- | For simplicity, we have just one UnivCo that represents a coercion from +-- some type to some other type, with (in general) no restrictions on the +-- type. The UnivCoProvenance specifies more exactly what the coercion really +-- is and why a program should (or shouldn't!) trust the coercion. +-- It is reasonable to consider each constructor of 'UnivCoProvenance' +-- as a totally independent coercion form; their only commonality is +-- that they don't tell you what types they coercion between. (That info +-- is in the 'UnivCo' constructor of 'Coercion'. +data UnivCoProvenance + = UnsafeCoerceProv -- ^ From @unsafeCoerce#@. These are unsound. + + | PhantomProv KindCoercion -- ^ See Note [Phantom coercions]. Only in Phantom + -- roled coercions + + | ProofIrrelProv KindCoercion -- ^ From the fact that any two coercions are + -- considered equivalent. See Note [ProofIrrelProv]. + -- Can be used in Nominal or Representational coercions + + | PluginProv String -- ^ From a plugin, which asserts that this coercion + -- is sound. The string is for the use of the plugin. + + deriving Data.Data + +instance Outputable UnivCoProvenance where + ppr UnsafeCoerceProv = text "(unsafeCoerce#)" + ppr (PhantomProv _) = text "(phantom)" + ppr (ProofIrrelProv _) = text "(proof irrel.)" + ppr (PluginProv str) = parens (text "plugin" <+> brackets (text str)) + +-- | A coercion to be filled in by the type-checker. See Note [Coercion holes] +data CoercionHole + = CoercionHole { ch_co_var :: CoVar + -- See Note [CoercionHoles and coercion free variables] + + , ch_ref :: IORef (Maybe Coercion) + } + +coHoleCoVar :: CoercionHole -> CoVar +coHoleCoVar = ch_co_var + +setCoHoleCoVar :: CoercionHole -> CoVar -> CoercionHole +setCoHoleCoVar h cv = h { ch_co_var = cv } + +instance Data.Data CoercionHole where + -- don't traverse? + toConstr _ = abstractConstr "CoercionHole" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "CoercionHole" + +instance Outputable CoercionHole where + ppr (CoercionHole { ch_co_var = cv }) = braces (ppr cv) + + +{- Note [Phantom coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + data T a = T1 | T2 +Then we have + T s ~R T t +for any old s,t. The witness for this is (TyConAppCo T Rep co), +where (co :: s ~P t) is a phantom coercion built with PhantomProv. +The role of the UnivCo is always Phantom. The Coercion stored is the +(nominal) kind coercion between the types + kind(s) ~N kind (t) + +Note [Coercion holes] +~~~~~~~~~~~~~~~~~~~~~~~~ +During typechecking, constraint solving for type classes works by + - Generate an evidence Id, d7 :: Num a + - Wrap it in a Wanted constraint, [W] d7 :: Num a + - Use the evidence Id where the evidence is needed + - Solve the constraint later + - When solved, add an enclosing let-binding let d7 = .... in .... + which actually binds d7 to the (Num a) evidence + +For equality constraints we use a different strategy. See Note [The +equality types story] in TysPrim for background on equality constraints. + - For /boxed/ equality constraints, (t1 ~N t2) and (t1 ~R t2), it's just + like type classes above. (Indeed, boxed equality constraints *are* classes.) + - But for /unboxed/ equality constraints (t1 ~R# t2) and (t1 ~N# t2) + we use a different plan + +For unboxed equalities: + - Generate a CoercionHole, a mutable variable just like a unification + variable + - Wrap the CoercionHole in a Wanted constraint; see TcRnTypes.TcEvDest + - Use the CoercionHole in a Coercion, via HoleCo + - Solve the constraint later + - When solved, fill in the CoercionHole by side effect, instead of + doing the let-binding thing + +The main reason for all this is that there may be no good place to let-bind +the evidence for unboxed equalities: + + - We emit constraints for kind coercions, to be used to cast a + type's kind. These coercions then must be used in types. Because + they might appear in a top-level type, there is no place to bind + these (unlifted) coercions in the usual way. + + - A coercion for (forall a. t1) ~ (forall a. t2) will look like + forall a. (coercion for t1~t2) + But the coercion for (t1~t2) may mention 'a', and we don't have + let-bindings within coercions. We could add them, but coercion + holes are easier. + + - Moreover, nothing is lost from the lack of let-bindings. For + dicionaries want to achieve sharing to avoid recomoputing the + dictionary. But coercions are entirely erased, so there's little + benefit to sharing. Indeed, even if we had a let-binding, we + always inline types and coercions at every use site and drop the + binding. + +Other notes about HoleCo: + + * INVARIANT: CoercionHole and HoleCo are used only during type checking, + and should never appear in Core. Just like unification variables; a Type + can contain a TcTyVar, but only during type checking. If, one day, we + use type-level information to separate out forms that can appear during + type-checking vs forms that can appear in core proper, holes in Core will + be ruled out. + + * See Note [CoercionHoles and coercion free variables] + + * Coercion holes can be compared for equality like other coercions: + by looking at the types coerced. + + +Note [CoercionHoles and coercion free variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Why does a CoercionHole contain a CoVar, as well as reference to +fill in? Because we want to treat that CoVar as a free variable of +the coercion. See #14584, and Note [What prevents a +constraint from floating] in TcSimplify, item (4): + + forall k. [W] co1 :: t1 ~# t2 |> co2 + [W] co2 :: k ~# * + +Here co2 is a CoercionHole. But we /must/ know that it is free in +co1, because that's all that stops it floating outside the +implication. + + +Note [ProofIrrelProv] +~~~~~~~~~~~~~~~~~~~~~ +A ProofIrrelProv is a coercion between coercions. For example: + + data G a where + MkG :: G Bool + +In core, we get + + G :: * -> * + MkG :: forall (a :: *). (a ~ Bool) -> G a + +Now, consider 'MkG -- that is, MkG used in a type -- and suppose we want +a proof that ('MkG a1 co1) ~ ('MkG a2 co2). This will have to be + + TyConAppCo Nominal MkG [co3, co4] + where + co3 :: co1 ~ co2 + co4 :: a1 ~ a2 + +Note that + co1 :: a1 ~ Bool + co2 :: a2 ~ Bool + +Here, + co3 = UnivCo (ProofIrrelProv co5) Nominal (CoercionTy co1) (CoercionTy co2) + where + co5 :: (a1 ~ Bool) ~ (a2 ~ Bool) + co5 = TyConAppCo Nominal (~#) [<*>, <*>, co4, ] + + +%************************************************************************ +%* * + Free variables of types and coercions +%* * +%************************************************************************ +-} + +{- Note [Free variables of types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The family of functions tyCoVarsOfType, tyCoVarsOfTypes etc, returns +a VarSet that is closed over the types of its variables. More precisely, + if S = tyCoVarsOfType( t ) + and (a:k) is in S + then tyCoVarsOftype( k ) is a subset of S + +Example: The tyCoVars of this ((a:* -> k) Int) is {a, k}. + +We could /not/ close over the kinds of the variable occurrences, and +instead do so at call sites, but it seems that we always want to do +so, so it's easiest to do it here. + +It turns out that getting the free variables of types is performance critical, +so we profiled several versions, exploring different implementation strategies. + +1. Baseline version: uses FV naively. Essentially: + + tyCoVarsOfType ty = fvVarSet $ tyCoFVsOfType ty + + This is not nice, because FV introduces some overhead to implement + determinism, and throught its "interesting var" function, neither of which + we need here, so they are a complete waste. + +2. UnionVarSet version: instead of reusing the FV-based code, we simply used + VarSets directly, trying to avoid the overhead of FV. E.g.: + + -- FV version: + tyCoFVsOfType (AppTy fun arg) a b c = (tyCoFVsOfType fun `unionFV` tyCoFVsOfType arg) a b c + + -- UnionVarSet version: + tyCoVarsOfType (AppTy fun arg) = (tyCoVarsOfType fun `unionVarSet` tyCoVarsOfType arg) + + This looks deceptively similar, but while FV internally builds a list- and + set-generating function, the VarSet functions manipulate sets directly, and + the latter peforms a lot worse than the naive FV version. + +3. Accumulator-style VarSet version: this is what we use now. We do use VarSet + as our data structure, but delegate the actual work to a new + ty_co_vars_of_... family of functions, which use accumulator style and the + "in-scope set" filter found in the internals of FV, but without the + determinism overhead. + +See #14880. + +Note [Closing over free variable kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +tyCoVarsOfType and tyCoFVsOfType, while traversing a type, will also close over +free variable kinds. In previous GHC versions, this happened naively: whenever +we would encounter an occurrence of a free type variable, we would close over +its kind. This, however is wrong for two reasons (see #14880): + +1. Efficiency. If we have Proxy (a::k) -> Proxy (a::k) -> Proxy (a::k), then + we don't want to have to traverse k more than once. + +2. Correctness. Imagine we have forall k. b -> k, where b has + kind k, for some k bound in an outer scope. If we look at b's kind inside + the forall, we'll collect that k is free and then remove k from the set of + free variables. This is plain wrong. We must instead compute that b is free + and then conclude that b's kind is free. + +An obvious first approach is to move the closing-over-kinds from the +occurrences of a type variable to after finding the free vars - however, this +turns out to introduce performance regressions, and isn't even entirely +correct. + +In fact, it isn't even important *when* we close over kinds; what matters is +that we handle each type var exactly once, and that we do it in the right +context. + +So the next approach we tried was to use the "in-scope set" part of FV or the +equivalent argument in the accumulator-style `ty_co_vars_of_type` function, to +say "don't bother with variables we have already closed over". This should work +fine in theory, but the code is complicated and doesn't perform well. + +But there is a simpler way, which is implemented here. Consider the two points +above: + +1. Efficiency: we now have an accumulator, so the second time we encounter 'a', + we'll ignore it, certainly not looking at its kind - this is why + pre-checking set membership before inserting ends up not only being faster, + but also being correct. + +2. Correctness: we have an "in-scope set" (I think we should call it it a + "bound-var set"), specifying variables that are bound by a forall in the type + we are traversing; we simply ignore these variables, certainly not looking at + their kind. + +So now consider: + + forall k. b -> k + +where b :: k->Type is free; but of course, it's a different k! When looking at +b -> k we'll have k in the bound-var set. So we'll ignore the k. But suppose +this is our first encounter with b; we want the free vars of its kind. But we +want to behave as if we took the free vars of its kind at the end; that is, +with no bound vars in scope. + +So the solution is easy. The old code was this: + + ty_co_vars_of_type (TyVarTy v) is acc + | v `elemVarSet` is = acc + | v `elemVarSet` acc = acc + | otherwise = ty_co_vars_of_type (tyVarKind v) is (extendVarSet acc v) + +Now all we need to do is take the free vars of tyVarKind v *with an empty +bound-var set*, thus: + +ty_co_vars_of_type (TyVarTy v) is acc + | v `elemVarSet` is = acc + | v `elemVarSet` acc = acc + | otherwise = ty_co_vars_of_type (tyVarKind v) emptyVarSet (extendVarSet acc v) + ^^^^^^^^^^^ + +And that's it. + +-} + +tyCoVarsOfType :: Type -> TyCoVarSet +-- See Note [Free variables of types] +tyCoVarsOfType ty = ty_co_vars_of_type ty emptyVarSet emptyVarSet + +tyCoVarsOfTypes :: [Type] -> TyCoVarSet +tyCoVarsOfTypes tys = ty_co_vars_of_types tys emptyVarSet emptyVarSet + +ty_co_vars_of_type :: Type -> TyCoVarSet -> TyCoVarSet -> TyCoVarSet +ty_co_vars_of_type (TyVarTy v) is acc + | v `elemVarSet` is = acc + | v `elemVarSet` acc = acc + | otherwise = ty_co_vars_of_type (tyVarKind v) + emptyVarSet -- See Note [Closing over free variable kinds] + (extendVarSet acc v) + +ty_co_vars_of_type (TyConApp _ tys) is acc = ty_co_vars_of_types tys is acc +ty_co_vars_of_type (LitTy {}) _ acc = acc +ty_co_vars_of_type (AppTy fun arg) is acc = ty_co_vars_of_type fun is (ty_co_vars_of_type arg is acc) +ty_co_vars_of_type (FunTy _ arg res) is acc = ty_co_vars_of_type arg is (ty_co_vars_of_type res is acc) +ty_co_vars_of_type (ForAllTy (Bndr tv _) ty) is acc = ty_co_vars_of_type (varType tv) is $ + ty_co_vars_of_type ty (extendVarSet is tv) acc +ty_co_vars_of_type (CastTy ty co) is acc = ty_co_vars_of_type ty is (ty_co_vars_of_co co is acc) +ty_co_vars_of_type (CoercionTy co) is acc = ty_co_vars_of_co co is acc + +ty_co_vars_of_types :: [Type] -> TyCoVarSet -> TyCoVarSet -> TyCoVarSet +ty_co_vars_of_types [] _ acc = acc +ty_co_vars_of_types (ty:tys) is acc = ty_co_vars_of_type ty is (ty_co_vars_of_types tys is acc) + +tyCoVarsOfCo :: Coercion -> TyCoVarSet +-- See Note [Free variables of types] +tyCoVarsOfCo co = ty_co_vars_of_co co emptyVarSet emptyVarSet + +tyCoVarsOfCos :: [Coercion] -> TyCoVarSet +tyCoVarsOfCos cos = ty_co_vars_of_cos cos emptyVarSet emptyVarSet + + +ty_co_vars_of_co :: Coercion -> TyCoVarSet -> TyCoVarSet -> TyCoVarSet +ty_co_vars_of_co (Refl ty) is acc = ty_co_vars_of_type ty is acc +ty_co_vars_of_co (GRefl _ ty mco) is acc = ty_co_vars_of_type ty is $ + ty_co_vars_of_mco mco is acc +ty_co_vars_of_co (TyConAppCo _ _ cos) is acc = ty_co_vars_of_cos cos is acc +ty_co_vars_of_co (AppCo co arg) is acc = ty_co_vars_of_co co is $ + ty_co_vars_of_co arg is acc +ty_co_vars_of_co (ForAllCo tv kind_co co) is acc = ty_co_vars_of_co kind_co is $ + ty_co_vars_of_co co (extendVarSet is tv) acc +ty_co_vars_of_co (FunCo _ co1 co2) is acc = ty_co_vars_of_co co1 is $ + ty_co_vars_of_co co2 is acc +ty_co_vars_of_co (CoVarCo v) is acc = ty_co_vars_of_co_var v is acc +ty_co_vars_of_co (HoleCo h) is acc = ty_co_vars_of_co_var (coHoleCoVar h) is acc + -- See Note [CoercionHoles and coercion free variables] +ty_co_vars_of_co (AxiomInstCo _ _ cos) is acc = ty_co_vars_of_cos cos is acc +ty_co_vars_of_co (UnivCo p _ t1 t2) is acc = ty_co_vars_of_prov p is $ + ty_co_vars_of_type t1 is $ + ty_co_vars_of_type t2 is acc +ty_co_vars_of_co (SymCo co) is acc = ty_co_vars_of_co co is acc +ty_co_vars_of_co (TransCo co1 co2) is acc = ty_co_vars_of_co co1 is $ + ty_co_vars_of_co co2 is acc +ty_co_vars_of_co (NthCo _ _ co) is acc = ty_co_vars_of_co co is acc +ty_co_vars_of_co (LRCo _ co) is acc = ty_co_vars_of_co co is acc +ty_co_vars_of_co (InstCo co arg) is acc = ty_co_vars_of_co co is $ + ty_co_vars_of_co arg is acc +ty_co_vars_of_co (KindCo co) is acc = ty_co_vars_of_co co is acc +ty_co_vars_of_co (SubCo co) is acc = ty_co_vars_of_co co is acc +ty_co_vars_of_co (AxiomRuleCo _ cs) is acc = ty_co_vars_of_cos cs is acc + +ty_co_vars_of_mco :: MCoercion -> TyCoVarSet -> TyCoVarSet -> TyCoVarSet +ty_co_vars_of_mco MRefl _is acc = acc +ty_co_vars_of_mco (MCo co) is acc = ty_co_vars_of_co co is acc + +ty_co_vars_of_co_var :: CoVar -> TyCoVarSet -> TyCoVarSet -> TyCoVarSet +ty_co_vars_of_co_var v is acc + | v `elemVarSet` is = acc + | v `elemVarSet` acc = acc + | otherwise = ty_co_vars_of_type (varType v) + emptyVarSet -- See Note [Closing over free variable kinds] + (extendVarSet acc v) + +ty_co_vars_of_cos :: [Coercion] -> TyCoVarSet -> TyCoVarSet -> TyCoVarSet +ty_co_vars_of_cos [] _ acc = acc +ty_co_vars_of_cos (co:cos) is acc = ty_co_vars_of_co co is (ty_co_vars_of_cos cos is acc) + +tyCoVarsOfProv :: UnivCoProvenance -> TyCoVarSet +tyCoVarsOfProv prov = ty_co_vars_of_prov prov emptyVarSet emptyVarSet + +ty_co_vars_of_prov :: UnivCoProvenance -> TyCoVarSet -> TyCoVarSet -> TyCoVarSet +ty_co_vars_of_prov (PhantomProv co) is acc = ty_co_vars_of_co co is acc +ty_co_vars_of_prov (ProofIrrelProv co) is acc = ty_co_vars_of_co co is acc +ty_co_vars_of_prov UnsafeCoerceProv _ acc = acc +ty_co_vars_of_prov (PluginProv _) _ acc = acc + +-- | Generates an in-scope set from the free variables in a list of types +-- and a list of coercions +mkTyCoInScopeSet :: [Type] -> [Coercion] -> InScopeSet +mkTyCoInScopeSet tys cos + = mkInScopeSet (ty_co_vars_of_types tys emptyVarSet $ + ty_co_vars_of_cos cos emptyVarSet emptyVarSet) + +-- | `tyCoFVsOfType` that returns free variables of a type in a deterministic +-- set. For explanation of why using `VarSet` is not deterministic see +-- Note [Deterministic FV] in FV. +tyCoVarsOfTypeDSet :: Type -> DTyCoVarSet +-- See Note [Free variables of types] +tyCoVarsOfTypeDSet ty = fvDVarSet $ tyCoFVsOfType ty + +-- | `tyCoFVsOfType` that returns free variables of a type in deterministic +-- order. For explanation of why using `VarSet` is not deterministic see +-- Note [Deterministic FV] in FV. +tyCoVarsOfTypeList :: Type -> [TyCoVar] +-- See Note [Free variables of types] +tyCoVarsOfTypeList ty = fvVarList $ tyCoFVsOfType ty + +-- | Returns free variables of types, including kind variables as +-- a non-deterministic set. For type synonyms it does /not/ expand the +-- synonym. +tyCoVarsOfTypesSet :: TyVarEnv Type -> TyCoVarSet +-- See Note [Free variables of types] +tyCoVarsOfTypesSet tys = tyCoVarsOfTypes $ nonDetEltsUFM tys + -- It's OK to use nonDetEltsUFM here because we immediately forget the + -- ordering by returning a set + +-- | Returns free variables of types, including kind variables as +-- a deterministic set. For type synonyms it does /not/ expand the +-- synonym. +tyCoVarsOfTypesDSet :: [Type] -> DTyCoVarSet +-- See Note [Free variables of types] +tyCoVarsOfTypesDSet tys = fvDVarSet $ tyCoFVsOfTypes tys + +-- | Returns free variables of types, including kind variables as +-- a deterministically ordered list. For type synonyms it does /not/ expand the +-- synonym. +tyCoVarsOfTypesList :: [Type] -> [TyCoVar] +-- See Note [Free variables of types] +tyCoVarsOfTypesList tys = fvVarList $ tyCoFVsOfTypes tys + +-- | The worker for `tyCoFVsOfType` and `tyCoFVsOfTypeList`. +-- The previous implementation used `unionVarSet` which is O(n+m) and can +-- make the function quadratic. +-- It's exported, so that it can be composed with +-- other functions that compute free variables. +-- See Note [FV naming conventions] in FV. +-- +-- Eta-expanded because that makes it run faster (apparently) +-- See Note [FV eta expansion] in FV for explanation. +tyCoFVsOfType :: Type -> FV +-- See Note [Free variables of types] +tyCoFVsOfType (TyVarTy v) f bound_vars (acc_list, acc_set) + | not (f v) = (acc_list, acc_set) + | v `elemVarSet` bound_vars = (acc_list, acc_set) + | v `elemVarSet` acc_set = (acc_list, acc_set) + | otherwise = tyCoFVsOfType (tyVarKind v) f + emptyVarSet -- See Note [Closing over free variable kinds] + (v:acc_list, extendVarSet acc_set v) +tyCoFVsOfType (TyConApp _ tys) f bound_vars acc = tyCoFVsOfTypes tys f bound_vars acc +tyCoFVsOfType (LitTy {}) f bound_vars acc = emptyFV f bound_vars acc +tyCoFVsOfType (AppTy fun arg) f bound_vars acc = (tyCoFVsOfType fun `unionFV` tyCoFVsOfType arg) f bound_vars acc +tyCoFVsOfType (FunTy _ arg res) f bound_vars acc = (tyCoFVsOfType arg `unionFV` tyCoFVsOfType res) f bound_vars acc +tyCoFVsOfType (ForAllTy bndr ty) f bound_vars acc = tyCoFVsBndr bndr (tyCoFVsOfType ty) f bound_vars acc +tyCoFVsOfType (CastTy ty co) f bound_vars acc = (tyCoFVsOfType ty `unionFV` tyCoFVsOfCo co) f bound_vars acc +tyCoFVsOfType (CoercionTy co) f bound_vars acc = tyCoFVsOfCo co f bound_vars acc + +tyCoFVsBndr :: TyCoVarBinder -> FV -> FV +-- Free vars of (forall b. ) +tyCoFVsBndr (Bndr tv _) fvs = tyCoFVsVarBndr tv fvs + +tyCoFVsVarBndrs :: [Var] -> FV -> FV +tyCoFVsVarBndrs vars fvs = foldr tyCoFVsVarBndr fvs vars + +tyCoFVsVarBndr :: Var -> FV -> FV +tyCoFVsVarBndr var fvs + = tyCoFVsOfType (varType var) -- Free vars of its type/kind + `unionFV` delFV var fvs -- Delete it from the thing-inside + +tyCoFVsOfTypes :: [Type] -> FV +-- See Note [Free variables of types] +tyCoFVsOfTypes (ty:tys) fv_cand in_scope acc = (tyCoFVsOfType ty `unionFV` tyCoFVsOfTypes tys) fv_cand in_scope acc +tyCoFVsOfTypes [] fv_cand in_scope acc = emptyFV fv_cand in_scope acc + +-- | Get a deterministic set of the vars free in a coercion +tyCoVarsOfCoDSet :: Coercion -> DTyCoVarSet +-- See Note [Free variables of types] +tyCoVarsOfCoDSet co = fvDVarSet $ tyCoFVsOfCo co + +tyCoVarsOfCoList :: Coercion -> [TyCoVar] +-- See Note [Free variables of types] +tyCoVarsOfCoList co = fvVarList $ tyCoFVsOfCo co + +tyCoFVsOfMCo :: MCoercion -> FV +tyCoFVsOfMCo MRefl = emptyFV +tyCoFVsOfMCo (MCo co) = tyCoFVsOfCo co + +tyCoVarsOfCosSet :: CoVarEnv Coercion -> TyCoVarSet +tyCoVarsOfCosSet cos = tyCoVarsOfCos $ nonDetEltsUFM cos + -- It's OK to use nonDetEltsUFM here because we immediately forget the + -- ordering by returning a set + +tyCoFVsOfCo :: Coercion -> FV +-- Extracts type and coercion variables from a coercion +-- See Note [Free variables of types] +tyCoFVsOfCo (Refl ty) fv_cand in_scope acc + = tyCoFVsOfType ty fv_cand in_scope acc +tyCoFVsOfCo (GRefl _ ty mco) fv_cand in_scope acc + = (tyCoFVsOfType ty `unionFV` tyCoFVsOfMCo mco) fv_cand in_scope acc +tyCoFVsOfCo (TyConAppCo _ _ cos) fv_cand in_scope acc = tyCoFVsOfCos cos fv_cand in_scope acc +tyCoFVsOfCo (AppCo co arg) fv_cand in_scope acc + = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCo arg) fv_cand in_scope acc +tyCoFVsOfCo (ForAllCo tv kind_co co) fv_cand in_scope acc + = (tyCoFVsVarBndr tv (tyCoFVsOfCo co) `unionFV` tyCoFVsOfCo kind_co) fv_cand in_scope acc +tyCoFVsOfCo (FunCo _ co1 co2) fv_cand in_scope acc + = (tyCoFVsOfCo co1 `unionFV` tyCoFVsOfCo co2) fv_cand in_scope acc +tyCoFVsOfCo (CoVarCo v) fv_cand in_scope acc + = tyCoFVsOfCoVar v fv_cand in_scope acc +tyCoFVsOfCo (HoleCo h) fv_cand in_scope acc + = tyCoFVsOfCoVar (coHoleCoVar h) fv_cand in_scope acc + -- See Note [CoercionHoles and coercion free variables] +tyCoFVsOfCo (AxiomInstCo _ _ cos) fv_cand in_scope acc = tyCoFVsOfCos cos fv_cand in_scope acc +tyCoFVsOfCo (UnivCo p _ t1 t2) fv_cand in_scope acc + = (tyCoFVsOfProv p `unionFV` tyCoFVsOfType t1 + `unionFV` tyCoFVsOfType t2) fv_cand in_scope acc +tyCoFVsOfCo (SymCo co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc +tyCoFVsOfCo (TransCo co1 co2) fv_cand in_scope acc = (tyCoFVsOfCo co1 `unionFV` tyCoFVsOfCo co2) fv_cand in_scope acc +tyCoFVsOfCo (NthCo _ _ co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc +tyCoFVsOfCo (LRCo _ co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc +tyCoFVsOfCo (InstCo co arg) fv_cand in_scope acc = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCo arg) fv_cand in_scope acc +tyCoFVsOfCo (KindCo co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc +tyCoFVsOfCo (SubCo co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc +tyCoFVsOfCo (AxiomRuleCo _ cs) fv_cand in_scope acc = tyCoFVsOfCos cs fv_cand in_scope acc + +tyCoFVsOfCoVar :: CoVar -> FV +tyCoFVsOfCoVar v fv_cand in_scope acc + = (unitFV v `unionFV` tyCoFVsOfType (varType v)) fv_cand in_scope acc + +tyCoFVsOfProv :: UnivCoProvenance -> FV +tyCoFVsOfProv UnsafeCoerceProv fv_cand in_scope acc = emptyFV fv_cand in_scope acc +tyCoFVsOfProv (PhantomProv co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc +tyCoFVsOfProv (ProofIrrelProv co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc +tyCoFVsOfProv (PluginProv _) fv_cand in_scope acc = emptyFV fv_cand in_scope acc + +tyCoFVsOfCos :: [Coercion] -> FV +tyCoFVsOfCos [] fv_cand in_scope acc = emptyFV fv_cand in_scope acc +tyCoFVsOfCos (co:cos) fv_cand in_scope acc = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCos cos) fv_cand in_scope acc + + +------------- Extracting the CoVars of a type or coercion ----------- + +{- + +Note [CoVarsOfX and the InterestingVarFun] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The coVarsOfType, coVarsOfTypes, coVarsOfCo, and coVarsOfCos functions are +implemented in terms of the respective FV equivalents (tyCoFVsOf...), rather +than the VarSet-based flavors (tyCoVarsOf...), despite the performance +considerations outlined in Note [Free variables of types]. + +This is because FV includes the InterestingVarFun, which is useful here, +because we can cleverly use it to restrict our calculations to CoVars - this +is what getCoVarSet achieves. + +See #14880. + +-} + +getCoVarSet :: FV -> CoVarSet +getCoVarSet fv = snd (fv isCoVar emptyVarSet ([], emptyVarSet)) + +coVarsOfType :: Type -> CoVarSet +coVarsOfType ty = getCoVarSet (tyCoFVsOfType ty) + +coVarsOfTypes :: [Type] -> TyCoVarSet +coVarsOfTypes tys = getCoVarSet (tyCoFVsOfTypes tys) + +coVarsOfCo :: Coercion -> CoVarSet +coVarsOfCo co = getCoVarSet (tyCoFVsOfCo co) + +coVarsOfCos :: [Coercion] -> CoVarSet +coVarsOfCos cos = getCoVarSet (tyCoFVsOfCos cos) + +----- Whether a covar is /Almost Devoid/ in a type or coercion ---- + +-- | Given a covar and a coercion, returns True if covar is almost devoid in +-- the coercion. That is, covar can only appear in Refl and GRefl. +-- See last wrinkle in Note [Unused coercion variable in ForAllCo] in Coercion +almostDevoidCoVarOfCo :: CoVar -> Coercion -> Bool +almostDevoidCoVarOfCo cv co = + almost_devoid_co_var_of_co co cv + +almost_devoid_co_var_of_co :: Coercion -> CoVar -> Bool +almost_devoid_co_var_of_co (Refl {}) _ = True -- covar is allowed in Refl and +almost_devoid_co_var_of_co (GRefl {}) _ = True -- GRefl, so we don't look into + -- the coercions +almost_devoid_co_var_of_co (TyConAppCo _ _ cos) cv + = almost_devoid_co_var_of_cos cos cv +almost_devoid_co_var_of_co (AppCo co arg) cv + = almost_devoid_co_var_of_co co cv + && almost_devoid_co_var_of_co arg cv +almost_devoid_co_var_of_co (ForAllCo v kind_co co) cv + = almost_devoid_co_var_of_co kind_co cv + && (v == cv || almost_devoid_co_var_of_co co cv) +almost_devoid_co_var_of_co (FunCo _ co1 co2) cv + = almost_devoid_co_var_of_co co1 cv + && almost_devoid_co_var_of_co co2 cv +almost_devoid_co_var_of_co (CoVarCo v) cv = v /= cv +almost_devoid_co_var_of_co (HoleCo h) cv = (coHoleCoVar h) /= cv +almost_devoid_co_var_of_co (AxiomInstCo _ _ cos) cv + = almost_devoid_co_var_of_cos cos cv +almost_devoid_co_var_of_co (UnivCo p _ t1 t2) cv + = almost_devoid_co_var_of_prov p cv + && almost_devoid_co_var_of_type t1 cv + && almost_devoid_co_var_of_type t2 cv +almost_devoid_co_var_of_co (SymCo co) cv + = almost_devoid_co_var_of_co co cv +almost_devoid_co_var_of_co (TransCo co1 co2) cv + = almost_devoid_co_var_of_co co1 cv + && almost_devoid_co_var_of_co co2 cv +almost_devoid_co_var_of_co (NthCo _ _ co) cv + = almost_devoid_co_var_of_co co cv +almost_devoid_co_var_of_co (LRCo _ co) cv + = almost_devoid_co_var_of_co co cv +almost_devoid_co_var_of_co (InstCo co arg) cv + = almost_devoid_co_var_of_co co cv + && almost_devoid_co_var_of_co arg cv +almost_devoid_co_var_of_co (KindCo co) cv + = almost_devoid_co_var_of_co co cv +almost_devoid_co_var_of_co (SubCo co) cv + = almost_devoid_co_var_of_co co cv +almost_devoid_co_var_of_co (AxiomRuleCo _ cs) cv + = almost_devoid_co_var_of_cos cs cv + +almost_devoid_co_var_of_cos :: [Coercion] -> CoVar -> Bool +almost_devoid_co_var_of_cos [] _ = True +almost_devoid_co_var_of_cos (co:cos) cv + = almost_devoid_co_var_of_co co cv + && almost_devoid_co_var_of_cos cos cv + +almost_devoid_co_var_of_prov :: UnivCoProvenance -> CoVar -> Bool +almost_devoid_co_var_of_prov (PhantomProv co) cv + = almost_devoid_co_var_of_co co cv +almost_devoid_co_var_of_prov (ProofIrrelProv co) cv + = almost_devoid_co_var_of_co co cv +almost_devoid_co_var_of_prov UnsafeCoerceProv _ = True +almost_devoid_co_var_of_prov (PluginProv _) _ = True + +almost_devoid_co_var_of_type :: Type -> CoVar -> Bool +almost_devoid_co_var_of_type (TyVarTy _) _ = True +almost_devoid_co_var_of_type (TyConApp _ tys) cv + = almost_devoid_co_var_of_types tys cv +almost_devoid_co_var_of_type (LitTy {}) _ = True +almost_devoid_co_var_of_type (AppTy fun arg) cv + = almost_devoid_co_var_of_type fun cv + && almost_devoid_co_var_of_type arg cv +almost_devoid_co_var_of_type (FunTy _ arg res) cv + = almost_devoid_co_var_of_type arg cv + && almost_devoid_co_var_of_type res cv +almost_devoid_co_var_of_type (ForAllTy (Bndr v _) ty) cv + = almost_devoid_co_var_of_type (varType v) cv + && (v == cv || almost_devoid_co_var_of_type ty cv) +almost_devoid_co_var_of_type (CastTy ty co) cv + = almost_devoid_co_var_of_type ty cv + && almost_devoid_co_var_of_co co cv +almost_devoid_co_var_of_type (CoercionTy co) cv + = almost_devoid_co_var_of_co co cv + +almost_devoid_co_var_of_types :: [Type] -> CoVar -> Bool +almost_devoid_co_var_of_types [] _ = True +almost_devoid_co_var_of_types (ty:tys) cv + = almost_devoid_co_var_of_type ty cv + && almost_devoid_co_var_of_types tys cv + +------------- Injective free vars ----------------- + +-- | Returns the free variables of a 'Type' that are in injective positions. +-- For example, if @F@ is a non-injective type family, then: +-- +-- @ +-- injectiveTyVarsOf( Either c (Maybe (a, F b c)) ) = {a,c} +-- @ +-- +-- If @'injectiveVarsOfType' ty = itvs@, then knowing @ty@ fixes @itvs@. +-- More formally, if +-- @a@ is in @'injectiveVarsOfType' ty@ +-- and @S1(ty) ~ S2(ty)@, +-- then @S1(a) ~ S2(a)@, +-- where @S1@ and @S2@ are arbitrary substitutions. +-- +-- See @Note [When does a tycon application need an explicit kind signature?]@. +injectiveVarsOfType :: Type -> FV +injectiveVarsOfType = go + where + go ty | Just ty' <- coreView ty + = go ty' + go (TyVarTy v) = unitFV v `unionFV` go (tyVarKind v) + go (AppTy f a) = go f `unionFV` go a + go (FunTy _ ty1 ty2) = go ty1 `unionFV` go ty2 + go (TyConApp tc tys) = + case tyConInjectivityInfo tc of + NotInjective -> emptyFV + Injective inj -> mapUnionFV go $ + filterByList (inj ++ repeat True) tys + -- Oversaturated arguments to a tycon are + -- always injective, hence the repeat True + go (ForAllTy tvb ty) = tyCoFVsBndr tvb $ go ty + go LitTy{} = emptyFV + go (CastTy ty _) = go ty + go CoercionTy{} = emptyFV + +-- | Does a 'TyCon' (that is applied to some number of arguments) need to be +-- ascribed with an explicit kind signature to resolve ambiguity if rendered as +-- a source-syntax type? +-- (See @Note [When does a tycon application need an explicit kind signature?]@ +-- for a full explanation of what this function checks for.) + +-- Morally, this function ought to belong in TyCon.hs, not TyCoRep.hs, but +-- accomplishing this requires a fair deal of futzing aruond with .hs-boot +-- files. +tyConAppNeedsKindSig + :: Bool -- ^ Should specified binders count towards injective positions in + -- the kind of the TyCon? (If you're using visible kind + -- applications, then you want True here. + -> TyCon + -> Int -- ^ The number of args the 'TyCon' is applied to. + -> Bool -- ^ Does @T t_1 ... t_n@ need a kind signature? (Where @n@ is the + -- number of arguments) +tyConAppNeedsKindSig spec_inj_pos tc n_args + | LT <- listLengthCmp tc_binders n_args + = False + | otherwise + = let (dropped_binders, remaining_binders) + = splitAt n_args tc_binders + result_kind = mkTyConKind remaining_binders tc_res_kind + result_vars = tyCoVarsOfType result_kind + dropped_vars = fvVarSet $ + mapUnionFV injective_vars_of_binder dropped_binders + + in not (subVarSet result_vars dropped_vars) + where + tc_binders = tyConBinders tc + tc_res_kind = tyConResKind tc + + -- Returns the variables that would be fixed by knowing a TyConBinder. See + -- Note [When does a tycon application need an explicit kind signature?] + -- for a more detailed explanation of what this function does. + injective_vars_of_binder :: TyConBinder -> FV + injective_vars_of_binder (Bndr tv vis) = + case vis of + AnonTCB VisArg -> injectiveVarsOfType (varType tv) + NamedTCB argf | source_of_injectivity argf + -> unitFV tv `unionFV` injectiveVarsOfType (varType tv) + _ -> emptyFV + + source_of_injectivity Required = True + source_of_injectivity Specified = spec_inj_pos + source_of_injectivity Inferred = False + +{- +Note [When does a tycon application need an explicit kind signature?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are a couple of places in GHC where we convert Core Types into forms that +more closely resemble user-written syntax. These include: + +1. Template Haskell Type reification (see, for instance, TcSplice.reify_tc_app) +2. Converting Types to LHsTypes (in HsUtils.typeToLHsType, or in Haddock) + +This conversion presents a challenge: how do we ensure that the resulting type +has enough kind information so as not to be ambiguous? To better motivate this +question, consider the following Core type: + + -- Foo :: Type -> Type + type Foo = Proxy Type + +There is nothing ambiguous about the RHS of Foo in Core. But if we were to, +say, reify it into a TH Type, then it's tempting to just drop the invisible +Type argument and simply return `Proxy`. But now we've lost crucial kind +information: we don't know if we're dealing with `Proxy Type` or `Proxy Bool` +or `Proxy Int` or something else! We've inadvertently introduced ambiguity. + +Unlike in other situations in GHC, we can't just turn on +-fprint-explicit-kinds, as we need to produce something which has the same +structure as a source-syntax type. Moreover, we can't rely on visible kind +application, since the first kind argument to Proxy is inferred, not specified. +Our solution is to annotate certain tycons with their kinds whenever they +appear in applied form in order to resolve the ambiguity. For instance, we +would reify the RHS of Foo like so: + + type Foo = (Proxy :: Type -> Type) + +We need to devise an algorithm that determines precisely which tycons need +these explicit kind signatures. We certainly don't want to annotate _every_ +tycon with a kind signature, or else we might end up with horribly bloated +types like the following: + + (Either :: Type -> Type -> Type) (Int :: Type) (Char :: Type) + +We only want to annotate tycons that absolutely require kind signatures in +order to resolve some sort of ambiguity, and nothing more. + +Suppose we have a tycon application (T ty_1 ... ty_n). Why might this type +require a kind signature? It might require it when we need to fill in any of +T's omitted arguments. By "omitted argument", we mean one that is dropped when +reifying ty_1 ... ty_n. Sometimes, the omitted arguments are inferred and +specified arguments (e.g., TH reification in TcSplice), and sometimes the +omitted arguments are only the inferred ones (e.g., in HsUtils.typeToLHsType, +which reifies specified arguments through visible kind application). +Regardless, the key idea is that _some_ arguments are going to be omitted after +reification, and the only mechanism we have at our disposal for filling them in +is through explicit kind signatures. + +What do we mean by "fill in"? Let's consider this small example: + + T :: forall {k}. Type -> (k -> Type) -> k + +Moreover, we have this application of T: + + T @{j} Int aty + +When we reify this type, we omit the inferred argument @{j}. Is it fixed by the +other (non-inferred) arguments? Yes! If we know the kind of (aty :: blah), then +we'll generate an equality constraint (kappa -> Type) and, assuming we can +solve it, that will fix `kappa`. (Here, `kappa` is the unification variable +that we instantiate `k` with.) + +Therefore, for any application of a tycon T to some arguments, the Question We +Must Answer is: + +* Given the first n arguments of T, do the kinds of the non-omitted arguments + fill in the omitted arguments? + +(This is still a bit hand-wavey, but we'll refine this question incrementally +as we explain more of the machinery underlying this process.) + +Answering this question is precisely the role that the `injectiveVarsOfType` +and `injective_vars_of_binder` functions exist to serve. If an omitted argument +`a` appears in the set returned by `injectiveVarsOfType ty`, then knowing +`ty` determines (i.e., fills in) `a`. (More on `injective_vars_of_binder` in a +bit.) + +More formally, if +`a` is in `injectiveVarsOfType ty` +and S1(ty) ~ S2(ty), +then S1(a) ~ S2(a), +where S1 and S2 are arbitrary substitutions. + +For example, is `F` is a non-injective type family, then + + injectiveVarsOfType(Either c (Maybe (a, F b c))) = {a, c} + +Now that we know what this function does, here is a second attempt at the +Question We Must Answer: + +* Given the first n arguments of T (ty_1 ... ty_n), consider the binders + of T that are instantiated by non-omitted arguments. Do the injective + variables of these binders fill in the remainder of T's kind? + +Alright, we're getting closer. Next, we need to clarify what the injective +variables of a tycon binder are. This the role that the +`injective_vars_of_binder` function serves. Here is what this function does for +each form of tycon binder: + +* Anonymous binders are injective positions. For example, in the promoted data + constructor '(:): + + '(:) :: forall a. a -> [a] -> [a] + + The second and third tyvar binders (of kinds `a` and `[a]`) are both + anonymous, so if we had '(:) 'True '[], then the kinds of 'True and + '[] would contribute to the kind of '(:) 'True '[]. Therefore, + injective_vars_of_binder(_ :: a) = injectiveVarsOfType(a) = {a}. + (Similarly, injective_vars_of_binder(_ :: [a]) = {a}.) +* Named binders: + - Inferred binders are never injective positions. For example, in this data + type: + + data Proxy a + Proxy :: forall {k}. k -> Type + + If we had Proxy 'True, then the kind of 'True would not contribute to the + kind of Proxy 'True. Therefore, + injective_vars_of_binder(forall {k}. ...) = {}. + - Required binders are injective positions. For example, in this data type: + + data Wurble k (a :: k) :: k + Wurble :: forall k -> k -> k + + The first tyvar binder (of kind `forall k`) has required visibility, so if + we had Wurble (Maybe a) Nothing, then the kind of Maybe a would + contribute to the kind of Wurble (Maybe a) Nothing. Hence, + injective_vars_of_binder(forall a -> ...) = {a}. + - Specified binders /might/ be injective positions, depending on how you + approach things. Continuing the '(:) example: + + '(:) :: forall a. a -> [a] -> [a] + + Normally, the (forall a. ...) tyvar binder wouldn't contribute to the kind + of '(:) 'True '[], since it's not explicitly instantiated by the user. But + if visible kind application is enabled, then this is possible, since the + user can write '(:) @Bool 'True '[]. (In that case, + injective_vars_of_binder(forall a. ...) = {a}.) + + There are some situations where using visible kind application is appropriate + (e.g., HsUtils.typeToLHsType) and others where it is not (e.g., TH + reification), so the `injective_vars_of_binder` function is parametrized by + a Bool which decides if specified binders should be counted towards + injective positions or not. + +Now that we've defined injective_vars_of_binder, we can refine the Question We +Must Answer once more: + +* Given the first n arguments of T (ty_1 ... ty_n), consider the binders + of T that are instantiated by non-omitted arguments. For each such binder + b_i, take the union of all injective_vars_of_binder(b_i). Is this set a + superset of the free variables of the remainder of T's kind? + +If the answer to this question is "no", then (T ty_1 ... ty_n) needs an +explicit kind signature, since T's kind has kind variables leftover that +aren't fixed by the non-omitted arguments. + +One last sticking point: what does "the remainder of T's kind" mean? You might +be tempted to think that it corresponds to all of the arguments in the kind of +T that would normally be instantiated by omitted arguments. But this isn't +quite right, strictly speaking. Consider the following (silly) example: + + S :: forall {k}. Type -> Type + +And suppose we have this application of S: + + S Int Bool + +The Int argument would be omitted, and +injective_vars_of_binder(_ :: Type) = {}. This is not a superset of {k}, which +might suggest that (S Bool) needs an explicit kind signature. But +(S Bool :: Type) doesn't actually fix `k`! This is because the kind signature +only affects the /result/ of the application, not all of the individual +arguments. So adding a kind signature here won't make a difference. Therefore, +the fourth (and final) iteration of the Question We Must Answer is: + +* Given the first n arguments of T (ty_1 ... ty_n), consider the binders + of T that are instantiated by non-omitted arguments. For each such binder + b_i, take the union of all injective_vars_of_binder(b_i). Is this set a + superset of the free variables of the kind of (T ty_1 ... ty_n)? + +Phew, that was a lot of work! + +How can be sure that this is correct? That is, how can we be sure that in the +event that we leave off a kind annotation, that one could infer the kind of the +tycon application from its arguments? It's essentially a proof by induction: if +we can infer the kinds of every subtree of a type, then the whole tycon +application will have an inferrable kind--unless, of course, the remainder of +the tycon application's kind has uninstantiated kind variables. + +What happens if T is oversaturated? That is, if T's kind has fewer than n +arguments, in the case that the concrete application instantiates a result +kind variable with an arrow kind? If we run out of arguments, we do not attach +a kind annotation. This should be a rare case, indeed. Here is an example: + + data T1 :: k1 -> k2 -> * + data T2 :: k1 -> k2 -> * + + type family G (a :: k) :: k + type instance G T1 = T2 + + type instance F Char = (G T1 Bool :: (* -> *) -> *) -- F from above + +Here G's kind is (forall k. k -> k), and the desugared RHS of that last +instance of F is (G (* -> (* -> *) -> *) (T1 * (* -> *)) Bool). According to +the algorithm above, there are 3 arguments to G so we should peel off 3 +arguments in G's kind. But G's kind has only two arguments. This is the +rare special case, and we choose not to annotate the application of G with +a kind signature. After all, we needn't do this, since that instance would +be reified as: + + type instance F Char = G (T1 :: * -> (* -> *) -> *) Bool + +So the kind of G isn't ambiguous anymore due to the explicit kind annotation +on its argument. See #8953 and test th/T8953. +-} + +------------- No free vars ----------------- + +-- | Returns True if this type has no free variables. Should be the same as +-- isEmptyVarSet . tyCoVarsOfType, but faster in the non-forall case. +noFreeVarsOfType :: Type -> Bool +noFreeVarsOfType (TyVarTy _) = False +noFreeVarsOfType (AppTy t1 t2) = noFreeVarsOfType t1 && noFreeVarsOfType t2 +noFreeVarsOfType (TyConApp _ tys) = all noFreeVarsOfType tys +noFreeVarsOfType ty@(ForAllTy {}) = isEmptyVarSet (tyCoVarsOfType ty) +noFreeVarsOfType (FunTy _ t1 t2) = noFreeVarsOfType t1 && noFreeVarsOfType t2 +noFreeVarsOfType (LitTy _) = True +noFreeVarsOfType (CastTy ty co) = noFreeVarsOfType ty && noFreeVarsOfCo co +noFreeVarsOfType (CoercionTy co) = noFreeVarsOfCo co + +noFreeVarsOfMCo :: MCoercion -> Bool +noFreeVarsOfMCo MRefl = True +noFreeVarsOfMCo (MCo co) = noFreeVarsOfCo co + +noFreeVarsOfTypes :: [Type] -> Bool +noFreeVarsOfTypes = all noFreeVarsOfType + +-- | Returns True if this coercion has no free variables. Should be the same as +-- isEmptyVarSet . tyCoVarsOfCo, but faster in the non-forall case. +noFreeVarsOfCo :: Coercion -> Bool +noFreeVarsOfCo (Refl ty) = noFreeVarsOfType ty +noFreeVarsOfCo (GRefl _ ty co) = noFreeVarsOfType ty && noFreeVarsOfMCo co +noFreeVarsOfCo (TyConAppCo _ _ args) = all noFreeVarsOfCo args +noFreeVarsOfCo (AppCo c1 c2) = noFreeVarsOfCo c1 && noFreeVarsOfCo c2 +noFreeVarsOfCo co@(ForAllCo {}) = isEmptyVarSet (tyCoVarsOfCo co) +noFreeVarsOfCo (FunCo _ c1 c2) = noFreeVarsOfCo c1 && noFreeVarsOfCo c2 +noFreeVarsOfCo (CoVarCo _) = False +noFreeVarsOfCo (HoleCo {}) = True -- I'm unsure; probably never happens +noFreeVarsOfCo (AxiomInstCo _ _ args) = all noFreeVarsOfCo args +noFreeVarsOfCo (UnivCo p _ t1 t2) = noFreeVarsOfProv p && + noFreeVarsOfType t1 && + noFreeVarsOfType t2 +noFreeVarsOfCo (SymCo co) = noFreeVarsOfCo co +noFreeVarsOfCo (TransCo co1 co2) = noFreeVarsOfCo co1 && noFreeVarsOfCo co2 +noFreeVarsOfCo (NthCo _ _ co) = noFreeVarsOfCo co +noFreeVarsOfCo (LRCo _ co) = noFreeVarsOfCo co +noFreeVarsOfCo (InstCo co1 co2) = noFreeVarsOfCo co1 && noFreeVarsOfCo co2 +noFreeVarsOfCo (KindCo co) = noFreeVarsOfCo co +noFreeVarsOfCo (SubCo co) = noFreeVarsOfCo co +noFreeVarsOfCo (AxiomRuleCo _ cs) = all noFreeVarsOfCo cs + +-- | Returns True if this UnivCoProv has no free variables. Should be the same as +-- isEmptyVarSet . tyCoVarsOfProv, but faster in the non-forall case. +noFreeVarsOfProv :: UnivCoProvenance -> Bool +noFreeVarsOfProv UnsafeCoerceProv = True +noFreeVarsOfProv (PhantomProv co) = noFreeVarsOfCo co +noFreeVarsOfProv (ProofIrrelProv co) = noFreeVarsOfCo co +noFreeVarsOfProv (PluginProv {}) = True + +{- +%************************************************************************ +%* * + Substitutions + Data type defined here to avoid unnecessary mutual recursion +%* * +%************************************************************************ +-} + +-- | Type & coercion substitution +-- +-- #tcvsubst_invariant# +-- The following invariants must hold of a 'TCvSubst': +-- +-- 1. The in-scope set is needed /only/ to +-- guide the generation of fresh uniques +-- +-- 2. In particular, the /kind/ of the type variables in +-- the in-scope set is not relevant +-- +-- 3. The substitution is only applied ONCE! This is because +-- in general such application will not reach a fixed point. +data TCvSubst + = TCvSubst InScopeSet -- The in-scope type and kind variables + TvSubstEnv -- Substitutes both type and kind variables + CvSubstEnv -- Substitutes coercion variables + -- See Note [Substitutions apply only once] + -- and Note [Extending the TvSubstEnv] + -- and Note [Substituting types and coercions] + -- and Note [The substitution invariant] + +-- | A substitution of 'Type's for 'TyVar's +-- and 'Kind's for 'KindVar's +type TvSubstEnv = TyVarEnv Type + -- NB: A TvSubstEnv is used + -- both inside a TCvSubst (with the apply-once invariant + -- discussed in Note [Substitutions apply only once], + -- and also independently in the middle of matching, + -- and unification (see Types.Unify). + -- So you have to look at the context to know if it's idempotent or + -- apply-once or whatever + +-- | A substitution of 'Coercion's for 'CoVar's +type CvSubstEnv = CoVarEnv Coercion + +{- Note [The substitution invariant] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When calling (substTy subst ty) it should be the case that +the in-scope set in the substitution is a superset of both: + + (SIa) The free vars of the range of the substitution + (SIb) The free vars of ty minus the domain of the substitution + +The same rules apply to other substitutions (notably CoreSubst.Subst) + +* Reason for (SIa). Consider + substTy [a :-> Maybe b] (forall b. b->a) + we must rename the forall b, to get + forall b2. b2 -> Maybe b + Making 'b' part of the in-scope set forces this renaming to + take place. + +* Reason for (SIb). Consider + substTy [a :-> Maybe b] (forall b. (a,b,x)) + Then if we use the in-scope set {b}, satisfying (SIa), there is + a danger we will rename the forall'd variable to 'x' by mistake, + getting this: + forall x. (Maybe b, x, x) + Breaking (SIb) caused the bug from #11371. + +Note: if the free vars of the range of the substitution are freshly created, +then the problems of (SIa) can't happen, and so it would be sound to +ignore (SIa). + +Note [Substitutions apply only once] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We use TCvSubsts to instantiate things, and we might instantiate + forall a b. ty +with the types + [a, b], or [b, a]. +So the substitution might go [a->b, b->a]. A similar situation arises in Core +when we find a beta redex like + (/\ a /\ b -> e) b a +Then we also end up with a substitution that permutes type variables. Other +variations happen to; for example [a -> (a, b)]. + + ******************************************************** + *** So a substitution must be applied precisely once *** + ******************************************************** + +A TCvSubst is not idempotent, but, unlike the non-idempotent substitution +we use during unifications, it must not be repeatedly applied. + +Note [Extending the TvSubstEnv] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See #tcvsubst_invariant# for the invariants that must hold. + +This invariant allows a short-cut when the subst envs are empty: +if the TvSubstEnv and CvSubstEnv are empty --- i.e. (isEmptyTCvSubst subst) +holds --- then (substTy subst ty) does nothing. + +For example, consider: + (/\a. /\b:(a~Int). ...b..) Int +We substitute Int for 'a'. The Unique of 'b' does not change, but +nevertheless we add 'b' to the TvSubstEnv, because b's kind does change + +This invariant has several crucial consequences: + +* In substVarBndr, we need extend the TvSubstEnv + - if the unique has changed + - or if the kind has changed + +* In substTyVar, we do not need to consult the in-scope set; + the TvSubstEnv is enough + +* In substTy, substTheta, we can short-circuit when the TvSubstEnv is empty + +Note [Substituting types and coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Types and coercions are mutually recursive, and either may have variables +"belonging" to the other. Thus, every time we wish to substitute in a +type, we may also need to substitute in a coercion, and vice versa. +However, the constructor used to create type variables is distinct from +that of coercion variables, so we carry two VarEnvs in a TCvSubst. Note +that it would be possible to use the CoercionTy constructor to combine +these environments, but that seems like a false economy. + +Note that the TvSubstEnv should *never* map a CoVar (built with the Id +constructor) and the CvSubstEnv should *never* map a TyVar. Furthermore, +the range of the TvSubstEnv should *never* include a type headed with +CoercionTy. +-} + +emptyTvSubstEnv :: TvSubstEnv +emptyTvSubstEnv = emptyVarEnv + +emptyCvSubstEnv :: CvSubstEnv +emptyCvSubstEnv = emptyVarEnv + +composeTCvSubstEnv :: InScopeSet + -> (TvSubstEnv, CvSubstEnv) + -> (TvSubstEnv, CvSubstEnv) + -> (TvSubstEnv, CvSubstEnv) +-- ^ @(compose env1 env2)(x)@ is @env1(env2(x))@; i.e. apply @env2@ then @env1@. +-- It assumes that both are idempotent. +-- Typically, @env1@ is the refinement to a base substitution @env2@ +composeTCvSubstEnv in_scope (tenv1, cenv1) (tenv2, cenv2) + = ( tenv1 `plusVarEnv` mapVarEnv (substTy subst1) tenv2 + , cenv1 `plusVarEnv` mapVarEnv (substCo subst1) cenv2 ) + -- First apply env1 to the range of env2 + -- Then combine the two, making sure that env1 loses if + -- both bind the same variable; that's why env1 is the + -- *left* argument to plusVarEnv, because the right arg wins + where + subst1 = TCvSubst in_scope tenv1 cenv1 + +-- | Composes two substitutions, applying the second one provided first, +-- like in function composition. +composeTCvSubst :: TCvSubst -> TCvSubst -> TCvSubst +composeTCvSubst (TCvSubst is1 tenv1 cenv1) (TCvSubst is2 tenv2 cenv2) + = TCvSubst is3 tenv3 cenv3 + where + is3 = is1 `unionInScope` is2 + (tenv3, cenv3) = composeTCvSubstEnv is3 (tenv1, cenv1) (tenv2, cenv2) + +emptyTCvSubst :: TCvSubst +emptyTCvSubst = TCvSubst emptyInScopeSet emptyTvSubstEnv emptyCvSubstEnv + +mkEmptyTCvSubst :: InScopeSet -> TCvSubst +mkEmptyTCvSubst is = TCvSubst is emptyTvSubstEnv emptyCvSubstEnv + +isEmptyTCvSubst :: TCvSubst -> Bool + -- See Note [Extending the TvSubstEnv] +isEmptyTCvSubst (TCvSubst _ tenv cenv) = isEmptyVarEnv tenv && isEmptyVarEnv cenv + +mkTCvSubst :: InScopeSet -> (TvSubstEnv, CvSubstEnv) -> TCvSubst +mkTCvSubst in_scope (tenv, cenv) = TCvSubst in_scope tenv cenv + +mkTvSubst :: InScopeSet -> TvSubstEnv -> TCvSubst +-- ^ Make a TCvSubst with specified tyvar subst and empty covar subst +mkTvSubst in_scope tenv = TCvSubst in_scope tenv emptyCvSubstEnv + +mkCvSubst :: InScopeSet -> CvSubstEnv -> TCvSubst +-- ^ Make a TCvSubst with specified covar subst and empty tyvar subst +mkCvSubst in_scope cenv = TCvSubst in_scope emptyTvSubstEnv cenv + +getTvSubstEnv :: TCvSubst -> TvSubstEnv +getTvSubstEnv (TCvSubst _ env _) = env + +getCvSubstEnv :: TCvSubst -> CvSubstEnv +getCvSubstEnv (TCvSubst _ _ env) = env + +getTCvInScope :: TCvSubst -> InScopeSet +getTCvInScope (TCvSubst in_scope _ _) = in_scope + +-- | Returns the free variables of the types in the range of a substitution as +-- a non-deterministic set. +getTCvSubstRangeFVs :: TCvSubst -> VarSet +getTCvSubstRangeFVs (TCvSubst _ tenv cenv) + = unionVarSet tenvFVs cenvFVs + where + tenvFVs = tyCoVarsOfTypesSet tenv + cenvFVs = tyCoVarsOfCosSet cenv + +isInScope :: Var -> TCvSubst -> Bool +isInScope v (TCvSubst in_scope _ _) = v `elemInScopeSet` in_scope + +notElemTCvSubst :: Var -> TCvSubst -> Bool +notElemTCvSubst v (TCvSubst _ tenv cenv) + | isTyVar v + = not (v `elemVarEnv` tenv) + | otherwise + = not (v `elemVarEnv` cenv) + +setTvSubstEnv :: TCvSubst -> TvSubstEnv -> TCvSubst +setTvSubstEnv (TCvSubst in_scope _ cenv) tenv = TCvSubst in_scope tenv cenv + +setCvSubstEnv :: TCvSubst -> CvSubstEnv -> TCvSubst +setCvSubstEnv (TCvSubst in_scope tenv _) cenv = TCvSubst in_scope tenv cenv + +zapTCvSubst :: TCvSubst -> TCvSubst +zapTCvSubst (TCvSubst in_scope _ _) = TCvSubst in_scope emptyVarEnv emptyVarEnv + +extendTCvInScope :: TCvSubst -> Var -> TCvSubst +extendTCvInScope (TCvSubst in_scope tenv cenv) var + = TCvSubst (extendInScopeSet in_scope var) tenv cenv + +extendTCvInScopeList :: TCvSubst -> [Var] -> TCvSubst +extendTCvInScopeList (TCvSubst in_scope tenv cenv) vars + = TCvSubst (extendInScopeSetList in_scope vars) tenv cenv + +extendTCvInScopeSet :: TCvSubst -> VarSet -> TCvSubst +extendTCvInScopeSet (TCvSubst in_scope tenv cenv) vars + = TCvSubst (extendInScopeSetSet in_scope vars) tenv cenv + +extendTCvSubst :: TCvSubst -> TyCoVar -> Type -> TCvSubst +extendTCvSubst subst v ty + | isTyVar v + = extendTvSubst subst v ty + | CoercionTy co <- ty + = extendCvSubst subst v co + | otherwise + = pprPanic "extendTCvSubst" (ppr v <+> text "|->" <+> ppr ty) + +extendTCvSubstWithClone :: TCvSubst -> TyCoVar -> TyCoVar -> TCvSubst +extendTCvSubstWithClone subst tcv + | isTyVar tcv = extendTvSubstWithClone subst tcv + | otherwise = extendCvSubstWithClone subst tcv + +extendTvSubst :: TCvSubst -> TyVar -> Type -> TCvSubst +extendTvSubst (TCvSubst in_scope tenv cenv) tv ty + = TCvSubst in_scope (extendVarEnv tenv tv ty) cenv + +extendTvSubstBinderAndInScope :: TCvSubst -> TyCoBinder -> Type -> TCvSubst +extendTvSubstBinderAndInScope subst (Named (Bndr v _)) ty + = ASSERT( isTyVar v ) + extendTvSubstAndInScope subst v ty +extendTvSubstBinderAndInScope subst (Anon {}) _ + = subst + +extendTvSubstWithClone :: TCvSubst -> TyVar -> TyVar -> TCvSubst +-- Adds a new tv -> tv mapping, /and/ extends the in-scope set +extendTvSubstWithClone (TCvSubst in_scope tenv cenv) tv tv' + = TCvSubst (extendInScopeSetSet in_scope new_in_scope) + (extendVarEnv tenv tv (mkTyVarTy tv')) + cenv + where + new_in_scope = tyCoVarsOfType (tyVarKind tv') `extendVarSet` tv' + +extendCvSubst :: TCvSubst -> CoVar -> Coercion -> TCvSubst +extendCvSubst (TCvSubst in_scope tenv cenv) v co + = TCvSubst in_scope tenv (extendVarEnv cenv v co) + +extendCvSubstWithClone :: TCvSubst -> CoVar -> CoVar -> TCvSubst +extendCvSubstWithClone (TCvSubst in_scope tenv cenv) cv cv' + = TCvSubst (extendInScopeSetSet in_scope new_in_scope) + tenv + (extendVarEnv cenv cv (mkCoVarCo cv')) + where + new_in_scope = tyCoVarsOfType (varType cv') `extendVarSet` cv' + +extendTvSubstAndInScope :: TCvSubst -> TyVar -> Type -> TCvSubst +-- Also extends the in-scope set +extendTvSubstAndInScope (TCvSubst in_scope tenv cenv) tv ty + = TCvSubst (in_scope `extendInScopeSetSet` tyCoVarsOfType ty) + (extendVarEnv tenv tv ty) + cenv + +extendTvSubstList :: TCvSubst -> [Var] -> [Type] -> TCvSubst +extendTvSubstList subst tvs tys + = foldl2 extendTvSubst subst tvs tys + +extendTCvSubstList :: TCvSubst -> [Var] -> [Type] -> TCvSubst +extendTCvSubstList subst tvs tys + = foldl2 extendTCvSubst subst tvs tys + +unionTCvSubst :: TCvSubst -> TCvSubst -> TCvSubst +-- Works when the ranges are disjoint +unionTCvSubst (TCvSubst in_scope1 tenv1 cenv1) (TCvSubst in_scope2 tenv2 cenv2) + = ASSERT( not (tenv1 `intersectsVarEnv` tenv2) + && not (cenv1 `intersectsVarEnv` cenv2) ) + TCvSubst (in_scope1 `unionInScope` in_scope2) + (tenv1 `plusVarEnv` tenv2) + (cenv1 `plusVarEnv` cenv2) + +-- mkTvSubstPrs and zipTvSubst generate the in-scope set from +-- the types given; but it's just a thunk so with a bit of luck +-- it'll never be evaluated + +-- | Generates the in-scope set for the 'TCvSubst' from the types in the incoming +-- environment. No CoVars, please! +zipTvSubst :: [TyVar] -> [Type] -> TCvSubst +zipTvSubst tvs tys + | debugIsOn + , not (all isTyVar tvs) || neLength tvs tys + = pprTrace "zipTvSubst" (ppr tvs $$ ppr tys) emptyTCvSubst + | otherwise + = mkTvSubst (mkInScopeSet (tyCoVarsOfTypes tys)) tenv + where + tenv = zipTyEnv tvs tys + +-- | Generates the in-scope set for the 'TCvSubst' from the types in the incoming +-- environment. No TyVars, please! +zipCvSubst :: [CoVar] -> [Coercion] -> TCvSubst +zipCvSubst cvs cos + | debugIsOn + , not (all isCoVar cvs) || neLength cvs cos + = pprTrace "zipCvSubst" (ppr cvs $$ ppr cos) emptyTCvSubst + | otherwise + = TCvSubst (mkInScopeSet (tyCoVarsOfCos cos)) emptyTvSubstEnv cenv + where + cenv = zipCoEnv cvs cos + +zipTCvSubst :: [TyCoVar] -> [Type] -> TCvSubst +zipTCvSubst tcvs tys + | debugIsOn + , neLength tcvs tys + = pprTrace "zipTCvSubst" (ppr tcvs $$ ppr tys) emptyTCvSubst + | otherwise + = zip_tcvsubst tcvs tys (mkEmptyTCvSubst $ mkInScopeSet (tyCoVarsOfTypes tys)) + where zip_tcvsubst :: [TyCoVar] -> [Type] -> TCvSubst -> TCvSubst + zip_tcvsubst (tv:tvs) (ty:tys) subst + = zip_tcvsubst tvs tys (extendTCvSubst subst tv ty) + zip_tcvsubst _ _ subst = subst -- empty case + +-- | Generates the in-scope set for the 'TCvSubst' from the types in the +-- incoming environment. No CoVars, please! +mkTvSubstPrs :: [(TyVar, Type)] -> TCvSubst +mkTvSubstPrs prs = + ASSERT2( onlyTyVarsAndNoCoercionTy, text "prs" <+> ppr prs ) + mkTvSubst in_scope tenv + where tenv = mkVarEnv prs + in_scope = mkInScopeSet $ tyCoVarsOfTypes $ map snd prs + onlyTyVarsAndNoCoercionTy = + and [ isTyVar tv && not (isCoercionTy ty) + | (tv, ty) <- prs ] + +zipTyEnv :: [TyVar] -> [Type] -> TvSubstEnv +zipTyEnv tyvars tys + = ASSERT( all (not . isCoercionTy) tys ) + mkVarEnv (zipEqual "zipTyEnv" tyvars tys) + -- There used to be a special case for when + -- ty == TyVarTy tv + -- (a not-uncommon case) in which case the substitution was dropped. + -- But the type-tidier changes the print-name of a type variable without + -- changing the unique, and that led to a bug. Why? Pre-tidying, we had + -- a type {Foo t}, where Foo is a one-method class. So Foo is really a newtype. + -- And it happened that t was the type variable of the class. Post-tiding, + -- it got turned into {Foo t2}. The ext-core printer expanded this using + -- sourceTypeRep, but that said "Oh, t == t2" because they have the same unique, + -- and so generated a rep type mentioning t not t2. + -- + -- Simplest fix is to nuke the "optimisation" + +zipCoEnv :: [CoVar] -> [Coercion] -> CvSubstEnv +zipCoEnv cvs cos = mkVarEnv (zipEqual "zipCoEnv" cvs cos) + +instance Outputable TCvSubst where + ppr (TCvSubst ins tenv cenv) + = brackets $ sep[ text "TCvSubst", + nest 2 (text "In scope:" <+> ppr ins), + nest 2 (text "Type env:" <+> ppr tenv), + nest 2 (text "Co env:" <+> ppr cenv) ] + +{- +%************************************************************************ +%* * + Performing type or kind substitutions +%* * +%************************************************************************ + +Note [Sym and ForAllCo] +~~~~~~~~~~~~~~~~~~~~~~~ +In OptCoercion, we try to push "sym" out to the leaves of a coercion. But, +how do we push sym into a ForAllCo? It's a little ugly. + +Here is the typing rule: + +h : k1 ~# k2 +(tv : k1) |- g : ty1 ~# ty2 +---------------------------- +ForAllCo tv h g : (ForAllTy (tv : k1) ty1) ~# + (ForAllTy (tv : k2) (ty2[tv |-> tv |> sym h])) + +Here is what we want: + +ForAllCo tv h' g' : (ForAllTy (tv : k2) (ty2[tv |-> tv |> sym h])) ~# + (ForAllTy (tv : k1) ty1) + + +Because the kinds of the type variables to the right of the colon are the kinds +coerced by h', we know (h' : k2 ~# k1). Thus, (h' = sym h). + +Now, we can rewrite ty1 to be (ty1[tv |-> tv |> sym h' |> h']). We thus want + +ForAllCo tv h' g' : + (ForAllTy (tv : k2) (ty2[tv |-> tv |> h'])) ~# + (ForAllTy (tv : k1) (ty1[tv |-> tv |> h'][tv |-> tv |> sym h'])) + +We thus see that we want + +g' : ty2[tv |-> tv |> h'] ~# ty1[tv |-> tv |> h'] + +and thus g' = sym (g[tv |-> tv |> h']). + +Putting it all together, we get this: + +sym (ForAllCo tv h g) +==> +ForAllCo tv (sym h) (sym g[tv |-> tv |> sym h]) + +Note [Substituting in a coercion hole] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It seems highly suspicious to be substituting in a coercion that still +has coercion holes. Yet, this can happen in a situation like this: + + f :: forall k. k :~: Type -> () + f Refl = let x :: forall (a :: k). [a] -> ... + x = ... + +When we check x's type signature, we require that k ~ Type. We indeed +know this due to the Refl pattern match, but the eager unifier can't +make use of givens. So, when we're done looking at x's type, a coercion +hole will remain. Then, when we're checking x's definition, we skolemise +x's type (in order to, e.g., bring the scoped type variable `a` into scope). +This requires performing a substitution for the fresh skolem variables. + +This subsitution needs to affect the kind of the coercion hole, too -- +otherwise, the kind will have an out-of-scope variable in it. More problematically +in practice (we won't actually notice the out-of-scope variable ever), skolems +in the kind might have too high a level, triggering a failure to uphold the +invariant that no free variables in a type have a higher level than the +ambient level in the type checker. In the event of having free variables in the +hole's kind, I'm pretty sure we'll always have an erroneous program, so we +don't need to worry what will happen when the hole gets filled in. After all, +a hole relating a locally-bound type variable will be unable to be solved. This +is why it's OK not to look through the IORef of a coercion hole during +substitution. + +-} + +-- | Type substitution, see 'zipTvSubst' +substTyWith :: HasCallStack => [TyVar] -> [Type] -> Type -> Type +-- Works only if the domain of the substitution is a +-- superset of the type being substituted into +substTyWith tvs tys = {-#SCC "substTyWith" #-} + ASSERT( tvs `equalLength` tys ) + substTy (zipTvSubst tvs tys) + +-- | Type substitution, see 'zipTvSubst'. Disables sanity checks. +-- The problems that the sanity checks in substTy catch are described in +-- Note [The substitution invariant]. +-- The goal of #11371 is to migrate all the calls of substTyUnchecked to +-- substTy and remove this function. Please don't use in new code. +substTyWithUnchecked :: [TyVar] -> [Type] -> Type -> Type +substTyWithUnchecked tvs tys + = ASSERT( tvs `equalLength` tys ) + substTyUnchecked (zipTvSubst tvs tys) + +-- | Substitute tyvars within a type using a known 'InScopeSet'. +-- Pre-condition: the 'in_scope' set should satisfy Note [The substitution +-- invariant]; specifically it should include the free vars of 'tys', +-- and of 'ty' minus the domain of the subst. +substTyWithInScope :: InScopeSet -> [TyVar] -> [Type] -> Type -> Type +substTyWithInScope in_scope tvs tys ty = + ASSERT( tvs `equalLength` tys ) + substTy (mkTvSubst in_scope tenv) ty + where tenv = zipTyEnv tvs tys + +-- | Coercion substitution, see 'zipTvSubst' +substCoWith :: HasCallStack => [TyVar] -> [Type] -> Coercion -> Coercion +substCoWith tvs tys = ASSERT( tvs `equalLength` tys ) + substCo (zipTvSubst tvs tys) + +-- | Coercion substitution, see 'zipTvSubst'. Disables sanity checks. +-- The problems that the sanity checks in substCo catch are described in +-- Note [The substitution invariant]. +-- The goal of #11371 is to migrate all the calls of substCoUnchecked to +-- substCo and remove this function. Please don't use in new code. +substCoWithUnchecked :: [TyVar] -> [Type] -> Coercion -> Coercion +substCoWithUnchecked tvs tys + = ASSERT( tvs `equalLength` tys ) + substCoUnchecked (zipTvSubst tvs tys) + + + +-- | Substitute covars within a type +substTyWithCoVars :: [CoVar] -> [Coercion] -> Type -> Type +substTyWithCoVars cvs cos = substTy (zipCvSubst cvs cos) + +-- | Type substitution, see 'zipTvSubst' +substTysWith :: [TyVar] -> [Type] -> [Type] -> [Type] +substTysWith tvs tys = ASSERT( tvs `equalLength` tys ) + substTys (zipTvSubst tvs tys) + +-- | Type substitution, see 'zipTvSubst' +substTysWithCoVars :: [CoVar] -> [Coercion] -> [Type] -> [Type] +substTysWithCoVars cvs cos = ASSERT( cvs `equalLength` cos ) + substTys (zipCvSubst cvs cos) + +-- | Substitute within a 'Type' after adding the free variables of the type +-- to the in-scope set. This is useful for the case when the free variables +-- aren't already in the in-scope set or easily available. +-- See also Note [The substitution invariant]. +substTyAddInScope :: TCvSubst -> Type -> Type +substTyAddInScope subst ty = + substTy (extendTCvInScopeSet subst $ tyCoVarsOfType ty) ty + +-- | When calling `substTy` it should be the case that the in-scope set in +-- the substitution is a superset of the free vars of the range of the +-- substitution. +-- See also Note [The substitution invariant]. +isValidTCvSubst :: TCvSubst -> Bool +isValidTCvSubst (TCvSubst in_scope tenv cenv) = + (tenvFVs `varSetInScope` in_scope) && + (cenvFVs `varSetInScope` in_scope) + where + tenvFVs = tyCoVarsOfTypesSet tenv + cenvFVs = tyCoVarsOfCosSet cenv + +-- | This checks if the substitution satisfies the invariant from +-- Note [The substitution invariant]. +checkValidSubst :: HasCallStack => TCvSubst -> [Type] -> [Coercion] -> a -> a +checkValidSubst subst@(TCvSubst in_scope tenv cenv) tys cos a + = ASSERT2( isValidTCvSubst subst, + text "in_scope" <+> ppr in_scope $$ + text "tenv" <+> ppr tenv $$ + text "tenvFVs" <+> ppr (tyCoVarsOfTypesSet tenv) $$ + text "cenv" <+> ppr cenv $$ + text "cenvFVs" <+> ppr (tyCoVarsOfCosSet cenv) $$ + text "tys" <+> ppr tys $$ + text "cos" <+> ppr cos ) + ASSERT2( tysCosFVsInScope, + text "in_scope" <+> ppr in_scope $$ + text "tenv" <+> ppr tenv $$ + text "cenv" <+> ppr cenv $$ + text "tys" <+> ppr tys $$ + text "cos" <+> ppr cos $$ + text "needInScope" <+> ppr needInScope ) + a + where + substDomain = nonDetKeysUFM tenv ++ nonDetKeysUFM cenv + -- It's OK to use nonDetKeysUFM here, because we only use this list to + -- remove some elements from a set + needInScope = (tyCoVarsOfTypes tys `unionVarSet` tyCoVarsOfCos cos) + `delListFromUniqSet_Directly` substDomain + tysCosFVsInScope = needInScope `varSetInScope` in_scope + + +-- | Substitute within a 'Type' +-- The substitution has to satisfy the invariants described in +-- Note [The substitution invariant]. +substTy :: HasCallStack => TCvSubst -> Type -> Type +substTy subst ty + | isEmptyTCvSubst subst = ty + | otherwise = checkValidSubst subst [ty] [] $ + subst_ty subst ty + +-- | Substitute within a 'Type' disabling the sanity checks. +-- The problems that the sanity checks in substTy catch are described in +-- Note [The substitution invariant]. +-- The goal of #11371 is to migrate all the calls of substTyUnchecked to +-- substTy and remove this function. Please don't use in new code. +substTyUnchecked :: TCvSubst -> Type -> Type +substTyUnchecked subst ty + | isEmptyTCvSubst subst = ty + | otherwise = subst_ty subst ty + +-- | Substitute within several 'Type's +-- The substitution has to satisfy the invariants described in +-- Note [The substitution invariant]. +substTys :: HasCallStack => TCvSubst -> [Type] -> [Type] +substTys subst tys + | isEmptyTCvSubst subst = tys + | otherwise = checkValidSubst subst tys [] $ map (subst_ty subst) tys + +-- | Substitute within several 'Type's disabling the sanity checks. +-- The problems that the sanity checks in substTys catch are described in +-- Note [The substitution invariant]. +-- The goal of #11371 is to migrate all the calls of substTysUnchecked to +-- substTys and remove this function. Please don't use in new code. +substTysUnchecked :: TCvSubst -> [Type] -> [Type] +substTysUnchecked subst tys + | isEmptyTCvSubst subst = tys + | otherwise = map (subst_ty subst) tys + +-- | Substitute within a 'ThetaType' +-- The substitution has to satisfy the invariants described in +-- Note [The substitution invariant]. +substTheta :: HasCallStack => TCvSubst -> ThetaType -> ThetaType +substTheta = substTys + +-- | Substitute within a 'ThetaType' disabling the sanity checks. +-- The problems that the sanity checks in substTys catch are described in +-- Note [The substitution invariant]. +-- The goal of #11371 is to migrate all the calls of substThetaUnchecked to +-- substTheta and remove this function. Please don't use in new code. +substThetaUnchecked :: TCvSubst -> ThetaType -> ThetaType +substThetaUnchecked = substTysUnchecked + + +subst_ty :: TCvSubst -> Type -> Type +-- subst_ty is the main workhorse for type substitution +-- +-- Note that the in_scope set is poked only if we hit a forall +-- so it may often never be fully computed +subst_ty subst ty + = go ty + where + go (TyVarTy tv) = substTyVar subst tv + go (AppTy fun arg) = mkAppTy (go fun) $! (go arg) + -- The mkAppTy smart constructor is important + -- we might be replacing (a Int), represented with App + -- by [Int], represented with TyConApp + go (TyConApp tc tys) = let args = map go tys + in args `seqList` TyConApp tc args + go ty@(FunTy { ft_arg = arg, ft_res = res }) + = let !arg' = go arg + !res' = go res + in ty { ft_arg = arg', ft_res = res' } + go (ForAllTy (Bndr tv vis) ty) + = case substVarBndrUnchecked subst tv of + (subst', tv') -> + (ForAllTy $! ((Bndr $! tv') vis)) $! + (subst_ty subst' ty) + go (LitTy n) = LitTy $! n + go (CastTy ty co) = (mkCastTy $! (go ty)) $! (subst_co subst co) + go (CoercionTy co) = CoercionTy $! (subst_co subst co) + +substTyVar :: TCvSubst -> TyVar -> Type +substTyVar (TCvSubst _ tenv _) tv + = ASSERT( isTyVar tv ) + case lookupVarEnv tenv tv of + Just ty -> ty + Nothing -> TyVarTy tv + +substTyVars :: TCvSubst -> [TyVar] -> [Type] +substTyVars subst = map $ substTyVar subst + +substTyCoVars :: TCvSubst -> [TyCoVar] -> [Type] +substTyCoVars subst = map $ substTyCoVar subst + +substTyCoVar :: TCvSubst -> TyCoVar -> Type +substTyCoVar subst tv + | isTyVar tv = substTyVar subst tv + | otherwise = CoercionTy $ substCoVar subst tv + +lookupTyVar :: TCvSubst -> TyVar -> Maybe Type + -- See Note [Extending the TCvSubst] +lookupTyVar (TCvSubst _ tenv _) tv + = ASSERT( isTyVar tv ) + lookupVarEnv tenv tv + +-- | Substitute within a 'Coercion' +-- The substitution has to satisfy the invariants described in +-- Note [The substitution invariant]. +substCo :: HasCallStack => TCvSubst -> Coercion -> Coercion +substCo subst co + | isEmptyTCvSubst subst = co + | otherwise = checkValidSubst subst [] [co] $ subst_co subst co + +-- | Substitute within a 'Coercion' disabling sanity checks. +-- The problems that the sanity checks in substCo catch are described in +-- Note [The substitution invariant]. +-- The goal of #11371 is to migrate all the calls of substCoUnchecked to +-- substCo and remove this function. Please don't use in new code. +substCoUnchecked :: TCvSubst -> Coercion -> Coercion +substCoUnchecked subst co + | isEmptyTCvSubst subst = co + | otherwise = subst_co subst co + +-- | Substitute within several 'Coercion's +-- The substitution has to satisfy the invariants described in +-- Note [The substitution invariant]. +substCos :: HasCallStack => TCvSubst -> [Coercion] -> [Coercion] +substCos subst cos + | isEmptyTCvSubst subst = cos + | otherwise = checkValidSubst subst [] cos $ map (subst_co subst) cos + +subst_co :: TCvSubst -> Coercion -> Coercion +subst_co subst co + = go co + where + go_ty :: Type -> Type + go_ty = subst_ty subst + + go_mco :: MCoercion -> MCoercion + go_mco MRefl = MRefl + go_mco (MCo co) = MCo (go co) + + go :: Coercion -> Coercion + go (Refl ty) = mkNomReflCo $! (go_ty ty) + go (GRefl r ty mco) = (mkGReflCo r $! (go_ty ty)) $! (go_mco mco) + go (TyConAppCo r tc args)= let args' = map go args + in args' `seqList` mkTyConAppCo r tc args' + go (AppCo co arg) = (mkAppCo $! go co) $! go arg + go (ForAllCo tv kind_co co) + = case substForAllCoBndrUnchecked subst tv kind_co of + (subst', tv', kind_co') -> + ((mkForAllCo $! tv') $! kind_co') $! subst_co subst' co + go (FunCo r co1 co2) = (mkFunCo r $! go co1) $! go co2 + go (CoVarCo cv) = substCoVar subst cv + go (AxiomInstCo con ind cos) = mkAxiomInstCo con ind $! map go cos + go (UnivCo p r t1 t2) = (((mkUnivCo $! go_prov p) $! r) $! + (go_ty t1)) $! (go_ty t2) + go (SymCo co) = mkSymCo $! (go co) + go (TransCo co1 co2) = (mkTransCo $! (go co1)) $! (go co2) + go (NthCo r d co) = mkNthCo r d $! (go co) + go (LRCo lr co) = mkLRCo lr $! (go co) + go (InstCo co arg) = (mkInstCo $! (go co)) $! go arg + go (KindCo co) = mkKindCo $! (go co) + go (SubCo co) = mkSubCo $! (go co) + go (AxiomRuleCo c cs) = let cs1 = map go cs + in cs1 `seqList` AxiomRuleCo c cs1 + go (HoleCo h) = HoleCo $! go_hole h + + go_prov UnsafeCoerceProv = UnsafeCoerceProv + go_prov (PhantomProv kco) = PhantomProv (go kco) + go_prov (ProofIrrelProv kco) = ProofIrrelProv (go kco) + go_prov p@(PluginProv _) = p + + -- See Note [Substituting in a coercion hole] + go_hole h@(CoercionHole { ch_co_var = cv }) + = h { ch_co_var = updateVarType go_ty cv } + +substForAllCoBndr :: TCvSubst -> TyCoVar -> KindCoercion + -> (TCvSubst, TyCoVar, Coercion) +substForAllCoBndr subst + = substForAllCoBndrUsing False (substCo subst) subst + +-- | Like 'substForAllCoBndr', but disables sanity checks. +-- The problems that the sanity checks in substCo catch are described in +-- Note [The substitution invariant]. +-- The goal of #11371 is to migrate all the calls of substCoUnchecked to +-- substCo and remove this function. Please don't use in new code. +substForAllCoBndrUnchecked :: TCvSubst -> TyCoVar -> KindCoercion + -> (TCvSubst, TyCoVar, Coercion) +substForAllCoBndrUnchecked subst + = substForAllCoBndrUsing False (substCoUnchecked subst) subst + +-- See Note [Sym and ForAllCo] +substForAllCoBndrUsing :: Bool -- apply sym to binder? + -> (Coercion -> Coercion) -- transformation to kind co + -> TCvSubst -> TyCoVar -> KindCoercion + -> (TCvSubst, TyCoVar, KindCoercion) +substForAllCoBndrUsing sym sco subst old_var + | isTyVar old_var = substForAllCoTyVarBndrUsing sym sco subst old_var + | otherwise = substForAllCoCoVarBndrUsing sym sco subst old_var + +substForAllCoTyVarBndrUsing :: Bool -- apply sym to binder? + -> (Coercion -> Coercion) -- transformation to kind co + -> TCvSubst -> TyVar -> KindCoercion + -> (TCvSubst, TyVar, KindCoercion) +substForAllCoTyVarBndrUsing sym sco (TCvSubst in_scope tenv cenv) old_var old_kind_co + = ASSERT( isTyVar old_var ) + ( TCvSubst (in_scope `extendInScopeSet` new_var) new_env cenv + , new_var, new_kind_co ) + where + new_env | no_change && not sym = delVarEnv tenv old_var + | sym = extendVarEnv tenv old_var $ + TyVarTy new_var `CastTy` new_kind_co + | otherwise = extendVarEnv tenv old_var (TyVarTy new_var) + + no_kind_change = noFreeVarsOfCo old_kind_co + no_change = no_kind_change && (new_var == old_var) + + new_kind_co | no_kind_change = old_kind_co + | otherwise = sco old_kind_co + + Pair new_ki1 _ = coercionKind new_kind_co + -- We could do substitution to (tyVarKind old_var). We don't do so because + -- we already substituted new_kind_co, which contains the kind information + -- we want. We don't want to do substitution once more. Also, in most cases, + -- new_kind_co is a Refl, in which case coercionKind is really fast. + + new_var = uniqAway in_scope (setTyVarKind old_var new_ki1) + +substForAllCoCoVarBndrUsing :: Bool -- apply sym to binder? + -> (Coercion -> Coercion) -- transformation to kind co + -> TCvSubst -> CoVar -> KindCoercion + -> (TCvSubst, CoVar, KindCoercion) +substForAllCoCoVarBndrUsing sym sco (TCvSubst in_scope tenv cenv) + old_var old_kind_co + = ASSERT( isCoVar old_var ) + ( TCvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv + , new_var, new_kind_co ) + where + new_cenv | no_change && not sym = delVarEnv cenv old_var + | otherwise = extendVarEnv cenv old_var (mkCoVarCo new_var) + + no_kind_change = noFreeVarsOfCo old_kind_co + no_change = no_kind_change && (new_var == old_var) + + new_kind_co | no_kind_change = old_kind_co + | otherwise = sco old_kind_co + + Pair h1 h2 = coercionKind new_kind_co + + new_var = uniqAway in_scope $ mkCoVar (varName old_var) new_var_type + new_var_type | sym = h2 + | otherwise = h1 + +substCoVar :: TCvSubst -> CoVar -> Coercion +substCoVar (TCvSubst _ _ cenv) cv + = case lookupVarEnv cenv cv of + Just co -> co + Nothing -> CoVarCo cv + +substCoVars :: TCvSubst -> [CoVar] -> [Coercion] +substCoVars subst cvs = map (substCoVar subst) cvs + +lookupCoVar :: TCvSubst -> Var -> Maybe Coercion +lookupCoVar (TCvSubst _ _ cenv) v = lookupVarEnv cenv v + +substTyVarBndr :: HasCallStack => TCvSubst -> TyVar -> (TCvSubst, TyVar) +substTyVarBndr = substTyVarBndrUsing substTy + +substTyVarBndrs :: HasCallStack => TCvSubst -> [TyVar] -> (TCvSubst, [TyVar]) +substTyVarBndrs = mapAccumL substTyVarBndr + +substVarBndr :: HasCallStack => TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar) +substVarBndr = substVarBndrUsing substTy + +substVarBndrs :: HasCallStack => TCvSubst -> [TyCoVar] -> (TCvSubst, [TyCoVar]) +substVarBndrs = mapAccumL substVarBndr + +substCoVarBndr :: HasCallStack => TCvSubst -> CoVar -> (TCvSubst, CoVar) +substCoVarBndr = substCoVarBndrUsing substTy + +-- | Like 'substVarBndr', but disables sanity checks. +-- The problems that the sanity checks in substTy catch are described in +-- Note [The substitution invariant]. +-- The goal of #11371 is to migrate all the calls of substTyUnchecked to +-- substTy and remove this function. Please don't use in new code. +substVarBndrUnchecked :: TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar) +substVarBndrUnchecked = substVarBndrUsing substTyUnchecked + +substVarBndrUsing :: (TCvSubst -> Type -> Type) + -> TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar) +substVarBndrUsing subst_fn subst v + | isTyVar v = substTyVarBndrUsing subst_fn subst v + | otherwise = substCoVarBndrUsing subst_fn subst v + +-- | Substitute a tyvar in a binding position, returning an +-- extended subst and a new tyvar. +-- Use the supplied function to substitute in the kind +substTyVarBndrUsing + :: (TCvSubst -> Type -> Type) -- ^ Use this to substitute in the kind + -> TCvSubst -> TyVar -> (TCvSubst, TyVar) +substTyVarBndrUsing subst_fn subst@(TCvSubst in_scope tenv cenv) old_var + = ASSERT2( _no_capture, pprTyVar old_var $$ pprTyVar new_var $$ ppr subst ) + ASSERT( isTyVar old_var ) + (TCvSubst (in_scope `extendInScopeSet` new_var) new_env cenv, new_var) + where + new_env | no_change = delVarEnv tenv old_var + | otherwise = extendVarEnv tenv old_var (TyVarTy new_var) + + _no_capture = not (new_var `elemVarSet` tyCoVarsOfTypesSet tenv) + -- Assertion check that we are not capturing something in the substitution + + old_ki = tyVarKind old_var + no_kind_change = noFreeVarsOfType old_ki -- verify that kind is closed + no_change = no_kind_change && (new_var == old_var) + -- no_change means that the new_var is identical in + -- all respects to the old_var (same unique, same kind) + -- See Note [Extending the TCvSubst] + -- + -- In that case we don't need to extend the substitution + -- to map old to new. But instead we must zap any + -- current substitution for the variable. For example: + -- (\x.e) with id_subst = [x |-> e'] + -- Here we must simply zap the substitution for x + + new_var | no_kind_change = uniqAway in_scope old_var + | otherwise = uniqAway in_scope $ + setTyVarKind old_var (subst_fn subst old_ki) + -- The uniqAway part makes sure the new variable is not already in scope + +-- | Substitute a covar in a binding position, returning an +-- extended subst and a new covar. +-- Use the supplied function to substitute in the kind +substCoVarBndrUsing + :: (TCvSubst -> Type -> Type) + -> TCvSubst -> CoVar -> (TCvSubst, CoVar) +substCoVarBndrUsing subst_fn subst@(TCvSubst in_scope tenv cenv) old_var + = ASSERT( isCoVar old_var ) + (TCvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv, new_var) + where + new_co = mkCoVarCo new_var + no_kind_change = noFreeVarsOfTypes [t1, t2] + no_change = new_var == old_var && no_kind_change + + new_cenv | no_change = delVarEnv cenv old_var + | otherwise = extendVarEnv cenv old_var new_co + + new_var = uniqAway in_scope subst_old_var + subst_old_var = mkCoVar (varName old_var) new_var_type + + (_, _, t1, t2, role) = coVarKindsTypesRole old_var + t1' = subst_fn subst t1 + t2' = subst_fn subst t2 + new_var_type = mkCoercionType role t1' t2' + -- It's important to do the substitution for coercions, + -- because they can have free type variables + +cloneTyVarBndr :: TCvSubst -> TyVar -> Unique -> (TCvSubst, TyVar) +cloneTyVarBndr subst@(TCvSubst in_scope tv_env cv_env) tv uniq + = ASSERT2( isTyVar tv, ppr tv ) -- I think it's only called on TyVars + (TCvSubst (extendInScopeSet in_scope tv') + (extendVarEnv tv_env tv (mkTyVarTy tv')) cv_env, tv') + where + old_ki = tyVarKind tv + no_kind_change = noFreeVarsOfType old_ki -- verify that kind is closed + + tv1 | no_kind_change = tv + | otherwise = setTyVarKind tv (substTy subst old_ki) + + tv' = setVarUnique tv1 uniq + +cloneTyVarBndrs :: TCvSubst -> [TyVar] -> UniqSupply -> (TCvSubst, [TyVar]) +cloneTyVarBndrs subst [] _usupply = (subst, []) +cloneTyVarBndrs subst (t:ts) usupply = (subst'', tv:tvs) + where + (uniq, usupply') = takeUniqFromSupply usupply + (subst' , tv ) = cloneTyVarBndr subst t uniq + (subst'', tvs) = cloneTyVarBndrs subst' ts usupply' + +{- +%************************************************************************ +%* * + Pretty-printing types + + Defined very early because of debug printing in assertions +%* * +%************************************************************************ + +@pprType@ is the standard @Type@ printer; the overloaded @ppr@ function is +defined to use this. @pprParendType@ is the same, except it puts +parens around the type, except for the atomic cases. @pprParendType@ +works just by setting the initial context precedence very high. + +Note that any function which pretty-prints a @Type@ first converts the @Type@ +to an @IfaceType@. See Note [IfaceType and pretty-printing] in IfaceType. + +See Note [Precedence in types] in BasicTypes. +-} + +-------------------------------------------------------- +-- When pretty-printing types, we convert to IfaceType, +-- and pretty-print that. +-- See Note [Pretty printing via IfaceSyn] in PprTyThing +-------------------------------------------------------- + +pprType, pprParendType :: Type -> SDoc +pprType = pprPrecType topPrec +pprParendType = pprPrecType appPrec + +pprPrecType :: PprPrec -> Type -> SDoc +pprPrecType = pprPrecTypeX emptyTidyEnv + +pprPrecTypeX :: TidyEnv -> PprPrec -> Type -> SDoc +pprPrecTypeX env prec ty + = getPprStyle $ \sty -> + if debugStyle sty -- Use debugPprType when in + then debug_ppr_ty prec ty -- when in debug-style + else pprPrecIfaceType prec (tidyToIfaceTypeStyX env ty sty) + -- NB: debug-style is used for -dppr-debug + -- dump-style is used for -ddump-tc-trace etc + +pprTyLit :: TyLit -> SDoc +pprTyLit = pprIfaceTyLit . toIfaceTyLit + +pprKind, pprParendKind :: Kind -> SDoc +pprKind = pprType +pprParendKind = pprParendType + +tidyToIfaceTypeStyX :: TidyEnv -> Type -> PprStyle -> IfaceType +tidyToIfaceTypeStyX env ty sty + | userStyle sty = tidyToIfaceTypeX env ty + | otherwise = toIfaceTypeX (tyCoVarsOfType ty) ty + -- in latter case, don't tidy, as we'll be printing uniques. + +tidyToIfaceType :: Type -> IfaceType +tidyToIfaceType = tidyToIfaceTypeX emptyTidyEnv + +tidyToIfaceTypeX :: TidyEnv -> Type -> IfaceType +-- It's vital to tidy before converting to an IfaceType +-- or nested binders will become indistinguishable! +-- +-- Also for the free type variables, tell toIfaceTypeX to +-- leave them as IfaceFreeTyVar. This is super-important +-- for debug printing. +tidyToIfaceTypeX env ty = toIfaceTypeX (mkVarSet free_tcvs) (tidyType env' ty) + where + env' = tidyFreeTyCoVars env free_tcvs + free_tcvs = tyCoVarsOfTypeWellScoped ty + +------------ +pprCo, pprParendCo :: Coercion -> SDoc +pprCo co = getPprStyle $ \ sty -> pprIfaceCoercion (tidyToIfaceCoSty co sty) +pprParendCo co = getPprStyle $ \ sty -> pprParendIfaceCoercion (tidyToIfaceCoSty co sty) + +tidyToIfaceCoSty :: Coercion -> PprStyle -> IfaceCoercion +tidyToIfaceCoSty co sty + | userStyle sty = tidyToIfaceCo co + | otherwise = toIfaceCoercionX (tyCoVarsOfCo co) co + -- in latter case, don't tidy, as we'll be printing uniques. + +tidyToIfaceCo :: Coercion -> IfaceCoercion +-- It's vital to tidy before converting to an IfaceType +-- or nested binders will become indistinguishable! +-- +-- Also for the free type variables, tell toIfaceCoercionX to +-- leave them as IfaceFreeCoVar. This is super-important +-- for debug printing. +tidyToIfaceCo co = toIfaceCoercionX (mkVarSet free_tcvs) (tidyCo env co) + where + env = tidyFreeTyCoVars emptyTidyEnv free_tcvs + free_tcvs = scopedSort $ tyCoVarsOfCoList co +------------ +pprClassPred :: Class -> [Type] -> SDoc +pprClassPred clas tys = pprTypeApp (classTyCon clas) tys + +------------ +pprTheta :: ThetaType -> SDoc +pprTheta = pprIfaceContext topPrec . map tidyToIfaceType + +pprParendTheta :: ThetaType -> SDoc +pprParendTheta = pprIfaceContext appPrec . map tidyToIfaceType + +pprThetaArrowTy :: ThetaType -> SDoc +pprThetaArrowTy = pprIfaceContextArr . map tidyToIfaceType + +------------------ +instance Outputable Type where + ppr ty = pprType ty + +instance Outputable TyLit where + ppr = pprTyLit + +------------------ +pprSigmaType :: Type -> SDoc +pprSigmaType = pprIfaceSigmaType ShowForAllWhen . tidyToIfaceType + +pprForAll :: [TyCoVarBinder] -> SDoc +pprForAll tvs = pprIfaceForAll (map toIfaceForAllBndr tvs) + +-- | Print a user-level forall; see Note [When to print foralls] +pprUserForAll :: [TyCoVarBinder] -> SDoc +pprUserForAll = pprUserIfaceForAll . map toIfaceForAllBndr + +pprTCvBndrs :: [TyCoVarBinder] -> SDoc +pprTCvBndrs tvs = sep (map pprTCvBndr tvs) + +pprTCvBndr :: TyCoVarBinder -> SDoc +pprTCvBndr = pprTyVar . binderVar + +pprTyVars :: [TyVar] -> SDoc +pprTyVars tvs = sep (map pprTyVar tvs) + +pprTyVar :: TyVar -> SDoc +-- Print a type variable binder with its kind (but not if *) +-- Here we do not go via IfaceType, because the duplication with +-- pprIfaceTvBndr is minimal, and the loss of uniques etc in +-- debug printing is disastrous +pprTyVar tv + | isLiftedTypeKind kind = ppr tv + | otherwise = parens (ppr tv <+> dcolon <+> ppr kind) + where + kind = tyVarKind tv + +instance Outputable TyCoBinder where + ppr (Anon af ty) = ppr af <+> ppr ty + ppr (Named (Bndr v Required)) = ppr v + ppr (Named (Bndr v Specified)) = char '@' <> ppr v + ppr (Named (Bndr v Inferred)) = braces (ppr v) + +----------------- +instance Outputable Coercion where -- defined here to avoid orphans + ppr = pprCo + +debugPprType :: Type -> SDoc +-- ^ debugPprType is a simple pretty printer that prints a type +-- without going through IfaceType. It does not format as prettily +-- as the normal route, but it's much more direct, and that can +-- be useful for debugging. E.g. with -dppr-debug it prints the +-- kind on type-variable /occurrences/ which the normal route +-- fundamentally cannot do. +debugPprType ty = debug_ppr_ty topPrec ty + +debug_ppr_ty :: PprPrec -> Type -> SDoc +debug_ppr_ty _ (LitTy l) + = ppr l + +debug_ppr_ty _ (TyVarTy tv) + = ppr tv -- With -dppr-debug we get (tv :: kind) + +debug_ppr_ty prec (FunTy { ft_af = af, ft_arg = arg, ft_res = res }) + = maybeParen prec funPrec $ + sep [debug_ppr_ty funPrec arg, arrow <+> debug_ppr_ty prec res] + where + arrow = case af of + VisArg -> text "->" + InvisArg -> text "=>" + +debug_ppr_ty prec (TyConApp tc tys) + | null tys = ppr tc + | otherwise = maybeParen prec appPrec $ + hang (ppr tc) 2 (sep (map (debug_ppr_ty appPrec) tys)) + +debug_ppr_ty _ (AppTy t1 t2) + = hang (debug_ppr_ty appPrec t1) -- Print parens so we see ((a b) c) + 2 (debug_ppr_ty appPrec t2) -- so that we can distinguish + -- TyConApp from AppTy + +debug_ppr_ty prec (CastTy ty co) + = maybeParen prec topPrec $ + hang (debug_ppr_ty topPrec ty) + 2 (text "|>" <+> ppr co) + +debug_ppr_ty _ (CoercionTy co) + = parens (text "CO" <+> ppr co) + +debug_ppr_ty prec ty@(ForAllTy {}) + | (tvs, body) <- split ty + = maybeParen prec funPrec $ + hang (text "forall" <+> fsep (map ppr tvs) <> dot) + -- The (map ppr tvs) will print kind-annotated + -- tvs, because we are (usually) in debug-style + 2 (ppr body) + where + split ty | ForAllTy tv ty' <- ty + , (tvs, body) <- split ty' + = (tv:tvs, body) + | otherwise + = ([], ty) + +{- +Note [When to print foralls] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Mostly we want to print top-level foralls when (and only when) the user specifies +-fprint-explicit-foralls. But when kind polymorphism is at work, that suppresses +too much information; see #9018. + +So I'm trying out this rule: print explicit foralls if + a) User specifies -fprint-explicit-foralls, or + b) Any of the quantified type variables has a kind + that mentions a kind variable + +This catches common situations, such as a type siguature + f :: m a +which means + f :: forall k. forall (m :: k->*) (a :: k). m a +We really want to see both the "forall k" and the kind signatures +on m and a. The latter comes from pprTCvBndr. + +Note [Infix type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +With TypeOperators you can say + + f :: (a ~> b) -> b + +and the (~>) is considered a type variable. However, the type +pretty-printer in this module will just see (a ~> b) as + + App (App (TyVarTy "~>") (TyVarTy "a")) (TyVarTy "b") + +So it'll print the type in prefix form. To avoid confusion we must +remember to parenthesise the operator, thus + + (~>) a b -> b + +See #2766. +-} + +pprDataCons :: TyCon -> SDoc +pprDataCons = sepWithVBars . fmap pprDataConWithArgs . tyConDataCons + where + sepWithVBars [] = empty + sepWithVBars docs = sep (punctuate (space <> vbar) docs) + +pprDataConWithArgs :: DataCon -> SDoc +pprDataConWithArgs dc = sep [forAllDoc, thetaDoc, ppr dc <+> argsDoc] + where + (_univ_tvs, _ex_tvs, _eq_spec, theta, arg_tys, _res_ty) = dataConFullSig dc + user_bndrs = dataConUserTyVarBinders dc + forAllDoc = pprUserForAll user_bndrs + thetaDoc = pprThetaArrowTy theta + argsDoc = hsep (fmap pprParendType arg_tys) + + +pprTypeApp :: TyCon -> [Type] -> SDoc +pprTypeApp tc tys + = pprIfaceTypeApp topPrec (toIfaceTyCon tc) + (toIfaceTcArgs tc tys) + -- TODO: toIfaceTcArgs seems rather wasteful here + +------------------ +-- | Display all kind information (with @-fprint-explicit-kinds@) when the +-- provided 'Bool' argument is 'True'. +-- See @Note [Kind arguments in error messages]@ in "TcErrors". +pprWithExplicitKindsWhen :: Bool -> SDoc -> SDoc +pprWithExplicitKindsWhen b + = updSDocDynFlags $ \dflags -> + if b then gopt_set dflags Opt_PrintExplicitKinds + else dflags + +{- +%************************************************************************ +%* * +\subsection{TidyType} +%* * +%************************************************************************ +-} + +-- | This tidies up a type for printing in an error message, or in +-- an interface file. +-- +-- It doesn't change the uniques at all, just the print names. +tidyVarBndrs :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar]) +tidyVarBndrs tidy_env tvs + = mapAccumL tidyVarBndr (avoidNameClashes tvs tidy_env) tvs + +tidyVarBndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar) +tidyVarBndr tidy_env@(occ_env, subst) var + = case tidyOccName occ_env (getHelpfulOccName var) of + (occ_env', occ') -> ((occ_env', subst'), var') + where + subst' = extendVarEnv subst var var' + var' = setVarType (setVarName var name') type' + type' = tidyType tidy_env (varType var) + name' = tidyNameOcc name occ' + name = varName var + +avoidNameClashes :: [TyCoVar] -> TidyEnv -> TidyEnv +-- Seed the occ_env with clashes among the names, see +-- Note [Tidying multiple names at once] in OccName +avoidNameClashes tvs (occ_env, subst) + = (avoidClashesOccEnv occ_env occs, subst) + where + occs = map getHelpfulOccName tvs + +getHelpfulOccName :: TyCoVar -> OccName +-- A TcTyVar with a System Name is probably a +-- unification variable; when we tidy them we give them a trailing +-- "0" (or 1 etc) so that they don't take precedence for the +-- un-modified name. Plus, indicating a unification variable in +-- this way is a helpful clue for users +getHelpfulOccName tv + | isSystemName name, isTcTyVar tv + = mkTyVarOcc (occNameString occ ++ "0") + | otherwise + = occ + where + name = varName tv + occ = getOccName name + +tidyTyCoVarBinder :: TidyEnv -> VarBndr TyCoVar vis + -> (TidyEnv, VarBndr TyCoVar vis) +tidyTyCoVarBinder tidy_env (Bndr tv vis) + = (tidy_env', Bndr tv' vis) + where + (tidy_env', tv') = tidyVarBndr tidy_env tv + +tidyTyCoVarBinders :: TidyEnv -> [VarBndr TyCoVar vis] + -> (TidyEnv, [VarBndr TyCoVar vis]) +tidyTyCoVarBinders tidy_env tvbs + = mapAccumL tidyTyCoVarBinder + (avoidNameClashes (binderVars tvbs) tidy_env) tvbs + +--------------- +tidyFreeTyCoVars :: TidyEnv -> [TyCoVar] -> TidyEnv +-- ^ Add the free 'TyVar's to the env in tidy form, +-- so that we can tidy the type they are free in +tidyFreeTyCoVars (full_occ_env, var_env) tyvars + = fst (tidyOpenTyCoVars (full_occ_env, var_env) tyvars) + +--------------- +tidyOpenTyCoVars :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar]) +tidyOpenTyCoVars env tyvars = mapAccumL tidyOpenTyCoVar env tyvars + +--------------- +tidyOpenTyCoVar :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar) +-- ^ Treat a new 'TyCoVar' as a binder, and give it a fresh tidy name +-- using the environment if one has not already been allocated. See +-- also 'tidyVarBndr' +tidyOpenTyCoVar env@(_, subst) tyvar + = case lookupVarEnv subst tyvar of + Just tyvar' -> (env, tyvar') -- Already substituted + Nothing -> + let env' = tidyFreeTyCoVars env (tyCoVarsOfTypeList (tyVarKind tyvar)) + in tidyVarBndr env' tyvar -- Treat it as a binder + +--------------- +tidyTyCoVarOcc :: TidyEnv -> TyCoVar -> TyCoVar +tidyTyCoVarOcc env@(_, subst) tv + = case lookupVarEnv subst tv of + Nothing -> updateVarType (tidyType env) tv + Just tv' -> tv' + +--------------- +tidyTypes :: TidyEnv -> [Type] -> [Type] +tidyTypes env tys = map (tidyType env) tys + +--------------- +tidyType :: TidyEnv -> Type -> Type +tidyType _ (LitTy n) = LitTy n +tidyType env (TyVarTy tv) = TyVarTy (tidyTyCoVarOcc env tv) +tidyType env (TyConApp tycon tys) = let args = tidyTypes env tys + in args `seqList` TyConApp tycon args +tidyType env (AppTy fun arg) = (AppTy $! (tidyType env fun)) $! (tidyType env arg) +tidyType env ty@(FunTy _ arg res) = let { !arg' = tidyType env arg + ; !res' = tidyType env res } + in ty { ft_arg = arg', ft_res = res' } +tidyType env (ty@(ForAllTy{})) = mkForAllTys' (zip tvs' vis) $! tidyType env' body_ty + where + (tvs, vis, body_ty) = splitForAllTys' ty + (env', tvs') = tidyVarBndrs env tvs +tidyType env (CastTy ty co) = (CastTy $! tidyType env ty) $! (tidyCo env co) +tidyType env (CoercionTy co) = CoercionTy $! (tidyCo env co) + + +-- The following two functions differ from mkForAllTys and splitForAllTys in that +-- they expect/preserve the ArgFlag argument. Thes belong to types/Type.hs, but +-- how should they be named? +mkForAllTys' :: [(TyCoVar, ArgFlag)] -> Type -> Type +mkForAllTys' tvvs ty = foldr strictMkForAllTy ty tvvs + where + strictMkForAllTy (tv,vis) ty = (ForAllTy $! ((Bndr $! tv) $! vis)) $! ty + +splitForAllTys' :: Type -> ([TyCoVar], [ArgFlag], Type) +splitForAllTys' ty = go ty [] [] + where + go (ForAllTy (Bndr tv vis) ty) tvs viss = go ty (tv:tvs) (vis:viss) + go ty tvs viss = (reverse tvs, reverse viss, ty) + + +--------------- +-- | Grabs the free type variables, tidies them +-- and then uses 'tidyType' to work over the type itself +tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type]) +tidyOpenTypes env tys + = (env', tidyTypes (trimmed_occ_env, var_env) tys) + where + (env'@(_, var_env), tvs') = tidyOpenTyCoVars env $ + tyCoVarsOfTypesWellScoped tys + trimmed_occ_env = initTidyOccEnv (map getOccName tvs') + -- The idea here was that we restrict the new TidyEnv to the + -- _free_ vars of the types, so that we don't gratuitously rename + -- the _bound_ variables of the types. + +--------------- +tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type) +tidyOpenType env ty = let (env', [ty']) = tidyOpenTypes env [ty] in + (env', ty') + +--------------- +-- | Calls 'tidyType' on a top-level type (i.e. with an empty tidying environment) +tidyTopType :: Type -> Type +tidyTopType ty = tidyType emptyTidyEnv ty + +--------------- +tidyOpenKind :: TidyEnv -> Kind -> (TidyEnv, Kind) +tidyOpenKind = tidyOpenType + +tidyKind :: TidyEnv -> Kind -> Kind +tidyKind = tidyType + +---------------- +tidyCo :: TidyEnv -> Coercion -> Coercion +tidyCo env@(_, subst) co + = go co + where + go_mco MRefl = MRefl + go_mco (MCo co) = MCo (go co) + + go (Refl ty) = Refl (tidyType env ty) + go (GRefl r ty mco) = GRefl r (tidyType env ty) $! go_mco mco + go (TyConAppCo r tc cos) = let args = map go cos + in args `seqList` TyConAppCo r tc args + go (AppCo co1 co2) = (AppCo $! go co1) $! go co2 + go (ForAllCo tv h co) = ((ForAllCo $! tvp) $! (go h)) $! (tidyCo envp co) + where (envp, tvp) = tidyVarBndr env tv + -- the case above duplicates a bit of work in tidying h and the kind + -- of tv. But the alternative is to use coercionKind, which seems worse. + go (FunCo r co1 co2) = (FunCo r $! go co1) $! go co2 + go (CoVarCo cv) = case lookupVarEnv subst cv of + Nothing -> CoVarCo cv + Just cv' -> CoVarCo cv' + go (HoleCo h) = HoleCo h + go (AxiomInstCo con ind cos) = let args = map go cos + in args `seqList` AxiomInstCo con ind args + go (UnivCo p r t1 t2) = (((UnivCo $! (go_prov p)) $! r) $! + tidyType env t1) $! tidyType env t2 + go (SymCo co) = SymCo $! go co + go (TransCo co1 co2) = (TransCo $! go co1) $! go co2 + go (NthCo r d co) = NthCo r d $! go co + go (LRCo lr co) = LRCo lr $! go co + go (InstCo co ty) = (InstCo $! go co) $! go ty + go (KindCo co) = KindCo $! go co + go (SubCo co) = SubCo $! go co + go (AxiomRuleCo ax cos) = let cos1 = tidyCos env cos + in cos1 `seqList` AxiomRuleCo ax cos1 + + go_prov UnsafeCoerceProv = UnsafeCoerceProv + go_prov (PhantomProv co) = PhantomProv (go co) + go_prov (ProofIrrelProv co) = ProofIrrelProv (go co) + go_prov p@(PluginProv _) = p + +tidyCos :: TidyEnv -> [Coercion] -> [Coercion] +tidyCos env = map (tidyCo env) + + +{- ********************************************************************* +* * + typeSize, coercionSize +* * +********************************************************************* -} + +-- NB: We put typeSize/coercionSize here because they are mutually +-- recursive, and have the CPR property. If we have mutual +-- recursion across a hi-boot file, we don't get the CPR property +-- and these functions allocate a tremendous amount of rubbish. +-- It's not critical (because typeSize is really only used in +-- debug mode, but I tripped over an example (T5642) in which +-- typeSize was one of the biggest single allocators in all of GHC. +-- And it's easy to fix, so I did. + +-- NB: typeSize does not respect `eqType`, in that two types that +-- are `eqType` may return different sizes. This is OK, because this +-- function is used only in reporting, not decision-making. + +typeSize :: Type -> Int +typeSize (LitTy {}) = 1 +typeSize (TyVarTy {}) = 1 +typeSize (AppTy t1 t2) = typeSize t1 + typeSize t2 +typeSize (FunTy _ t1 t2) = typeSize t1 + typeSize t2 +typeSize (ForAllTy (Bndr tv _) t) = typeSize (varType tv) + typeSize t +typeSize (TyConApp _ ts) = 1 + sum (map typeSize ts) +typeSize (CastTy ty co) = typeSize ty + coercionSize co +typeSize (CoercionTy co) = coercionSize co + +coercionSize :: Coercion -> Int +coercionSize (Refl ty) = typeSize ty +coercionSize (GRefl _ ty MRefl) = typeSize ty +coercionSize (GRefl _ ty (MCo co)) = 1 + typeSize ty + coercionSize co +coercionSize (TyConAppCo _ _ args) = 1 + sum (map coercionSize args) +coercionSize (AppCo co arg) = coercionSize co + coercionSize arg +coercionSize (ForAllCo _ h co) = 1 + coercionSize co + coercionSize h +coercionSize (FunCo _ co1 co2) = 1 + coercionSize co1 + coercionSize co2 +coercionSize (CoVarCo _) = 1 +coercionSize (HoleCo _) = 1 +coercionSize (AxiomInstCo _ _ args) = 1 + sum (map coercionSize args) +coercionSize (UnivCo p _ t1 t2) = 1 + provSize p + typeSize t1 + typeSize t2 +coercionSize (SymCo co) = 1 + coercionSize co +coercionSize (TransCo co1 co2) = 1 + coercionSize co1 + coercionSize co2 +coercionSize (NthCo _ _ co) = 1 + coercionSize co +coercionSize (LRCo _ co) = 1 + coercionSize co +coercionSize (InstCo co arg) = 1 + coercionSize co + coercionSize arg +coercionSize (KindCo co) = 1 + coercionSize co +coercionSize (SubCo co) = 1 + coercionSize co +coercionSize (AxiomRuleCo _ cs) = 1 + sum (map coercionSize cs) + +provSize :: UnivCoProvenance -> Int +provSize UnsafeCoerceProv = 1 +provSize (PhantomProv co) = 1 + coercionSize co +provSize (ProofIrrelProv co) = 1 + coercionSize co +provSize (PluginProv _) = 1 diff --git a/compiler/types/TyCoRep.hs-boot b/compiler/types/TyCoRep.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/types/TyCoRep.hs-boot @@ -0,0 +1,31 @@ +module TyCoRep where + +import GhcPrelude + +import Outputable ( SDoc ) +import Data.Data ( Data ) +import {-# SOURCE #-} Var( Var, ArgFlag, AnonArgFlag ) + +data Type +data TyThing +data Coercion +data UnivCoProvenance +data TCvSubst +data TyLit +data TyCoBinder +data MCoercion + +type PredType = Type +type Kind = Type +type ThetaType = [PredType] +type CoercionN = Coercion +type MCoercionN = MCoercion + +pprKind :: Kind -> SDoc +pprType :: Type -> SDoc +mkFunTy :: AnonArgFlag -> Type -> Type -> Type +mkForAllTy :: Var -> ArgFlag -> Type -> Type + +isRuntimeRepTy :: Type -> Bool + +instance Data Type -- To support Data instances in CoAxiom diff --git a/compiler/types/TyCon.hs b/compiler/types/TyCon.hs new file mode 100644 --- /dev/null +++ b/compiler/types/TyCon.hs @@ -0,0 +1,2732 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +The @TyCon@ datatype +-} + +{-# LANGUAGE CPP, FlexibleInstances #-} + +module TyCon( + -- * Main TyCon data types + TyCon, + AlgTyConRhs(..), visibleDataCons, + AlgTyConFlav(..), isNoParent, + FamTyConFlav(..), Role(..), Injectivity(..), + RuntimeRepInfo(..), TyConFlavour(..), + + -- * TyConBinder + TyConBinder, TyConBndrVis(..), TyConTyCoBinder, + mkNamedTyConBinder, mkNamedTyConBinders, + mkRequiredTyConBinder, + mkAnonTyConBinder, mkAnonTyConBinders, + tyConBinderArgFlag, tyConBndrVisArgFlag, isNamedTyConBinder, + isVisibleTyConBinder, isInvisibleTyConBinder, + + -- ** Field labels + tyConFieldLabels, lookupTyConFieldLabel, + + -- ** Constructing TyCons + mkAlgTyCon, + mkClassTyCon, + mkFunTyCon, + mkPrimTyCon, + mkKindTyCon, + mkLiftedPrimTyCon, + mkTupleTyCon, + mkSumTyCon, + mkDataTyConRhs, + mkSynonymTyCon, + mkFamilyTyCon, + mkPromotedDataCon, + mkTcTyCon, + + -- ** Predicates on TyCons + isAlgTyCon, isVanillaAlgTyCon, + isClassTyCon, isFamInstTyCon, + isFunTyCon, + isPrimTyCon, + isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, + isUnboxedSumTyCon, isPromotedTupleTyCon, + isTypeSynonymTyCon, + mustBeSaturated, + isPromotedDataCon, isPromotedDataCon_maybe, + isKindTyCon, isLiftedTypeKindTyConName, + isTauTyCon, isFamFreeTyCon, + + isDataTyCon, isProductTyCon, isDataProductTyCon_maybe, + isDataSumTyCon_maybe, + isEnumerationTyCon, + isNewTyCon, isAbstractTyCon, + isFamilyTyCon, isOpenFamilyTyCon, + isTypeFamilyTyCon, isDataFamilyTyCon, + isOpenTypeFamilyTyCon, isClosedSynFamilyTyConWithAxiom_maybe, + tyConInjectivityInfo, + isBuiltInSynFamTyCon_maybe, + isUnliftedTyCon, + isGadtSyntaxTyCon, isInjectiveTyCon, isGenerativeTyCon, isGenInjAlgRhs, + isTyConAssoc, tyConAssoc_maybe, tyConFlavourAssoc_maybe, + isImplicitTyCon, + isTyConWithSrcDataCons, + isTcTyCon, setTcTyConKind, + isTcLevPoly, + + -- ** Extracting information out of TyCons + tyConName, + tyConSkolem, + tyConKind, + tyConUnique, + tyConTyVars, tyConVisibleTyVars, + tyConCType, tyConCType_maybe, + tyConDataCons, tyConDataCons_maybe, + tyConSingleDataCon_maybe, tyConSingleDataCon, + tyConSingleAlgDataCon_maybe, + tyConFamilySize, + tyConStupidTheta, + tyConArity, + tyConRoles, + tyConFlavour, + tyConTuple_maybe, tyConClass_maybe, tyConATs, + tyConFamInst_maybe, tyConFamInstSig_maybe, tyConFamilyCoercion_maybe, + tyConFamilyResVar_maybe, + synTyConDefn_maybe, synTyConRhs_maybe, + famTyConFlav_maybe, famTcResVar, + algTyConRhs, + newTyConRhs, newTyConEtadArity, newTyConEtadRhs, + unwrapNewTyCon_maybe, unwrapNewTyConEtad_maybe, + newTyConDataCon_maybe, + algTcFields, + tyConRuntimeRepInfo, + tyConBinders, tyConResKind, tyConTyVarBinders, + tcTyConScopedTyVars, tcTyConIsPoly, + mkTyConTagMap, + + -- ** Manipulating TyCons + expandSynTyCon_maybe, + newTyConCo, newTyConCo_maybe, + pprPromotionQuote, mkTyConKind, + + -- ** Predicated on TyConFlavours + tcFlavourIsOpen, + + -- * Runtime type representation + TyConRepName, tyConRepName_maybe, + mkPrelTyConRepName, + tyConRepModOcc, + + -- * Primitive representations of Types + PrimRep(..), PrimElemRep(..), + isVoidRep, isGcPtrRep, + primRepSizeB, + primElemRepSizeB, + primRepIsFloat, + + -- * Recursion breaking + RecTcChecker, initRecTc, defaultRecTcMaxBound, + setRecTcMaxBound, checkRecTc + +) where + +#include "HsVersions.h" + +import GhcPrelude + +import {-# SOURCE #-} TyCoRep ( Kind, Type, PredType, pprType, mkForAllTy, mkFunTy ) +import {-# SOURCE #-} TysWiredIn ( runtimeRepTyCon, constraintKind + , vecCountTyCon, vecElemTyCon, liftedTypeKind ) +import {-# SOURCE #-} DataCon ( DataCon, dataConExTyCoVars, dataConFieldLabels + , dataConTyCon, dataConFullSig + , isUnboxedSumCon ) + +import Binary +import Var +import VarSet +import Class +import BasicTypes +import DynFlags +import ForeignCall +import Name +import NameEnv +import CoAxiom +import PrelNames +import Maybes +import Outputable +import FastStringEnv +import FieldLabel +import Constants +import Util +import Unique( tyConRepNameUnique, dataConTyRepNameUnique ) +import UniqSet +import Module + +import qualified Data.Data as Data + +{- +----------------------------------------------- + Notes about type families +----------------------------------------------- + +Note [Type synonym families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Type synonym families, also known as "type functions", map directly + onto the type functions in FC: + + type family F a :: * + type instance F Int = Bool + ..etc... + +* Reply "yes" to isTypeFamilyTyCon, and isFamilyTyCon + +* From the user's point of view (F Int) and Bool are simply + equivalent types. + +* A Haskell 98 type synonym is a degenerate form of a type synonym + family. + +* Type functions can't appear in the LHS of a type function: + type instance F (F Int) = ... -- BAD! + +* Translation of type family decl: + type family F a :: * + translates to + a FamilyTyCon 'F', whose FamTyConFlav is OpenSynFamilyTyCon + + type family G a :: * where + G Int = Bool + G Bool = Char + G a = () + translates to + a FamilyTyCon 'G', whose FamTyConFlav is ClosedSynFamilyTyCon, with the + appropriate CoAxiom representing the equations + +We also support injective type families -- see Note [Injective type families] + +Note [Data type families] +~~~~~~~~~~~~~~~~~~~~~~~~~ +See also Note [Wrappers for data instance tycons] in MkId.hs + +* Data type families are declared thus + data family T a :: * + data instance T Int = T1 | T2 Bool + + Here T is the "family TyCon". + +* Reply "yes" to isDataFamilyTyCon, and isFamilyTyCon + +* The user does not see any "equivalent types" as he did with type + synonym families. He just sees constructors with types + T1 :: T Int + T2 :: Bool -> T Int + +* Here's the FC version of the above declarations: + + data T a + data R:TInt = T1 | T2 Bool + axiom ax_ti : T Int ~R R:TInt + + Note that this is a *representational* coercion + The R:TInt is the "representation TyCons". + It has an AlgTyConFlav of + DataFamInstTyCon T [Int] ax_ti + +* The axiom ax_ti may be eta-reduced; see + Note [Eta reduction for data families] in FamInstEnv + +* Data family instances may have a different arity than the data family. + See Note [Arity of data families] in FamInstEnv + +* The data constructor T2 has a wrapper (which is what the + source-level "T2" invokes): + + $WT2 :: Bool -> T Int + $WT2 b = T2 b `cast` sym ax_ti + +* A data instance can declare a fully-fledged GADT: + + data instance T (a,b) where + X1 :: T (Int,Bool) + X2 :: a -> b -> T (a,b) + + Here's the FC version of the above declaration: + + data R:TPair a b where + X1 :: R:TPair Int Bool + X2 :: a -> b -> R:TPair a b + axiom ax_pr :: T (a,b) ~R R:TPair a b + + $WX1 :: forall a b. a -> b -> T (a,b) + $WX1 a b (x::a) (y::b) = X2 a b x y `cast` sym (ax_pr a b) + + The R:TPair are the "representation TyCons". + We have a bit of work to do, to unpick the result types of the + data instance declaration for T (a,b), to get the result type in the + representation; e.g. T (a,b) --> R:TPair a b + + The representation TyCon R:TList, has an AlgTyConFlav of + + DataFamInstTyCon T [(a,b)] ax_pr + +* Notice that T is NOT translated to a FC type function; it just + becomes a "data type" with no constructors, which can be coerced + into R:TInt, R:TPair by the axioms. These axioms + axioms come into play when (and *only* when) you + - use a data constructor + - do pattern matching + Rather like newtype, in fact + + As a result + + - T behaves just like a data type so far as decomposition is concerned + + - (T Int) is not implicitly converted to R:TInt during type inference. + Indeed the latter type is unknown to the programmer. + + - There *is* an instance for (T Int) in the type-family instance + environment, but it is only used for overlap checking + + - It's fine to have T in the LHS of a type function: + type instance F (T a) = [a] + + It was this last point that confused me! The big thing is that you + should not think of a data family T as a *type function* at all, not + even an injective one! We can't allow even injective type functions + on the LHS of a type function: + type family injective G a :: * + type instance F (G Int) = Bool + is no good, even if G is injective, because consider + type instance G Int = Bool + type instance F Bool = Char + + So a data type family is not an injective type function. It's just a + data type with some axioms that connect it to other data types. + +* The tyConTyVars of the representation tycon are the tyvars that the + user wrote in the patterns. This is important in TcDeriv, where we + bring these tyvars into scope before type-checking the deriving + clause. This fact is arranged for in TcInstDecls.tcDataFamInstDecl. + +Note [Associated families and their parent class] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +*Associated* families are just like *non-associated* families, except +that they have a famTcParent field of (Just cls_tc), which identifies the +parent class. + +However there is an important sharing relationship between + * the tyConTyVars of the parent Class + * the tyConTyVars of the associated TyCon + + class C a b where + data T p a + type F a q b + +Here the 'a' and 'b' are shared with the 'Class'; that is, they have +the same Unique. + +This is important. In an instance declaration we expect + * all the shared variables to be instantiated the same way + * the non-shared variables of the associated type should not + be instantiated at all + + instance C [x] (Tree y) where + data T p [x] = T1 x | T2 p + type F [x] q (Tree y) = (x,y,q) + +Note [TyCon Role signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Every tycon has a role signature, assigning a role to each of the tyConTyVars +(or of equal length to the tyConArity, if there are no tyConTyVars). An +example demonstrates these best: say we have a tycon T, with parameters a at +nominal, b at representational, and c at phantom. Then, to prove +representational equality between T a1 b1 c1 and T a2 b2 c2, we need to have +nominal equality between a1 and a2, representational equality between b1 and +b2, and nothing in particular (i.e., phantom equality) between c1 and c2. This +might happen, say, with the following declaration: + + data T a b c where + MkT :: b -> T Int b c + +Data and class tycons have their roles inferred (see inferRoles in TcTyDecls), +as do vanilla synonym tycons. Family tycons have all parameters at role N, +though it is conceivable that we could relax this restriction. (->)'s and +tuples' parameters are at role R. Each primitive tycon declares its roles; +it's worth noting that (~#)'s parameters are at role N. Promoted data +constructors' type arguments are at role R. All kind arguments are at role +N. + +Note [Unboxed tuple RuntimeRep vars] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The contents of an unboxed tuple may have any representation. Accordingly, +the kind of the unboxed tuple constructor is runtime-representation +polymorphic. For example, + + (#,#) :: forall (q :: RuntimeRep) (r :: RuntimeRep). TYPE q -> TYPE r -> # + +These extra tyvars (v and w) cause some delicate processing around tuples, +where we used to be able to assume that the tycon arity and the +datacon arity were the same. + +Note [Injective type families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We allow injectivity annotations for type families (both open and closed): + + type family F (a :: k) (b :: k) = r | r -> a + type family G a b = res | res -> a b where ... + +Injectivity information is stored in the `famTcInj` field of `FamilyTyCon`. +`famTcInj` maybe stores a list of Bools, where each entry corresponds to a +single element of `tyConTyVars` (both lists should have identical length). If no +injectivity annotation was provided `famTcInj` is Nothing. From this follows an +invariant that if `famTcInj` is a Just then at least one element in the list +must be True. + +See also: + * [Injectivity annotation] in HsDecls + * [Renaming injectivity annotation] in RnSource + * [Verifying injectivity annotation] in FamInstEnv + * [Type inference for type families with injectivity] in TcInteract + +************************************************************************ +* * + TyConBinder, TyConTyCoBinder +* * +************************************************************************ +-} + +type TyConBinder = VarBndr TyVar TyConBndrVis + +-- In the whole definition of @data TyCon@, only @PromotedDataCon@ will really +-- contain CoVar. +type TyConTyCoBinder = VarBndr TyCoVar TyConBndrVis + +data TyConBndrVis + = NamedTCB ArgFlag + | AnonTCB AnonArgFlag + +instance Outputable TyConBndrVis where + ppr (NamedTCB flag) = text "NamedTCB" <> ppr flag + ppr (AnonTCB af) = text "AnonTCB" <> ppr af + +mkAnonTyConBinder :: AnonArgFlag -> TyVar -> TyConBinder +mkAnonTyConBinder af tv = ASSERT( isTyVar tv) + Bndr tv (AnonTCB af) + +mkAnonTyConBinders :: AnonArgFlag -> [TyVar] -> [TyConBinder] +mkAnonTyConBinders af tvs = map (mkAnonTyConBinder af) tvs + +mkNamedTyConBinder :: ArgFlag -> TyVar -> TyConBinder +-- The odd argument order supports currying +mkNamedTyConBinder vis tv = ASSERT( isTyVar tv ) + Bndr tv (NamedTCB vis) + +mkNamedTyConBinders :: ArgFlag -> [TyVar] -> [TyConBinder] +-- The odd argument order supports currying +mkNamedTyConBinders vis tvs = map (mkNamedTyConBinder vis) tvs + +-- | Make a Required TyConBinder. It chooses between NamedTCB and +-- AnonTCB based on whether the tv is mentioned in the dependent set +mkRequiredTyConBinder :: TyCoVarSet -- these are used dependently + -> TyVar + -> TyConBinder +mkRequiredTyConBinder dep_set tv + | tv `elemVarSet` dep_set = mkNamedTyConBinder Required tv + | otherwise = mkAnonTyConBinder VisArg tv + +tyConBinderArgFlag :: TyConBinder -> ArgFlag +tyConBinderArgFlag (Bndr _ vis) = tyConBndrVisArgFlag vis + +tyConBndrVisArgFlag :: TyConBndrVis -> ArgFlag +tyConBndrVisArgFlag (NamedTCB vis) = vis +tyConBndrVisArgFlag (AnonTCB VisArg) = Required +tyConBndrVisArgFlag (AnonTCB InvisArg) = Inferred -- See Note [AnonTCB InvisArg] + +isNamedTyConBinder :: TyConBinder -> Bool +-- Identifies kind variables +-- E.g. data T k (a:k) = blah +-- Here 'k' is a NamedTCB, a variable used in the kind of other binders +isNamedTyConBinder (Bndr _ (NamedTCB {})) = True +isNamedTyConBinder _ = False + +isVisibleTyConBinder :: VarBndr tv TyConBndrVis -> Bool +-- Works for IfaceTyConBinder too +isVisibleTyConBinder (Bndr _ tcb_vis) = isVisibleTcbVis tcb_vis + +isVisibleTcbVis :: TyConBndrVis -> Bool +isVisibleTcbVis (NamedTCB vis) = isVisibleArgFlag vis +isVisibleTcbVis (AnonTCB VisArg) = True +isVisibleTcbVis (AnonTCB InvisArg) = False + +isInvisibleTyConBinder :: VarBndr tv TyConBndrVis -> Bool +-- Works for IfaceTyConBinder too +isInvisibleTyConBinder tcb = not (isVisibleTyConBinder tcb) + +mkTyConKind :: [TyConBinder] -> Kind -> Kind +mkTyConKind bndrs res_kind = foldr mk res_kind bndrs + where + mk :: TyConBinder -> Kind -> Kind + mk (Bndr tv (AnonTCB af)) k = mkFunTy af (varType tv) k + mk (Bndr tv (NamedTCB vis)) k = mkForAllTy tv vis k + +tyConTyVarBinders :: [TyConBinder] -- From the TyCon + -> [TyVarBinder] -- Suitable for the foralls of a term function +-- See Note [Building TyVarBinders from TyConBinders] +tyConTyVarBinders tc_bndrs + = map mk_binder tc_bndrs + where + mk_binder (Bndr tv tc_vis) = mkTyVarBinder vis tv + where + vis = case tc_vis of + AnonTCB VisArg -> Specified + AnonTCB InvisArg -> Inferred -- See Note [AnonTCB InvisArg] + NamedTCB Required -> Specified + NamedTCB vis -> vis + +-- Returns only tyvars, as covars are always inferred +tyConVisibleTyVars :: TyCon -> [TyVar] +tyConVisibleTyVars tc + = [ tv | Bndr tv vis <- tyConBinders tc + , isVisibleTcbVis vis ] + +{- Note [AnonTCB InivsArg] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's pretty rare to have an (AnonTCB InvisArg) binder. The +only way it can occur is in a PromotedDataCon whose +kind has an equality constraint: + 'MkT :: forall a b. (a~b) => blah +See Note [Constraints in kinds] in TyCoRep, and +Note [Promoted data constructors] in this module. + +When mapping an (AnonTCB InvisArg) to an ArgFlag, in +tyConBndrVisArgFlag, we use "Inferred" to mean "the user cannot +specify this arguments, even with visible type/kind application; +instead the type checker must fill it in. + +We map (AnonTCB VisArg) to Required, of course: the user must +provide it. It would be utterly wrong to do this for constraint +arguments, which is why AnonTCB must have the AnonArgFlag in +the first place. + +Note [Building TyVarBinders from TyConBinders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We sometimes need to build the quantified type of a value from +the TyConBinders of a type or class. For that we need not +TyConBinders but TyVarBinders (used in forall-type) E.g: + + * From data T a = MkT (Maybe a) + we are going to make a data constructor with type + MkT :: forall a. Maybe a -> T a + See the TyCoVarBinders passed to buildDataCon + + * From class C a where { op :: a -> Maybe a } + we are going to make a default method + $dmop :: forall a. C a => a -> Maybe a + See the TyCoVarBinders passed to mkSigmaTy in mkDefaultMethodType + +Both of these are user-callable. (NB: default methods are not callable +directly by the user but rather via the code generated by 'deriving', +which uses visible type application; see mkDefMethBind.) + +Since they are user-callable we must get their type-argument visibility +information right; and that info is in the TyConBinders. +Here is an example: + + data App a b = MkApp (a b) -- App :: forall {k}. (k->*) -> k -> * + +The TyCon has + + tyConTyBinders = [ Named (Bndr (k :: *) Inferred), Anon (k->*), Anon k ] + +The TyConBinders for App line up with App's kind, given above. + +But the DataCon MkApp has the type + MkApp :: forall {k} (a:k->*) (b:k). a b -> App k a b + +That is, its TyCoVarBinders should be + + dataConUnivTyVarBinders = [ Bndr (k:*) Inferred + , Bndr (a:k->*) Specified + , Bndr (b:k) Specified ] + +So tyConTyVarBinders converts TyCon's TyConBinders into TyVarBinders: + - variable names from the TyConBinders + - but changing Anon/Required to Specified + +The last part about Required->Specified comes from this: + data T k (a:k) b = MkT (a b) +Here k is Required in T's kind, but we don't have Required binders in +the TyCoBinders for a term (see Note [No Required TyCoBinder in terms] +in TyCoRep), so we change it to Specified when making MkT's TyCoBinders +-} + + +{- Note [The binders/kind/arity fields of a TyCon] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +All TyCons have this group of fields + tyConBinders :: [TyConBinder/TyConTyCoBinder] + tyConResKind :: Kind + tyConTyVars :: [TyVar] -- Cached = binderVars tyConBinders + -- NB: Currently (Aug 2018), TyCons that own this + -- field really only contain TyVars. So it is + -- [TyVar] instead of [TyCoVar]. + tyConKind :: Kind -- Cached = mkTyConKind tyConBinders tyConResKind + tyConArity :: Arity -- Cached = length tyConBinders + +They fit together like so: + +* tyConBinders gives the telescope of type/coercion variables on the LHS of the + type declaration. For example: + + type App a (b :: k) = a b + + tyConBinders = [ Bndr (k::*) (NamedTCB Inferred) + , Bndr (a:k->*) AnonTCB + , Bndr (b:k) AnonTCB ] + + Note that that are three binders here, including the + kind variable k. + +* See Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep + for what the visibility flag means. + +* Each TyConBinder tyConBinders has a TyVar (sometimes it is TyCoVar), and + that TyVar may scope over some other part of the TyCon's definition. Eg + type T a = a -> a + we have + tyConBinders = [ Bndr (a:*) AnonTCB ] + synTcRhs = a -> a + So the 'a' scopes over the synTcRhs + +* From the tyConBinders and tyConResKind we can get the tyConKind + E.g for our App example: + App :: forall k. (k->*) -> k -> * + + We get a 'forall' in the kind for each NamedTCB, and an arrow + for each AnonTCB + + tyConKind is the full kind of the TyCon, not just the result kind + +* For type families, tyConArity is the arguments this TyCon must be + applied to, to be considered saturated. Here we mean "applied to in + the actual Type", not surface syntax; i.e. including implicit kind + variables. So it's just (length tyConBinders) + +* For an algebraic data type, or data instance, the tyConResKind is + always (TYPE r); that is, the tyConBinders are enough to saturate + the type constructor. I'm not quite sure why we have this invariant, + but it's enforced by etaExpandAlgTyCon +-} + +instance Outputable tv => Outputable (VarBndr tv TyConBndrVis) where + ppr (Bndr v bi) = ppr_bi bi <+> parens (ppr v) + where + ppr_bi (AnonTCB VisArg) = text "anon-vis" + ppr_bi (AnonTCB InvisArg) = text "anon-invis" + ppr_bi (NamedTCB Required) = text "req" + ppr_bi (NamedTCB Specified) = text "spec" + ppr_bi (NamedTCB Inferred) = text "inf" + +instance Binary TyConBndrVis where + put_ bh (AnonTCB af) = do { putByte bh 0; put_ bh af } + put_ bh (NamedTCB vis) = do { putByte bh 1; put_ bh vis } + + get bh = do { h <- getByte bh + ; case h of + 0 -> do { af <- get bh; return (AnonTCB af) } + _ -> do { vis <- get bh; return (NamedTCB vis) } } + + +{- ********************************************************************* +* * + The TyCon type +* * +************************************************************************ +-} + + +-- | TyCons represent type constructors. Type constructors are introduced by +-- things such as: +-- +-- 1) Data declarations: @data Foo = ...@ creates the @Foo@ type constructor of +-- kind @*@ +-- +-- 2) Type synonyms: @type Foo = ...@ creates the @Foo@ type constructor +-- +-- 3) Newtypes: @newtype Foo a = MkFoo ...@ creates the @Foo@ type constructor +-- of kind @* -> *@ +-- +-- 4) Class declarations: @class Foo where@ creates the @Foo@ type constructor +-- of kind @*@ +-- +-- This data type also encodes a number of primitive, built in type constructors +-- such as those for function and tuple types. + +-- If you edit this type, you may need to update the GHC formalism +-- See Note [GHC Formalism] in coreSyn/CoreLint.hs +data TyCon + = -- | The function type constructor, @(->)@ + FunTyCon { + tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: + -- identical to Unique of Name stored in + -- tyConName field. + + tyConName :: Name, -- ^ Name of the constructor + + -- See Note [The binders/kind/arity fields of a TyCon] + tyConBinders :: [TyConBinder], -- ^ Full binders + tyConResKind :: Kind, -- ^ Result kind + tyConKind :: Kind, -- ^ Kind of this TyCon + tyConArity :: Arity, -- ^ Arity + + tcRepName :: TyConRepName + } + + -- | Algebraic data types, from + -- - @data@ declarations + -- - @newtype@ declarations + -- - data instance declarations + -- - type instance declarations + -- - the TyCon generated by a class declaration + -- - boxed tuples + -- - unboxed tuples + -- - constraint tuples + -- All these constructors are lifted and boxed except unboxed tuples + -- which should have an 'UnboxedAlgTyCon' parent. + -- Data/newtype/type /families/ are handled by 'FamilyTyCon'. + -- See 'AlgTyConRhs' for more information. + | AlgTyCon { + tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: + -- identical to Unique of Name stored in + -- tyConName field. + + tyConName :: Name, -- ^ Name of the constructor + + -- See Note [The binders/kind/arity fields of a TyCon] + tyConBinders :: [TyConBinder], -- ^ Full binders + tyConTyVars :: [TyVar], -- ^ TyVar binders + tyConResKind :: Kind, -- ^ Result kind + tyConKind :: Kind, -- ^ Kind of this TyCon + tyConArity :: Arity, -- ^ Arity + + -- The tyConTyVars scope over: + -- + -- 1. The 'algTcStupidTheta' + -- 2. The cached types in algTyConRhs.NewTyCon + -- 3. The family instance types if present + -- + -- Note that it does /not/ scope over the data + -- constructors. + + tcRoles :: [Role], -- ^ The role for each type variable + -- This list has length = tyConArity + -- See also Note [TyCon Role signatures] + + tyConCType :: Maybe CType,-- ^ The C type that should be used + -- for this type when using the FFI + -- and CAPI + + algTcGadtSyntax :: Bool, -- ^ Was the data type declared with GADT + -- syntax? If so, that doesn't mean it's a + -- true GADT; only that the "where" form + -- was used. This field is used only to + -- guide pretty-printing + + algTcStupidTheta :: [PredType], -- ^ The \"stupid theta\" for the data + -- type (always empty for GADTs). A + -- \"stupid theta\" is the context to + -- the left of an algebraic type + -- declaration, e.g. @Eq a@ in the + -- declaration @data Eq a => T a ...@. + + algTcRhs :: AlgTyConRhs, -- ^ Contains information about the + -- data constructors of the algebraic type + + algTcFields :: FieldLabelEnv, -- ^ Maps a label to information + -- about the field + + algTcParent :: AlgTyConFlav -- ^ Gives the class or family declaration + -- 'TyCon' for derived 'TyCon's representing + -- class or family instances, respectively. + + } + + -- | Represents type synonyms + | SynonymTyCon { + tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: + -- identical to Unique of Name stored in + -- tyConName field. + + tyConName :: Name, -- ^ Name of the constructor + + -- See Note [The binders/kind/arity fields of a TyCon] + tyConBinders :: [TyConBinder], -- ^ Full binders + tyConTyVars :: [TyVar], -- ^ TyVar binders + tyConResKind :: Kind, -- ^ Result kind + tyConKind :: Kind, -- ^ Kind of this TyCon + tyConArity :: Arity, -- ^ Arity + -- tyConTyVars scope over: synTcRhs + + tcRoles :: [Role], -- ^ The role for each type variable + -- This list has length = tyConArity + -- See also Note [TyCon Role signatures] + + synTcRhs :: Type, -- ^ Contains information about the expansion + -- of the synonym + + synIsTau :: Bool, -- True <=> the RHS of this synonym does not + -- have any foralls, after expanding any + -- nested synonyms + synIsFamFree :: Bool -- True <=> the RHS of this synonym does not mention + -- any type synonym families (data families + -- are fine), again after expanding any + -- nested synonyms + } + + -- | Represents families (both type and data) + -- Argument roles are all Nominal + | FamilyTyCon { + tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: + -- identical to Unique of Name stored in + -- tyConName field. + + tyConName :: Name, -- ^ Name of the constructor + + -- See Note [The binders/kind/arity fields of a TyCon] + tyConBinders :: [TyConBinder], -- ^ Full binders + tyConTyVars :: [TyVar], -- ^ TyVar binders + tyConResKind :: Kind, -- ^ Result kind + tyConKind :: Kind, -- ^ Kind of this TyCon + tyConArity :: Arity, -- ^ Arity + -- tyConTyVars connect an associated family TyCon + -- with its parent class; see TcValidity.checkConsistentFamInst + + famTcResVar :: Maybe Name, -- ^ Name of result type variable, used + -- for pretty-printing with --show-iface + -- and for reifying TyCon in Template + -- Haskell + + famTcFlav :: FamTyConFlav, -- ^ Type family flavour: open, closed, + -- abstract, built-in. See comments for + -- FamTyConFlav + + famTcParent :: Maybe TyCon, -- ^ For *associated* type/data families + -- The class tycon in which the family is declared + -- See Note [Associated families and their parent class] + + famTcInj :: Injectivity -- ^ is this a type family injective in + -- its type variables? Nothing if no + -- injectivity annotation was given + } + + -- | Primitive types; cannot be defined in Haskell. This includes + -- the usual suspects (such as @Int#@) as well as foreign-imported + -- types and kinds (@*@, @#@, and @?@) + | PrimTyCon { + tyConUnique :: Unique, -- ^ A Unique of this TyCon. Invariant: + -- identical to Unique of Name stored in + -- tyConName field. + + tyConName :: Name, -- ^ Name of the constructor + + -- See Note [The binders/kind/arity fields of a TyCon] + tyConBinders :: [TyConBinder], -- ^ Full binders + tyConResKind :: Kind, -- ^ Result kind + tyConKind :: Kind, -- ^ Kind of this TyCon + tyConArity :: Arity, -- ^ Arity + + tcRoles :: [Role], -- ^ The role for each type variable + -- This list has length = tyConArity + -- See also Note [TyCon Role signatures] + + isUnlifted :: Bool, -- ^ Most primitive tycons are unlifted (may + -- not contain bottom) but other are lifted, + -- e.g. @RealWorld@ + -- Only relevant if tyConKind = * + + primRepName :: Maybe TyConRepName -- Only relevant for kind TyCons + -- i.e, *, #, ? + } + + -- | Represents promoted data constructor. + | PromotedDataCon { -- See Note [Promoted data constructors] + tyConUnique :: Unique, -- ^ Same Unique as the data constructor + tyConName :: Name, -- ^ Same Name as the data constructor + + -- See Note [The binders/kind/arity fields of a TyCon] + tyConBinders :: [TyConTyCoBinder], -- ^ Full binders + tyConResKind :: Kind, -- ^ Result kind + tyConKind :: Kind, -- ^ Kind of this TyCon + tyConArity :: Arity, -- ^ Arity + + tcRoles :: [Role], -- ^ Roles: N for kind vars, R for type vars + dataCon :: DataCon, -- ^ Corresponding data constructor + tcRepName :: TyConRepName, + promDcRepInfo :: RuntimeRepInfo -- ^ See comments with 'RuntimeRepInfo' + } + + -- | These exist only during type-checking. See Note [How TcTyCons work] + -- in TcTyClsDecls + | TcTyCon { + tyConUnique :: Unique, + tyConName :: Name, + + -- See Note [The binders/kind/arity fields of a TyCon] + tyConBinders :: [TyConBinder], -- ^ Full binders + tyConTyVars :: [TyVar], -- ^ TyVar binders + tyConResKind :: Kind, -- ^ Result kind + tyConKind :: Kind, -- ^ Kind of this TyCon + tyConArity :: Arity, -- ^ Arity + + -- NB: the TyConArity of a TcTyCon must match + -- the number of Required (positional, user-specified) + -- arguments to the type constructor; see the use + -- of tyConArity in generaliseTcTyCon + + tcTyConScopedTyVars :: [(Name,TyVar)], + -- ^ Scoped tyvars over the tycon's body + -- See Note [Scoped tyvars in a TcTyCon] + + tcTyConIsPoly :: Bool, -- ^ Is this TcTyCon already generalized? + + tcTyConFlavour :: TyConFlavour + -- ^ What sort of 'TyCon' this represents. + } +{- Note [Scoped tyvars in a TcTyCon] + +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The tcTyConScopedTyVars field records the lexicial-binding connection +between the original, user-specified Name (i.e. thing in scope) and +the TcTyVar that the Name is bound to. + +Order *does* matter; the tcTyConScopedTyvars list consists of + specified_tvs ++ required_tvs + +where + * specified ones first + * required_tvs the same as tyConTyVars + * tyConArity = length required_tvs + +See also Note [How TcTyCons work] in TcTyClsDecls +-} + +-- | Represents right-hand-sides of 'TyCon's for algebraic types +data AlgTyConRhs + + -- | Says that we know nothing about this data type, except that + -- it's represented by a pointer. Used when we export a data type + -- abstractly into an .hi file. + = AbstractTyCon + + -- | Information about those 'TyCon's derived from a @data@ + -- declaration. This includes data types with no constructors at + -- all. + | DataTyCon { + data_cons :: [DataCon], + -- ^ The data type constructors; can be empty if the + -- user declares the type to have no constructors + -- + -- INVARIANT: Kept in order of increasing 'DataCon' + -- tag (see the tag assignment in mkTyConTagMap) + data_cons_size :: Int, + -- ^ Cached value: length data_cons + is_enum :: Bool -- ^ Cached value: is this an enumeration type? + -- See Note [Enumeration types] + } + + | TupleTyCon { -- A boxed, unboxed, or constraint tuple + data_con :: DataCon, -- NB: it can be an *unboxed* tuple + tup_sort :: TupleSort -- ^ Is this a boxed, unboxed or constraint + -- tuple? + } + + -- | An unboxed sum type. + | SumTyCon { + data_cons :: [DataCon], + data_cons_size :: Int -- ^ Cached value: length data_cons + } + + -- | Information about those 'TyCon's derived from a @newtype@ declaration + | NewTyCon { + data_con :: DataCon, -- ^ The unique constructor for the @newtype@. + -- It has no existentials + + nt_rhs :: Type, -- ^ Cached value: the argument type of the + -- constructor, which is just the representation + -- type of the 'TyCon' (remember that @newtype@s + -- do not exist at runtime so need a different + -- representation type). + -- + -- The free 'TyVar's of this type are the + -- 'tyConTyVars' from the corresponding 'TyCon' + + nt_etad_rhs :: ([TyVar], Type), + -- ^ Same as the 'nt_rhs', but this time eta-reduced. + -- Hence the list of 'TyVar's in this field may be + -- shorter than the declared arity of the 'TyCon'. + + -- See Note [Newtype eta] + nt_co :: CoAxiom Unbranched + -- The axiom coercion that creates the @newtype@ + -- from the representation 'Type'. + + -- See Note [Newtype coercions] + -- Invariant: arity = #tvs in nt_etad_rhs; + -- See Note [Newtype eta] + -- Watch out! If any newtypes become transparent + -- again check #1072. + } + +mkSumTyConRhs :: [DataCon] -> AlgTyConRhs +mkSumTyConRhs data_cons = SumTyCon data_cons (length data_cons) + +mkDataTyConRhs :: [DataCon] -> AlgTyConRhs +mkDataTyConRhs cons + = DataTyCon { + data_cons = cons, + data_cons_size = length cons, + is_enum = not (null cons) && all is_enum_con cons + -- See Note [Enumeration types] in TyCon + } + where + is_enum_con con + | (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res) + <- dataConFullSig con + = null ex_tvs && null eq_spec && null theta && null arg_tys + +-- | Some promoted datacons signify extra info relevant to GHC. For example, +-- the @IntRep@ constructor of @RuntimeRep@ corresponds to the 'IntRep' +-- constructor of 'PrimRep'. This data structure allows us to store this +-- information right in the 'TyCon'. The other approach would be to look +-- up things like @RuntimeRep@'s @PrimRep@ by known-key every time. +data RuntimeRepInfo + = NoRRI -- ^ an ordinary promoted data con + | RuntimeRep ([Type] -> [PrimRep]) + -- ^ A constructor of @RuntimeRep@. The argument to the function should + -- be the list of arguments to the promoted datacon. + | VecCount Int -- ^ A constructor of @VecCount@ + | VecElem PrimElemRep -- ^ A constructor of @VecElem@ + +-- | Extract those 'DataCon's that we are able to learn about. Note +-- that visibility in this sense does not correspond to visibility in +-- the context of any particular user program! +visibleDataCons :: AlgTyConRhs -> [DataCon] +visibleDataCons (AbstractTyCon {}) = [] +visibleDataCons (DataTyCon{ data_cons = cs }) = cs +visibleDataCons (NewTyCon{ data_con = c }) = [c] +visibleDataCons (TupleTyCon{ data_con = c }) = [c] +visibleDataCons (SumTyCon{ data_cons = cs }) = cs + +-- ^ Both type classes as well as family instances imply implicit +-- type constructors. These implicit type constructors refer to their parent +-- structure (ie, the class or family from which they derive) using a type of +-- the following form. +data AlgTyConFlav + = -- | An ordinary type constructor has no parent. + VanillaAlgTyCon + TyConRepName + + -- | An unboxed type constructor. The TyConRepName is a Maybe since we + -- currently don't allow unboxed sums to be Typeable since there are too + -- many of them. See #13276. + | UnboxedAlgTyCon + (Maybe TyConRepName) + + -- | Type constructors representing a class dictionary. + -- See Note [ATyCon for classes] in TyCoRep + | ClassTyCon + Class -- INVARIANT: the classTyCon of this Class is the + -- current tycon + TyConRepName + + -- | Type constructors representing an *instance* of a *data* family. + -- Parameters: + -- + -- 1) The type family in question + -- + -- 2) Instance types; free variables are the 'tyConTyVars' + -- of the current 'TyCon' (not the family one). INVARIANT: + -- the number of types matches the arity of the family 'TyCon' + -- + -- 3) A 'CoTyCon' identifying the representation + -- type with the type instance family + | DataFamInstTyCon -- See Note [Data type families] + (CoAxiom Unbranched) -- The coercion axiom. + -- A *Representational* coercion, + -- of kind T ty1 ty2 ~R R:T a b c + -- where T is the family TyCon, + -- and R:T is the representation TyCon (ie this one) + -- and a,b,c are the tyConTyVars of this TyCon + -- + -- BUT may be eta-reduced; see FamInstEnv + -- Note [Eta reduction for data families] + + -- Cached fields of the CoAxiom, but adjusted to + -- use the tyConTyVars of this TyCon + TyCon -- The family TyCon + [Type] -- Argument types (mentions the tyConTyVars of this TyCon) + -- No shorter in length than the tyConTyVars of the family TyCon + -- How could it be longer? See [Arity of data families] in FamInstEnv + + -- E.g. data instance T [a] = ... + -- gives a representation tycon: + -- data R:TList a = ... + -- axiom co a :: T [a] ~ R:TList a + -- with R:TList's algTcParent = DataFamInstTyCon T [a] co + +instance Outputable AlgTyConFlav where + ppr (VanillaAlgTyCon {}) = text "Vanilla ADT" + ppr (UnboxedAlgTyCon {}) = text "Unboxed ADT" + ppr (ClassTyCon cls _) = text "Class parent" <+> ppr cls + ppr (DataFamInstTyCon _ tc tys) = text "Family parent (family instance)" + <+> ppr tc <+> sep (map pprType tys) + +-- | Checks the invariants of a 'AlgTyConFlav' given the appropriate type class +-- name, if any +okParent :: Name -> AlgTyConFlav -> Bool +okParent _ (VanillaAlgTyCon {}) = True +okParent _ (UnboxedAlgTyCon {}) = True +okParent tc_name (ClassTyCon cls _) = tc_name == tyConName (classTyCon cls) +okParent _ (DataFamInstTyCon _ fam_tc tys) = tys `lengthAtLeast` tyConArity fam_tc + +isNoParent :: AlgTyConFlav -> Bool +isNoParent (VanillaAlgTyCon {}) = True +isNoParent _ = False + +-------------------- + +data Injectivity + = NotInjective + | Injective [Bool] -- 1-1 with tyConTyVars (incl kind vars) + deriving( Eq ) + +-- | Information pertaining to the expansion of a type synonym (@type@) +data FamTyConFlav + = -- | Represents an open type family without a fixed right hand + -- side. Additional instances can appear at any time. + -- + -- These are introduced by either a top level declaration: + -- + -- > data family T a :: * + -- + -- Or an associated data type declaration, within a class declaration: + -- + -- > class C a b where + -- > data T b :: * + DataFamilyTyCon + TyConRepName + + -- | An open type synonym family e.g. @type family F x y :: * -> *@ + | OpenSynFamilyTyCon + + -- | A closed type synonym family e.g. + -- @type family F x where { F Int = Bool }@ + | ClosedSynFamilyTyCon (Maybe (CoAxiom Branched)) + -- See Note [Closed type families] + + -- | A closed type synonym family declared in an hs-boot file with + -- type family F a where .. + | AbstractClosedSynFamilyTyCon + + -- | Built-in type family used by the TypeNats solver + | BuiltInSynFamTyCon BuiltInSynFamily + +instance Outputable FamTyConFlav where + ppr (DataFamilyTyCon n) = text "data family" <+> ppr n + ppr OpenSynFamilyTyCon = text "open type family" + ppr (ClosedSynFamilyTyCon Nothing) = text "closed type family" + ppr (ClosedSynFamilyTyCon (Just coax)) = text "closed type family" <+> ppr coax + ppr AbstractClosedSynFamilyTyCon = text "abstract closed type family" + ppr (BuiltInSynFamTyCon _) = text "built-in type family" + +{- Note [Closed type families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* In an open type family you can add new instances later. This is the + usual case. + +* In a closed type family you can only put equations where the family + is defined. + +A non-empty closed type family has a single axiom with multiple +branches, stored in the 'ClosedSynFamilyTyCon' constructor. A closed +type family with no equations does not have an axiom, because there is +nothing for the axiom to prove! + + +Note [Promoted data constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +All data constructors can be promoted to become a type constructor, +via the PromotedDataCon alternative in TyCon. + +* The TyCon promoted from a DataCon has the *same* Name and Unique as + the DataCon. Eg. If the data constructor Data.Maybe.Just(unique 78, + say) is promoted to a TyCon whose name is Data.Maybe.Just(unique 78) + +* We promote the *user* type of the DataCon. Eg + data T = MkT {-# UNPACK #-} !(Bool, Bool) + The promoted kind is + 'MkT :: (Bool,Bool) -> T + *not* + 'MkT :: Bool -> Bool -> T + +* Similarly for GADTs: + data G a where + MkG :: forall b. b -> G [b] + The promoted data constructor has kind + 'MkG :: forall b. b -> G [b] + *not* + 'MkG :: forall a b. (a ~# [b]) => b -> G a + +Note [Enumeration types] +~~~~~~~~~~~~~~~~~~~~~~~~ +We define datatypes with no constructors to *not* be +enumerations; this fixes trac #2578, Otherwise we +end up generating an empty table for + __closure_tbl +which is used by tagToEnum# to map Int# to constructors +in an enumeration. The empty table apparently upset +the linker. + +Moreover, all the data constructor must be enumerations, meaning +they have type (forall abc. T a b c). GADTs are not enumerations. +For example consider + data T a where + T1 :: T Int + T2 :: T Bool + T3 :: T a +What would [T1 ..] be? [T1,T3] :: T Int? Easiest thing is to exclude them. +See #4528. + +Note [Newtype coercions] +~~~~~~~~~~~~~~~~~~~~~~~~ +The NewTyCon field nt_co is a CoAxiom which is used for coercing from +the representation type of the newtype, to the newtype itself. For +example, + + newtype T a = MkT (a -> a) + +the NewTyCon for T will contain nt_co = CoT where CoT t : T t ~ t -> t. + +In the case that the right hand side is a type application +ending with the same type variables as the left hand side, we +"eta-contract" the coercion. So if we had + + newtype S a = MkT [a] + +then we would generate the arity 0 axiom CoS : S ~ []. The +primary reason we do this is to make newtype deriving cleaner. + +In the paper we'd write + axiom CoT : (forall t. T t) ~ (forall t. [t]) +and then when we used CoT at a particular type, s, we'd say + CoT @ s +which encodes as (TyConApp instCoercionTyCon [TyConApp CoT [], s]) + +Note [Newtype eta] +~~~~~~~~~~~~~~~~~~ +Consider + newtype Parser a = MkParser (IO a) deriving Monad +Are these two types equal (to Core)? + Monad Parser + Monad IO +which we need to make the derived instance for Monad Parser. + +Well, yes. But to see that easily we eta-reduce the RHS type of +Parser, in this case to ([], Froogle), so that even unsaturated applications +of Parser will work right. This eta reduction is done when the type +constructor is built, and cached in NewTyCon. + +Here's an example that I think showed up in practice +Source code: + newtype T a = MkT [a] + newtype Foo m = MkFoo (forall a. m a -> Int) + + w1 :: Foo [] + w1 = ... + + w2 :: Foo T + w2 = MkFoo (\(MkT x) -> case w1 of MkFoo f -> f x) + +After desugaring, and discarding the data constructors for the newtypes, +we get: + w2 = w1 `cast` Foo CoT +so the coercion tycon CoT must have + kind: T ~ [] + and arity: 0 + +This eta-reduction is implemented in BuildTyCl.mkNewTyConRhs. + + +************************************************************************ +* * + TyConRepName +* * +********************************************************************* -} + +type TyConRepName = Name -- The Name of the top-level declaration + -- $tcMaybe :: Data.Typeable.Internal.TyCon + -- $tcMaybe = TyCon { tyConName = "Maybe", ... } + +tyConRepName_maybe :: TyCon -> Maybe TyConRepName +tyConRepName_maybe (FunTyCon { tcRepName = rep_nm }) + = Just rep_nm +tyConRepName_maybe (PrimTyCon { primRepName = mb_rep_nm }) + = mb_rep_nm +tyConRepName_maybe (AlgTyCon { algTcParent = parent }) + | VanillaAlgTyCon rep_nm <- parent = Just rep_nm + | ClassTyCon _ rep_nm <- parent = Just rep_nm + | UnboxedAlgTyCon rep_nm <- parent = rep_nm +tyConRepName_maybe (FamilyTyCon { famTcFlav = DataFamilyTyCon rep_nm }) + = Just rep_nm +tyConRepName_maybe (PromotedDataCon { dataCon = dc, tcRepName = rep_nm }) + | isUnboxedSumCon dc -- see #13276 + = Nothing + | otherwise + = Just rep_nm +tyConRepName_maybe _ = Nothing + +-- | Make a 'Name' for the 'Typeable' representation of the given wired-in type +mkPrelTyConRepName :: Name -> TyConRepName +-- See Note [Grand plan for Typeable] in 'TcTypeable' in TcTypeable. +mkPrelTyConRepName tc_name -- Prelude tc_name is always External, + -- so nameModule will work + = mkExternalName rep_uniq rep_mod rep_occ (nameSrcSpan tc_name) + where + name_occ = nameOccName tc_name + name_mod = nameModule tc_name + name_uniq = nameUnique tc_name + rep_uniq | isTcOcc name_occ = tyConRepNameUnique name_uniq + | otherwise = dataConTyRepNameUnique name_uniq + (rep_mod, rep_occ) = tyConRepModOcc name_mod name_occ + +-- | The name (and defining module) for the Typeable representation (TyCon) of a +-- type constructor. +-- +-- See Note [Grand plan for Typeable] in 'TcTypeable' in TcTypeable. +tyConRepModOcc :: Module -> OccName -> (Module, OccName) +tyConRepModOcc tc_module tc_occ = (rep_module, mkTyConRepOcc tc_occ) + where + rep_module + | tc_module == gHC_PRIM = gHC_TYPES + | otherwise = tc_module + + +{- ********************************************************************* +* * + PrimRep +* * +************************************************************************ + +Note [rep swamp] + +GHC has a rich selection of types that represent "primitive types" of +one kind or another. Each of them makes a different set of +distinctions, and mostly the differences are for good reasons, +although it's probably true that we could merge some of these. + +Roughly in order of "includes more information": + + - A Width (cmm/CmmType) is simply a binary value with the specified + number of bits. It may represent a signed or unsigned integer, a + floating-point value, or an address. + + data Width = W8 | W16 | W32 | W64 | W80 | W128 + + - Size, which is used in the native code generator, is Width + + floating point information. + + data Size = II8 | II16 | II32 | II64 | FF32 | FF64 | FF80 + + it is necessary because e.g. the instruction to move a 64-bit float + on x86 (movsd) is different from the instruction to move a 64-bit + integer (movq), so the mov instruction is parameterised by Size. + + - CmmType wraps Width with more information: GC ptr, float, or + other value. + + data CmmType = CmmType CmmCat Width + + data CmmCat -- "Category" (not exported) + = GcPtrCat -- GC pointer + | BitsCat -- Non-pointer + | FloatCat -- Float + + It is important to have GcPtr information in Cmm, since we generate + info tables containing pointerhood for the GC from this. As for + why we have float (and not signed/unsigned) here, see Note [Signed + vs unsigned]. + + - ArgRep makes only the distinctions necessary for the call and + return conventions of the STG machine. It is essentially CmmType + + void. + + - PrimRep makes a few more distinctions than ArgRep: it divides + non-GC-pointers into signed/unsigned and addresses, information + that is necessary for passing these values to foreign functions. + +There's another tension here: whether the type encodes its size in +bytes, or whether its size depends on the machine word size. Width +and CmmType have the size built-in, whereas ArgRep and PrimRep do not. + +This means to turn an ArgRep/PrimRep into a CmmType requires DynFlags. + +On the other hand, CmmType includes some "nonsense" values, such as +CmmType GcPtrCat W32 on a 64-bit machine. +-} + +-- | A 'PrimRep' is an abstraction of a type. It contains information that +-- the code generator needs in order to pass arguments, return results, +-- and store values of this type. +data PrimRep + = VoidRep + | LiftedRep + | UnliftedRep -- ^ Unlifted pointer + | Int8Rep -- ^ Signed, 8-bit value + | Int16Rep -- ^ Signed, 16-bit value + | IntRep -- ^ Signed, word-sized value + | WordRep -- ^ Unsigned, word-sized value + | Int64Rep -- ^ Signed, 64 bit value (with 32-bit words only) + | Word8Rep -- ^ Unsigned, 8 bit value + | Word16Rep -- ^ Unsigned, 16 bit value + | Word64Rep -- ^ Unsigned, 64 bit value (with 32-bit words only) + | AddrRep -- ^ A pointer, but /not/ to a Haskell value (use '(Un)liftedRep') + | FloatRep + | DoubleRep + | VecRep Int PrimElemRep -- ^ A vector + deriving( Eq, Show ) + +data PrimElemRep + = Int8ElemRep + | Int16ElemRep + | Int32ElemRep + | Int64ElemRep + | Word8ElemRep + | Word16ElemRep + | Word32ElemRep + | Word64ElemRep + | FloatElemRep + | DoubleElemRep + deriving( Eq, Show ) + +instance Outputable PrimRep where + ppr r = text (show r) + +instance Outputable PrimElemRep where + ppr r = text (show r) + +isVoidRep :: PrimRep -> Bool +isVoidRep VoidRep = True +isVoidRep _other = False + +isGcPtrRep :: PrimRep -> Bool +isGcPtrRep LiftedRep = True +isGcPtrRep UnliftedRep = True +isGcPtrRep _ = False + +-- | The size of a 'PrimRep' in bytes. +-- +-- This applies also when used in a constructor, where we allow packing the +-- fields. For instance, in @data Foo = Foo Float# Float#@ the two fields will +-- take only 8 bytes, which for 64-bit arch will be equal to 1 word. +-- See also mkVirtHeapOffsetsWithPadding for details of how data fields are +-- layed out. +primRepSizeB :: DynFlags -> PrimRep -> Int +primRepSizeB dflags IntRep = wORD_SIZE dflags +primRepSizeB dflags WordRep = wORD_SIZE dflags +primRepSizeB _ Int8Rep = 1 +primRepSizeB _ Int16Rep = 2 +primRepSizeB _ Int64Rep = wORD64_SIZE +primRepSizeB _ Word8Rep = 1 +primRepSizeB _ Word16Rep = 2 +primRepSizeB _ Word64Rep = wORD64_SIZE +primRepSizeB _ FloatRep = fLOAT_SIZE +primRepSizeB dflags DoubleRep = dOUBLE_SIZE dflags +primRepSizeB dflags AddrRep = wORD_SIZE dflags +primRepSizeB dflags LiftedRep = wORD_SIZE dflags +primRepSizeB dflags UnliftedRep = wORD_SIZE dflags +primRepSizeB _ VoidRep = 0 +primRepSizeB _ (VecRep len rep) = len * primElemRepSizeB rep + +primElemRepSizeB :: PrimElemRep -> Int +primElemRepSizeB Int8ElemRep = 1 +primElemRepSizeB Int16ElemRep = 2 +primElemRepSizeB Int32ElemRep = 4 +primElemRepSizeB Int64ElemRep = 8 +primElemRepSizeB Word8ElemRep = 1 +primElemRepSizeB Word16ElemRep = 2 +primElemRepSizeB Word32ElemRep = 4 +primElemRepSizeB Word64ElemRep = 8 +primElemRepSizeB FloatElemRep = 4 +primElemRepSizeB DoubleElemRep = 8 + +-- | Return if Rep stands for floating type, +-- returns Nothing for vector types. +primRepIsFloat :: PrimRep -> Maybe Bool +primRepIsFloat FloatRep = Just True +primRepIsFloat DoubleRep = Just True +primRepIsFloat (VecRep _ _) = Nothing +primRepIsFloat _ = Just False + + +{- +************************************************************************ +* * + Field labels +* * +************************************************************************ +-} + +-- | The labels for the fields of this particular 'TyCon' +tyConFieldLabels :: TyCon -> [FieldLabel] +tyConFieldLabels tc = dFsEnvElts $ tyConFieldLabelEnv tc + +-- | The labels for the fields of this particular 'TyCon' +tyConFieldLabelEnv :: TyCon -> FieldLabelEnv +tyConFieldLabelEnv tc + | isAlgTyCon tc = algTcFields tc + | otherwise = emptyDFsEnv + +-- | Look up a field label belonging to this 'TyCon' +lookupTyConFieldLabel :: FieldLabelString -> TyCon -> Maybe FieldLabel +lookupTyConFieldLabel lbl tc = lookupDFsEnv (tyConFieldLabelEnv tc) lbl + +-- | Make a map from strings to FieldLabels from all the data +-- constructors of this algebraic tycon +fieldsOfAlgTcRhs :: AlgTyConRhs -> FieldLabelEnv +fieldsOfAlgTcRhs rhs = mkDFsEnv [ (flLabel fl, fl) + | fl <- dataConsFields (visibleDataCons rhs) ] + where + -- Duplicates in this list will be removed by 'mkFsEnv' + dataConsFields dcs = concatMap dataConFieldLabels dcs + + +{- +************************************************************************ +* * +\subsection{TyCon Construction} +* * +************************************************************************ + +Note: the TyCon constructors all take a Kind as one argument, even though +they could, in principle, work out their Kind from their other arguments. +But to do so they need functions from Types, and that makes a nasty +module mutual-recursion. And they aren't called from many places. +So we compromise, and move their Kind calculation to the call site. +-} + +-- | Given the name of the function type constructor and it's kind, create the +-- corresponding 'TyCon'. It is recommended to use 'TyCoRep.funTyCon' if you want +-- this functionality +mkFunTyCon :: Name -> [TyConBinder] -> Name -> TyCon +mkFunTyCon name binders rep_nm + = FunTyCon { + tyConUnique = nameUnique name, + tyConName = name, + tyConBinders = binders, + tyConResKind = liftedTypeKind, + tyConKind = mkTyConKind binders liftedTypeKind, + tyConArity = length binders, + tcRepName = rep_nm + } + +-- | This is the making of an algebraic 'TyCon'. Notably, you have to +-- pass in the generic (in the -XGenerics sense) information about the +-- type constructor - you can get hold of it easily (see Generics +-- module) +mkAlgTyCon :: Name + -> [TyConBinder] -- ^ Binders of the 'TyCon' + -> Kind -- ^ Result kind + -> [Role] -- ^ The roles for each TyVar + -> Maybe CType -- ^ The C type this type corresponds to + -- when using the CAPI FFI + -> [PredType] -- ^ Stupid theta: see 'algTcStupidTheta' + -> AlgTyConRhs -- ^ Information about data constructors + -> AlgTyConFlav -- ^ What flavour is it? + -- (e.g. vanilla, type family) + -> Bool -- ^ Was the 'TyCon' declared with GADT syntax? + -> TyCon +mkAlgTyCon name binders res_kind roles cType stupid rhs parent gadt_syn + = AlgTyCon { + tyConName = name, + tyConUnique = nameUnique name, + tyConBinders = binders, + tyConResKind = res_kind, + tyConKind = mkTyConKind binders res_kind, + tyConArity = length binders, + tyConTyVars = binderVars binders, + tcRoles = roles, + tyConCType = cType, + algTcStupidTheta = stupid, + algTcRhs = rhs, + algTcFields = fieldsOfAlgTcRhs rhs, + algTcParent = ASSERT2( okParent name parent, ppr name $$ ppr parent ) parent, + algTcGadtSyntax = gadt_syn + } + +-- | Simpler specialization of 'mkAlgTyCon' for classes +mkClassTyCon :: Name -> [TyConBinder] + -> [Role] -> AlgTyConRhs -> Class + -> Name -> TyCon +mkClassTyCon name binders roles rhs clas tc_rep_name + = mkAlgTyCon name binders constraintKind roles Nothing [] rhs + (ClassTyCon clas tc_rep_name) + False + +mkTupleTyCon :: Name + -> [TyConBinder] + -> Kind -- ^ Result kind of the 'TyCon' + -> Arity -- ^ Arity of the tuple 'TyCon' + -> DataCon + -> TupleSort -- ^ Whether the tuple is boxed or unboxed + -> AlgTyConFlav + -> TyCon +mkTupleTyCon name binders res_kind arity con sort parent + = AlgTyCon { + tyConUnique = nameUnique name, + tyConName = name, + tyConBinders = binders, + tyConTyVars = binderVars binders, + tyConResKind = res_kind, + tyConKind = mkTyConKind binders res_kind, + tyConArity = arity, + tcRoles = replicate arity Representational, + tyConCType = Nothing, + algTcGadtSyntax = False, + algTcStupidTheta = [], + algTcRhs = TupleTyCon { data_con = con, + tup_sort = sort }, + algTcFields = emptyDFsEnv, + algTcParent = parent + } + +mkSumTyCon :: Name + -> [TyConBinder] + -> Kind -- ^ Kind of the resulting 'TyCon' + -> Arity -- ^ Arity of the sum + -> [TyVar] -- ^ 'TyVar's scoped over: see 'tyConTyVars' + -> [DataCon] + -> AlgTyConFlav + -> TyCon +mkSumTyCon name binders res_kind arity tyvars cons parent + = AlgTyCon { + tyConUnique = nameUnique name, + tyConName = name, + tyConBinders = binders, + tyConTyVars = tyvars, + tyConResKind = res_kind, + tyConKind = mkTyConKind binders res_kind, + tyConArity = arity, + tcRoles = replicate arity Representational, + tyConCType = Nothing, + algTcGadtSyntax = False, + algTcStupidTheta = [], + algTcRhs = mkSumTyConRhs cons, + algTcFields = emptyDFsEnv, + algTcParent = parent + } + +-- | Makes a tycon suitable for use during type-checking. It stores +-- a variety of details about the definition of the TyCon, but no +-- right-hand side. It lives only during the type-checking of a +-- mutually-recursive group of tycons; it is then zonked to a proper +-- TyCon in zonkTcTyCon. +-- See also Note [Kind checking recursive type and class declarations] +-- in TcTyClsDecls. +mkTcTyCon :: Name + -> [TyConBinder] + -> Kind -- ^ /result/ kind only + -> [(Name,TcTyVar)] -- ^ Scoped type variables; + -- see Note [How TcTyCons work] in TcTyClsDecls + -> Bool -- ^ Is this TcTyCon generalised already? + -> TyConFlavour -- ^ What sort of 'TyCon' this represents + -> TyCon +mkTcTyCon name binders res_kind scoped_tvs poly flav + = TcTyCon { tyConUnique = getUnique name + , tyConName = name + , tyConTyVars = binderVars binders + , tyConBinders = binders + , tyConResKind = res_kind + , tyConKind = mkTyConKind binders res_kind + , tyConArity = length binders + , tcTyConScopedTyVars = scoped_tvs + , tcTyConIsPoly = poly + , tcTyConFlavour = flav } + +-- | Create an unlifted primitive 'TyCon', such as @Int#@. +mkPrimTyCon :: Name -> [TyConBinder] + -> Kind -- ^ /result/ kind, never levity-polymorphic + -> [Role] -> TyCon +mkPrimTyCon name binders res_kind roles + = mkPrimTyCon' name binders res_kind roles True (Just $ mkPrelTyConRepName name) + +-- | Kind constructors +mkKindTyCon :: Name -> [TyConBinder] + -> Kind -- ^ /result/ kind + -> [Role] -> Name -> TyCon +mkKindTyCon name binders res_kind roles rep_nm + = tc + where + tc = mkPrimTyCon' name binders res_kind roles False (Just rep_nm) + +-- | Create a lifted primitive 'TyCon' such as @RealWorld@ +mkLiftedPrimTyCon :: Name -> [TyConBinder] + -> Kind -- ^ /result/ kind + -> [Role] -> TyCon +mkLiftedPrimTyCon name binders res_kind roles + = mkPrimTyCon' name binders res_kind roles False (Just rep_nm) + where rep_nm = mkPrelTyConRepName name + +mkPrimTyCon' :: Name -> [TyConBinder] + -> Kind -- ^ /result/ kind, never levity-polymorphic + -- (If you need a levity-polymorphic PrimTyCon, change + -- isTcLevPoly.) + -> [Role] + -> Bool -> Maybe TyConRepName -> TyCon +mkPrimTyCon' name binders res_kind roles is_unlifted rep_nm + = PrimTyCon { + tyConName = name, + tyConUnique = nameUnique name, + tyConBinders = binders, + tyConResKind = res_kind, + tyConKind = mkTyConKind binders res_kind, + tyConArity = length roles, + tcRoles = roles, + isUnlifted = is_unlifted, + primRepName = rep_nm + } + +-- | Create a type synonym 'TyCon' +mkSynonymTyCon :: Name -> [TyConBinder] -> Kind -- ^ /result/ kind + -> [Role] -> Type -> Bool -> Bool -> TyCon +mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free + = SynonymTyCon { + tyConName = name, + tyConUnique = nameUnique name, + tyConBinders = binders, + tyConResKind = res_kind, + tyConKind = mkTyConKind binders res_kind, + tyConArity = length binders, + tyConTyVars = binderVars binders, + tcRoles = roles, + synTcRhs = rhs, + synIsTau = is_tau, + synIsFamFree = is_fam_free + } + +-- | Create a type family 'TyCon' +mkFamilyTyCon :: Name -> [TyConBinder] -> Kind -- ^ /result/ kind + -> Maybe Name -> FamTyConFlav + -> Maybe Class -> Injectivity -> TyCon +mkFamilyTyCon name binders res_kind resVar flav parent inj + = FamilyTyCon + { tyConUnique = nameUnique name + , tyConName = name + , tyConBinders = binders + , tyConResKind = res_kind + , tyConKind = mkTyConKind binders res_kind + , tyConArity = length binders + , tyConTyVars = binderVars binders + , famTcResVar = resVar + , famTcFlav = flav + , famTcParent = classTyCon <$> parent + , famTcInj = inj + } + + +-- | Create a promoted data constructor 'TyCon' +-- Somewhat dodgily, we give it the same Name +-- as the data constructor itself; when we pretty-print +-- the TyCon we add a quote; see the Outputable TyCon instance +mkPromotedDataCon :: DataCon -> Name -> TyConRepName + -> [TyConTyCoBinder] -> Kind -> [Role] + -> RuntimeRepInfo -> TyCon +mkPromotedDataCon con name rep_name binders res_kind roles rep_info + = PromotedDataCon { + tyConUnique = nameUnique name, + tyConName = name, + tyConArity = length roles, + tcRoles = roles, + tyConBinders = binders, + tyConResKind = res_kind, + tyConKind = mkTyConKind binders res_kind, + dataCon = con, + tcRepName = rep_name, + promDcRepInfo = rep_info + } + +isFunTyCon :: TyCon -> Bool +isFunTyCon (FunTyCon {}) = True +isFunTyCon _ = False + +-- | Test if the 'TyCon' is algebraic but abstract (invisible data constructors) +isAbstractTyCon :: TyCon -> Bool +isAbstractTyCon (AlgTyCon { algTcRhs = AbstractTyCon }) = True +isAbstractTyCon _ = False + +-- | Does this 'TyCon' represent something that cannot be defined in Haskell? +isPrimTyCon :: TyCon -> Bool +isPrimTyCon (PrimTyCon {}) = True +isPrimTyCon _ = False + +-- | Is this 'TyCon' unlifted (i.e. cannot contain bottom)? Note that this can +-- only be true for primitive and unboxed-tuple 'TyCon's +isUnliftedTyCon :: TyCon -> Bool +isUnliftedTyCon (PrimTyCon {isUnlifted = is_unlifted}) + = is_unlifted +isUnliftedTyCon (AlgTyCon { algTcRhs = rhs } ) + | TupleTyCon { tup_sort = sort } <- rhs + = not (isBoxed (tupleSortBoxity sort)) +isUnliftedTyCon (AlgTyCon { algTcRhs = rhs } ) + | SumTyCon {} <- rhs + = True +isUnliftedTyCon _ = False + +-- | Returns @True@ if the supplied 'TyCon' resulted from either a +-- @data@ or @newtype@ declaration +isAlgTyCon :: TyCon -> Bool +isAlgTyCon (AlgTyCon {}) = True +isAlgTyCon _ = False + +-- | Returns @True@ for vanilla AlgTyCons -- that is, those created +-- with a @data@ or @newtype@ declaration. +isVanillaAlgTyCon :: TyCon -> Bool +isVanillaAlgTyCon (AlgTyCon { algTcParent = VanillaAlgTyCon _ }) = True +isVanillaAlgTyCon _ = False + +isDataTyCon :: TyCon -> Bool +-- ^ Returns @True@ for data types that are /definitely/ represented by +-- heap-allocated constructors. These are scrutinised by Core-level +-- @case@ expressions, and they get info tables allocated for them. +-- +-- Generally, the function will be true for all @data@ types and false +-- for @newtype@s, unboxed tuples, unboxed sums and type family +-- 'TyCon's. But it is not guaranteed to return @True@ in all cases +-- that it could. +-- +-- NB: for a data type family, only the /instance/ 'TyCon's +-- get an info table. The family declaration 'TyCon' does not +isDataTyCon (AlgTyCon {algTcRhs = rhs}) + = case rhs of + TupleTyCon { tup_sort = sort } + -> isBoxed (tupleSortBoxity sort) + SumTyCon {} -> False + DataTyCon {} -> True + NewTyCon {} -> False + AbstractTyCon {} -> False -- We don't know, so return False +isDataTyCon _ = False + +-- | 'isInjectiveTyCon' is true of 'TyCon's for which this property holds +-- (where X is the role passed in): +-- If (T a1 b1 c1) ~X (T a2 b2 c2), then (a1 ~X1 a2), (b1 ~X2 b2), and (c1 ~X3 c2) +-- (where X1, X2, and X3, are the roles given by tyConRolesX tc X) +-- See also Note [Decomposing equality] in TcCanonical +isInjectiveTyCon :: TyCon -> Role -> Bool +isInjectiveTyCon _ Phantom = False +isInjectiveTyCon (FunTyCon {}) _ = True +isInjectiveTyCon (AlgTyCon {}) Nominal = True +isInjectiveTyCon (AlgTyCon {algTcRhs = rhs}) Representational + = isGenInjAlgRhs rhs +isInjectiveTyCon (SynonymTyCon {}) _ = False +isInjectiveTyCon (FamilyTyCon { famTcFlav = DataFamilyTyCon _ }) + Nominal = True +isInjectiveTyCon (FamilyTyCon { famTcInj = Injective inj }) Nominal = and inj +isInjectiveTyCon (FamilyTyCon {}) _ = False +isInjectiveTyCon (PrimTyCon {}) _ = True +isInjectiveTyCon (PromotedDataCon {}) _ = True +isInjectiveTyCon (TcTyCon {}) _ = True + -- Reply True for TcTyCon to minimise knock on type errors + -- See Note [How TcTyCons work] item (1) in TcTyClsDecls + +-- | 'isGenerativeTyCon' is true of 'TyCon's for which this property holds +-- (where X is the role passed in): +-- If (T tys ~X t), then (t's head ~X T). +-- See also Note [Decomposing equality] in TcCanonical +isGenerativeTyCon :: TyCon -> Role -> Bool +isGenerativeTyCon (FamilyTyCon { famTcFlav = DataFamilyTyCon _ }) Nominal = True +isGenerativeTyCon (FamilyTyCon {}) _ = False + -- in all other cases, injectivity implies generativity +isGenerativeTyCon tc r = isInjectiveTyCon tc r + +-- | Is this an 'AlgTyConRhs' of a 'TyCon' that is generative and injective +-- with respect to representational equality? +isGenInjAlgRhs :: AlgTyConRhs -> Bool +isGenInjAlgRhs (TupleTyCon {}) = True +isGenInjAlgRhs (SumTyCon {}) = True +isGenInjAlgRhs (DataTyCon {}) = True +isGenInjAlgRhs (AbstractTyCon {}) = False +isGenInjAlgRhs (NewTyCon {}) = False + +-- | Is this 'TyCon' that for a @newtype@ +isNewTyCon :: TyCon -> Bool +isNewTyCon (AlgTyCon {algTcRhs = NewTyCon {}}) = True +isNewTyCon _ = False + +-- | Take a 'TyCon' apart into the 'TyVar's it scopes over, the 'Type' it +-- expands into, and (possibly) a coercion from the representation type to the +-- @newtype@. +-- Returns @Nothing@ if this is not possible. +unwrapNewTyCon_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom Unbranched) +unwrapNewTyCon_maybe (AlgTyCon { tyConTyVars = tvs, + algTcRhs = NewTyCon { nt_co = co, + nt_rhs = rhs }}) + = Just (tvs, rhs, co) +unwrapNewTyCon_maybe _ = Nothing + +unwrapNewTyConEtad_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom Unbranched) +unwrapNewTyConEtad_maybe (AlgTyCon { algTcRhs = NewTyCon { nt_co = co, + nt_etad_rhs = (tvs,rhs) }}) + = Just (tvs, rhs, co) +unwrapNewTyConEtad_maybe _ = Nothing + +isProductTyCon :: TyCon -> Bool +-- True of datatypes or newtypes that have +-- one, non-existential, data constructor +-- See Note [Product types] +isProductTyCon tc@(AlgTyCon {}) + = case algTcRhs tc of + TupleTyCon {} -> True + DataTyCon{ data_cons = [data_con] } + -> null (dataConExTyCoVars data_con) + NewTyCon {} -> True + _ -> False +isProductTyCon _ = False + +isDataProductTyCon_maybe :: TyCon -> Maybe DataCon +-- True of datatypes (not newtypes) with +-- one, vanilla, data constructor +-- See Note [Product types] +isDataProductTyCon_maybe (AlgTyCon { algTcRhs = rhs }) + = case rhs of + DataTyCon { data_cons = [con] } + | null (dataConExTyCoVars con) -- non-existential + -> Just con + TupleTyCon { data_con = con } + -> Just con + _ -> Nothing +isDataProductTyCon_maybe _ = Nothing + +isDataSumTyCon_maybe :: TyCon -> Maybe [DataCon] +isDataSumTyCon_maybe (AlgTyCon { algTcRhs = rhs }) + = case rhs of + DataTyCon { data_cons = cons } + | cons `lengthExceeds` 1 + , all (null . dataConExTyCoVars) cons -- FIXME(osa): Why do we need this? + -> Just cons + SumTyCon { data_cons = cons } + | all (null . dataConExTyCoVars) cons -- FIXME(osa): Why do we need this? + -> Just cons + _ -> Nothing +isDataSumTyCon_maybe _ = Nothing + +{- Note [Product types] +~~~~~~~~~~~~~~~~~~~~~~~ +A product type is + * A data type (not a newtype) + * With one, boxed data constructor + * That binds no existential type variables + +The main point is that product types are amenable to unboxing for + * Strict function calls; we can transform + f (D a b) = e + to + fw a b = e + via the worker/wrapper transformation. (Question: couldn't this + work for existentials too?) + + * CPR for function results; we can transform + f x y = let ... in D a b + to + fw x y = let ... in (# a, b #) + +Note that the data constructor /can/ have evidence arguments: equality +constraints, type classes etc. So it can be GADT. These evidence +arguments are simply value arguments, and should not get in the way. +-} + + +-- | Is this a 'TyCon' representing a regular H98 type synonym (@type@)? +isTypeSynonymTyCon :: TyCon -> Bool +isTypeSynonymTyCon (SynonymTyCon {}) = True +isTypeSynonymTyCon _ = False + +isTauTyCon :: TyCon -> Bool +isTauTyCon (SynonymTyCon { synIsTau = is_tau }) = is_tau +isTauTyCon _ = True + +isFamFreeTyCon :: TyCon -> Bool +isFamFreeTyCon (SynonymTyCon { synIsFamFree = fam_free }) = fam_free +isFamFreeTyCon (FamilyTyCon { famTcFlav = flav }) = isDataFamFlav flav +isFamFreeTyCon _ = True + +-- As for newtypes, it is in some contexts important to distinguish between +-- closed synonyms and synonym families, as synonym families have no unique +-- right hand side to which a synonym family application can expand. +-- + +-- | True iff we can decompose (T a b c) into ((T a b) c) +-- I.e. is it injective and generative w.r.t nominal equality? +-- That is, if (T a b) ~N d e f, is it always the case that +-- (T ~N d), (a ~N e) and (b ~N f)? +-- Specifically NOT true of synonyms (open and otherwise) +-- +-- It'd be unusual to call mustBeSaturated on a regular H98 +-- type synonym, because you should probably have expanded it first +-- But regardless, it's not decomposable +mustBeSaturated :: TyCon -> Bool +mustBeSaturated = tcFlavourMustBeSaturated . tyConFlavour + +-- | Is this an algebraic 'TyCon' declared with the GADT syntax? +isGadtSyntaxTyCon :: TyCon -> Bool +isGadtSyntaxTyCon (AlgTyCon { algTcGadtSyntax = res }) = res +isGadtSyntaxTyCon _ = False + +-- | Is this an algebraic 'TyCon' which is just an enumeration of values? +isEnumerationTyCon :: TyCon -> Bool +-- See Note [Enumeration types] in TyCon +isEnumerationTyCon (AlgTyCon { tyConArity = arity, algTcRhs = rhs }) + = case rhs of + DataTyCon { is_enum = res } -> res + TupleTyCon {} -> arity == 0 + _ -> False +isEnumerationTyCon _ = False + +-- | Is this a 'TyCon', synonym or otherwise, that defines a family? +isFamilyTyCon :: TyCon -> Bool +isFamilyTyCon (FamilyTyCon {}) = True +isFamilyTyCon _ = False + +-- | Is this a 'TyCon', synonym or otherwise, that defines a family with +-- instances? +isOpenFamilyTyCon :: TyCon -> Bool +isOpenFamilyTyCon (FamilyTyCon {famTcFlav = flav }) + | OpenSynFamilyTyCon <- flav = True + | DataFamilyTyCon {} <- flav = True +isOpenFamilyTyCon _ = False + +-- | Is this a synonym 'TyCon' that can have may have further instances appear? +isTypeFamilyTyCon :: TyCon -> Bool +isTypeFamilyTyCon (FamilyTyCon { famTcFlav = flav }) = not (isDataFamFlav flav) +isTypeFamilyTyCon _ = False + +-- | Is this a synonym 'TyCon' that can have may have further instances appear? +isDataFamilyTyCon :: TyCon -> Bool +isDataFamilyTyCon (FamilyTyCon { famTcFlav = flav }) = isDataFamFlav flav +isDataFamilyTyCon _ = False + +-- | Is this an open type family TyCon? +isOpenTypeFamilyTyCon :: TyCon -> Bool +isOpenTypeFamilyTyCon (FamilyTyCon {famTcFlav = OpenSynFamilyTyCon }) = True +isOpenTypeFamilyTyCon _ = False + +-- | Is this a non-empty closed type family? Returns 'Nothing' for +-- abstract or empty closed families. +isClosedSynFamilyTyConWithAxiom_maybe :: TyCon -> Maybe (CoAxiom Branched) +isClosedSynFamilyTyConWithAxiom_maybe + (FamilyTyCon {famTcFlav = ClosedSynFamilyTyCon mb}) = mb +isClosedSynFamilyTyConWithAxiom_maybe _ = Nothing + +-- | @'tyConInjectivityInfo' tc@ returns @'Injective' is@ is @tc@ is an +-- injective tycon (where @is@ states for which 'tyConBinders' @tc@ is +-- injective), or 'NotInjective' otherwise. +tyConInjectivityInfo :: TyCon -> Injectivity +tyConInjectivityInfo tc + | FamilyTyCon { famTcInj = inj } <- tc + = inj + | isInjectiveTyCon tc Nominal + = Injective (replicate (tyConArity tc) True) + | otherwise + = NotInjective + +isBuiltInSynFamTyCon_maybe :: TyCon -> Maybe BuiltInSynFamily +isBuiltInSynFamTyCon_maybe + (FamilyTyCon {famTcFlav = BuiltInSynFamTyCon ops }) = Just ops +isBuiltInSynFamTyCon_maybe _ = Nothing + +isDataFamFlav :: FamTyConFlav -> Bool +isDataFamFlav (DataFamilyTyCon {}) = True -- Data family +isDataFamFlav _ = False -- Type synonym family + +-- | Is this TyCon for an associated type? +isTyConAssoc :: TyCon -> Bool +isTyConAssoc = isJust . tyConAssoc_maybe + +-- | Get the enclosing class TyCon (if there is one) for the given TyCon. +tyConAssoc_maybe :: TyCon -> Maybe TyCon +tyConAssoc_maybe = tyConFlavourAssoc_maybe . tyConFlavour + +-- | Get the enclosing class TyCon (if there is one) for the given TyConFlavour +tyConFlavourAssoc_maybe :: TyConFlavour -> Maybe TyCon +tyConFlavourAssoc_maybe (DataFamilyFlavour mb_parent) = mb_parent +tyConFlavourAssoc_maybe (OpenTypeFamilyFlavour mb_parent) = mb_parent +tyConFlavourAssoc_maybe _ = Nothing + +-- The unit tycon didn't used to be classed as a tuple tycon +-- but I thought that was silly so I've undone it +-- If it can't be for some reason, it should be a AlgTyCon +isTupleTyCon :: TyCon -> Bool +-- ^ Does this 'TyCon' represent a tuple? +-- +-- NB: when compiling @Data.Tuple@, the tycons won't reply @True@ to +-- 'isTupleTyCon', because they are built as 'AlgTyCons'. However they +-- get spat into the interface file as tuple tycons, so I don't think +-- it matters. +isTupleTyCon (AlgTyCon { algTcRhs = TupleTyCon {} }) = True +isTupleTyCon _ = False + +tyConTuple_maybe :: TyCon -> Maybe TupleSort +tyConTuple_maybe (AlgTyCon { algTcRhs = rhs }) + | TupleTyCon { tup_sort = sort} <- rhs = Just sort +tyConTuple_maybe _ = Nothing + +-- | Is this the 'TyCon' for an unboxed tuple? +isUnboxedTupleTyCon :: TyCon -> Bool +isUnboxedTupleTyCon (AlgTyCon { algTcRhs = rhs }) + | TupleTyCon { tup_sort = sort } <- rhs + = not (isBoxed (tupleSortBoxity sort)) +isUnboxedTupleTyCon _ = False + +-- | Is this the 'TyCon' for a boxed tuple? +isBoxedTupleTyCon :: TyCon -> Bool +isBoxedTupleTyCon (AlgTyCon { algTcRhs = rhs }) + | TupleTyCon { tup_sort = sort } <- rhs + = isBoxed (tupleSortBoxity sort) +isBoxedTupleTyCon _ = False + +-- | Is this the 'TyCon' for an unboxed sum? +isUnboxedSumTyCon :: TyCon -> Bool +isUnboxedSumTyCon (AlgTyCon { algTcRhs = rhs }) + | SumTyCon {} <- rhs + = True +isUnboxedSumTyCon _ = False + +-- | Is this the 'TyCon' for a /promoted/ tuple? +isPromotedTupleTyCon :: TyCon -> Bool +isPromotedTupleTyCon tyCon + | Just dataCon <- isPromotedDataCon_maybe tyCon + , isTupleTyCon (dataConTyCon dataCon) = True + | otherwise = False + +-- | Is this a PromotedDataCon? +isPromotedDataCon :: TyCon -> Bool +isPromotedDataCon (PromotedDataCon {}) = True +isPromotedDataCon _ = False + +-- | Retrieves the promoted DataCon if this is a PromotedDataCon; +isPromotedDataCon_maybe :: TyCon -> Maybe DataCon +isPromotedDataCon_maybe (PromotedDataCon { dataCon = dc }) = Just dc +isPromotedDataCon_maybe _ = Nothing + +-- | Is this tycon really meant for use at the kind level? That is, +-- should it be permitted without -XDataKinds? +isKindTyCon :: TyCon -> Bool +isKindTyCon tc = getUnique tc `elementOfUniqSet` kindTyConKeys + +-- | These TyCons should be allowed at the kind level, even without +-- -XDataKinds. +kindTyConKeys :: UniqSet Unique +kindTyConKeys = unionManyUniqSets + ( mkUniqSet [ liftedTypeKindTyConKey, constraintKindTyConKey, tYPETyConKey ] + : map (mkUniqSet . tycon_with_datacons) [ runtimeRepTyCon + , vecCountTyCon, vecElemTyCon ] ) + where + tycon_with_datacons tc = getUnique tc : map getUnique (tyConDataCons tc) + +isLiftedTypeKindTyConName :: Name -> Bool +isLiftedTypeKindTyConName = (`hasKey` liftedTypeKindTyConKey) + +-- | Identifies implicit tycons that, in particular, do not go into interface +-- files (because they are implicitly reconstructed when the interface is +-- read). +-- +-- Note that: +-- +-- * Associated families are implicit, as they are re-constructed from +-- the class declaration in which they reside, and +-- +-- * Family instances are /not/ implicit as they represent the instance body +-- (similar to a @dfun@ does that for a class instance). +-- +-- * Tuples are implicit iff they have a wired-in name +-- (namely: boxed and unboxed tupeles are wired-in and implicit, +-- but constraint tuples are not) +isImplicitTyCon :: TyCon -> Bool +isImplicitTyCon (FunTyCon {}) = True +isImplicitTyCon (PrimTyCon {}) = True +isImplicitTyCon (PromotedDataCon {}) = True +isImplicitTyCon (AlgTyCon { algTcRhs = rhs, tyConName = name }) + | TupleTyCon {} <- rhs = isWiredInName name + | SumTyCon {} <- rhs = True + | otherwise = False +isImplicitTyCon (FamilyTyCon { famTcParent = parent }) = isJust parent +isImplicitTyCon (SynonymTyCon {}) = False +isImplicitTyCon (TcTyCon {}) = False + +tyConCType_maybe :: TyCon -> Maybe CType +tyConCType_maybe tc@(AlgTyCon {}) = tyConCType tc +tyConCType_maybe _ = Nothing + +-- | Is this a TcTyCon? (That is, one only used during type-checking?) +isTcTyCon :: TyCon -> Bool +isTcTyCon (TcTyCon {}) = True +isTcTyCon _ = False + +setTcTyConKind :: TyCon -> Kind -> TyCon +-- Update the Kind of a TcTyCon +-- The new kind is always a zonked version of its previous +-- kind, so we don't need to update any other fields. +-- See Note [The Purely Kinded Invariant] in TcHsType +setTcTyConKind tc@(TcTyCon {}) kind = tc { tyConKind = kind } +setTcTyConKind tc _ = pprPanic "setTcTyConKind" (ppr tc) + +-- | Could this TyCon ever be levity-polymorphic when fully applied? +-- True is safe. False means we're sure. Does only a quick check +-- based on the TyCon's category. +-- Precondition: The fully-applied TyCon has kind (TYPE blah) +isTcLevPoly :: TyCon -> Bool +isTcLevPoly FunTyCon{} = False +isTcLevPoly (AlgTyCon { algTcParent = UnboxedAlgTyCon _ }) = True +isTcLevPoly AlgTyCon{} = False +isTcLevPoly SynonymTyCon{} = True +isTcLevPoly FamilyTyCon{} = True +isTcLevPoly PrimTyCon{} = False +isTcLevPoly TcTyCon{} = False +isTcLevPoly tc@PromotedDataCon{} = pprPanic "isTcLevPoly datacon" (ppr tc) + +{- +----------------------------------------------- +-- Expand type-constructor applications +----------------------------------------------- +-} + +expandSynTyCon_maybe + :: TyCon + -> [tyco] -- ^ Arguments to 'TyCon' + -> Maybe ([(TyVar,tyco)], + Type, + [tyco]) -- ^ Returns a 'TyVar' substitution, the body + -- type of the synonym (not yet substituted) + -- and any arguments remaining from the + -- application + +-- ^ Expand a type synonym application, if any +expandSynTyCon_maybe tc tys + | SynonymTyCon { tyConTyVars = tvs, synTcRhs = rhs, tyConArity = arity } <- tc + = case tys `listLengthCmp` arity of + GT -> Just (tvs `zip` tys, rhs, drop arity tys) + EQ -> Just (tvs `zip` tys, rhs, []) + LT -> Nothing + | otherwise + = Nothing + +---------------- + +-- | Check if the tycon actually refers to a proper `data` or `newtype` +-- with user defined constructors rather than one from a class or other +-- construction. + +-- NB: This is only used in TcRnExports.checkPatSynParent to determine if an +-- exported tycon can have a pattern synonym bundled with it, e.g., +-- module Foo (TyCon(.., PatSyn)) where +isTyConWithSrcDataCons :: TyCon -> Bool +isTyConWithSrcDataCons (AlgTyCon { algTcRhs = rhs, algTcParent = parent }) = + case rhs of + DataTyCon {} -> isSrcParent + NewTyCon {} -> isSrcParent + TupleTyCon {} -> isSrcParent + _ -> False + where + isSrcParent = isNoParent parent +isTyConWithSrcDataCons (FamilyTyCon { famTcFlav = DataFamilyTyCon {} }) + = True -- #14058 +isTyConWithSrcDataCons _ = False + + +-- | As 'tyConDataCons_maybe', but returns the empty list of constructors if no +-- constructors could be found +tyConDataCons :: TyCon -> [DataCon] +-- It's convenient for tyConDataCons to return the +-- empty list for type synonyms etc +tyConDataCons tycon = tyConDataCons_maybe tycon `orElse` [] + +-- | Determine the 'DataCon's originating from the given 'TyCon', if the 'TyCon' +-- is the sort that can have any constructors (note: this does not include +-- abstract algebraic types) +tyConDataCons_maybe :: TyCon -> Maybe [DataCon] +tyConDataCons_maybe (AlgTyCon {algTcRhs = rhs}) + = case rhs of + DataTyCon { data_cons = cons } -> Just cons + NewTyCon { data_con = con } -> Just [con] + TupleTyCon { data_con = con } -> Just [con] + SumTyCon { data_cons = cons } -> Just cons + _ -> Nothing +tyConDataCons_maybe _ = Nothing + +-- | If the given 'TyCon' has a /single/ data constructor, i.e. it is a @data@ +-- type with one alternative, a tuple type or a @newtype@ then that constructor +-- is returned. If the 'TyCon' has more than one constructor, or represents a +-- primitive or function type constructor then @Nothing@ is returned. In any +-- other case, the function panics +tyConSingleDataCon_maybe :: TyCon -> Maybe DataCon +tyConSingleDataCon_maybe (AlgTyCon { algTcRhs = rhs }) + = case rhs of + DataTyCon { data_cons = [c] } -> Just c + TupleTyCon { data_con = c } -> Just c + NewTyCon { data_con = c } -> Just c + _ -> Nothing +tyConSingleDataCon_maybe _ = Nothing + +tyConSingleDataCon :: TyCon -> DataCon +tyConSingleDataCon tc + = case tyConSingleDataCon_maybe tc of + Just c -> c + Nothing -> pprPanic "tyConDataCon" (ppr tc) + +tyConSingleAlgDataCon_maybe :: TyCon -> Maybe DataCon +-- Returns (Just con) for single-constructor +-- *algebraic* data types *not* newtypes +tyConSingleAlgDataCon_maybe (AlgTyCon { algTcRhs = rhs }) + = case rhs of + DataTyCon { data_cons = [c] } -> Just c + TupleTyCon { data_con = c } -> Just c + _ -> Nothing +tyConSingleAlgDataCon_maybe _ = Nothing + +-- | Determine the number of value constructors a 'TyCon' has. Panics if the +-- 'TyCon' is not algebraic or a tuple +tyConFamilySize :: TyCon -> Int +tyConFamilySize tc@(AlgTyCon { algTcRhs = rhs }) + = case rhs of + DataTyCon { data_cons_size = size } -> size + NewTyCon {} -> 1 + TupleTyCon {} -> 1 + SumTyCon { data_cons_size = size } -> size + _ -> pprPanic "tyConFamilySize 1" (ppr tc) +tyConFamilySize tc = pprPanic "tyConFamilySize 2" (ppr tc) + +-- | Extract an 'AlgTyConRhs' with information about data constructors from an +-- algebraic or tuple 'TyCon'. Panics for any other sort of 'TyCon' +algTyConRhs :: TyCon -> AlgTyConRhs +algTyConRhs (AlgTyCon {algTcRhs = rhs}) = rhs +algTyConRhs other = pprPanic "algTyConRhs" (ppr other) + +-- | Extract type variable naming the result of injective type family +tyConFamilyResVar_maybe :: TyCon -> Maybe Name +tyConFamilyResVar_maybe (FamilyTyCon {famTcResVar = res}) = res +tyConFamilyResVar_maybe _ = Nothing + +-- | Get the list of roles for the type parameters of a TyCon +tyConRoles :: TyCon -> [Role] +-- See also Note [TyCon Role signatures] +tyConRoles tc + = case tc of + { FunTyCon {} -> [Nominal, Nominal, Representational, Representational] + ; AlgTyCon { tcRoles = roles } -> roles + ; SynonymTyCon { tcRoles = roles } -> roles + ; FamilyTyCon {} -> const_role Nominal + ; PrimTyCon { tcRoles = roles } -> roles + ; PromotedDataCon { tcRoles = roles } -> roles + ; TcTyCon {} -> const_role Nominal + } + where + const_role r = replicate (tyConArity tc) r + +-- | Extract the bound type variables and type expansion of a type synonym +-- 'TyCon'. Panics if the 'TyCon' is not a synonym +newTyConRhs :: TyCon -> ([TyVar], Type) +newTyConRhs (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_rhs = rhs }}) + = (tvs, rhs) +newTyConRhs tycon = pprPanic "newTyConRhs" (ppr tycon) + +-- | The number of type parameters that need to be passed to a newtype to +-- resolve it. May be less than in the definition if it can be eta-contracted. +newTyConEtadArity :: TyCon -> Int +newTyConEtadArity (AlgTyCon {algTcRhs = NewTyCon { nt_etad_rhs = tvs_rhs }}) + = length (fst tvs_rhs) +newTyConEtadArity tycon = pprPanic "newTyConEtadArity" (ppr tycon) + +-- | Extract the bound type variables and type expansion of an eta-contracted +-- type synonym 'TyCon'. Panics if the 'TyCon' is not a synonym +newTyConEtadRhs :: TyCon -> ([TyVar], Type) +newTyConEtadRhs (AlgTyCon {algTcRhs = NewTyCon { nt_etad_rhs = tvs_rhs }}) = tvs_rhs +newTyConEtadRhs tycon = pprPanic "newTyConEtadRhs" (ppr tycon) + +-- | Extracts the @newtype@ coercion from such a 'TyCon', which can be used to +-- construct something with the @newtype@s type from its representation type +-- (right hand side). If the supplied 'TyCon' is not a @newtype@, returns +-- @Nothing@ +newTyConCo_maybe :: TyCon -> Maybe (CoAxiom Unbranched) +newTyConCo_maybe (AlgTyCon {algTcRhs = NewTyCon { nt_co = co }}) = Just co +newTyConCo_maybe _ = Nothing + +newTyConCo :: TyCon -> CoAxiom Unbranched +newTyConCo tc = case newTyConCo_maybe tc of + Just co -> co + Nothing -> pprPanic "newTyConCo" (ppr tc) + +newTyConDataCon_maybe :: TyCon -> Maybe DataCon +newTyConDataCon_maybe (AlgTyCon {algTcRhs = NewTyCon { data_con = con }}) = Just con +newTyConDataCon_maybe _ = Nothing + +-- | Find the \"stupid theta\" of the 'TyCon'. A \"stupid theta\" is the context +-- to the left of an algebraic type declaration, e.g. @Eq a@ in the declaration +-- @data Eq a => T a ...@ +tyConStupidTheta :: TyCon -> [PredType] +tyConStupidTheta (AlgTyCon {algTcStupidTheta = stupid}) = stupid +tyConStupidTheta (FunTyCon {}) = [] +tyConStupidTheta tycon = pprPanic "tyConStupidTheta" (ppr tycon) + +-- | Extract the 'TyVar's bound by a vanilla type synonym +-- and the corresponding (unsubstituted) right hand side. +synTyConDefn_maybe :: TyCon -> Maybe ([TyVar], Type) +synTyConDefn_maybe (SynonymTyCon {tyConTyVars = tyvars, synTcRhs = ty}) + = Just (tyvars, ty) +synTyConDefn_maybe _ = Nothing + +-- | Extract the information pertaining to the right hand side of a type synonym +-- (@type@) declaration. +synTyConRhs_maybe :: TyCon -> Maybe Type +synTyConRhs_maybe (SynonymTyCon {synTcRhs = rhs}) = Just rhs +synTyConRhs_maybe _ = Nothing + +-- | Extract the flavour of a type family (with all the extra information that +-- it carries) +famTyConFlav_maybe :: TyCon -> Maybe FamTyConFlav +famTyConFlav_maybe (FamilyTyCon {famTcFlav = flav}) = Just flav +famTyConFlav_maybe _ = Nothing + +-- | Is this 'TyCon' that for a class instance? +isClassTyCon :: TyCon -> Bool +isClassTyCon (AlgTyCon {algTcParent = ClassTyCon {}}) = True +isClassTyCon _ = False + +-- | If this 'TyCon' is that for a class instance, return the class it is for. +-- Otherwise returns @Nothing@ +tyConClass_maybe :: TyCon -> Maybe Class +tyConClass_maybe (AlgTyCon {algTcParent = ClassTyCon clas _}) = Just clas +tyConClass_maybe _ = Nothing + +-- | Return the associated types of the 'TyCon', if any +tyConATs :: TyCon -> [TyCon] +tyConATs (AlgTyCon {algTcParent = ClassTyCon clas _}) = classATs clas +tyConATs _ = [] + +---------------------------------------------------------------------------- +-- | Is this 'TyCon' that for a data family instance? +isFamInstTyCon :: TyCon -> Bool +isFamInstTyCon (AlgTyCon {algTcParent = DataFamInstTyCon {} }) + = True +isFamInstTyCon _ = False + +tyConFamInstSig_maybe :: TyCon -> Maybe (TyCon, [Type], CoAxiom Unbranched) +tyConFamInstSig_maybe (AlgTyCon {algTcParent = DataFamInstTyCon ax f ts }) + = Just (f, ts, ax) +tyConFamInstSig_maybe _ = Nothing + +-- | If this 'TyCon' is that of a data family instance, return the family in question +-- and the instance types. Otherwise, return @Nothing@ +tyConFamInst_maybe :: TyCon -> Maybe (TyCon, [Type]) +tyConFamInst_maybe (AlgTyCon {algTcParent = DataFamInstTyCon _ f ts }) + = Just (f, ts) +tyConFamInst_maybe _ = Nothing + +-- | If this 'TyCon' is that of a data family instance, return a 'TyCon' which +-- represents a coercion identifying the representation type with the type +-- instance family. Otherwise, return @Nothing@ +tyConFamilyCoercion_maybe :: TyCon -> Maybe (CoAxiom Unbranched) +tyConFamilyCoercion_maybe (AlgTyCon {algTcParent = DataFamInstTyCon ax _ _ }) + = Just ax +tyConFamilyCoercion_maybe _ = Nothing + +-- | Extract any 'RuntimeRepInfo' from this TyCon +tyConRuntimeRepInfo :: TyCon -> RuntimeRepInfo +tyConRuntimeRepInfo (PromotedDataCon { promDcRepInfo = rri }) = rri +tyConRuntimeRepInfo _ = NoRRI + -- could panic in that second case. But Douglas Adams told me not to. + +{- +Note [Constructor tag allocation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When typechecking we need to allocate constructor tags to constructors. +They are allocated based on the position in the data_cons field of TyCon, +with the first constructor getting fIRST_TAG. + +We used to pay linear cost per constructor, with each constructor looking up +its relative index in the constructor list. That was quadratic and prohibitive +for large data types with more than 10k constructors. + +The current strategy is to build a NameEnv with a mapping from costructor's +Name to ConTag and pass it down to buildDataCon for efficient lookup. + +Relevant ticket: #14657 +-} + +mkTyConTagMap :: TyCon -> NameEnv ConTag +mkTyConTagMap tycon = + mkNameEnv $ map getName (tyConDataCons tycon) `zip` [fIRST_TAG..] + -- See Note [Constructor tag allocation] + +{- +************************************************************************ +* * +\subsection[TyCon-instances]{Instance declarations for @TyCon@} +* * +************************************************************************ + +@TyCon@s are compared by comparing their @Unique@s. +-} + +instance Eq TyCon where + a == b = getUnique a == getUnique b + a /= b = getUnique a /= getUnique b + +instance Uniquable TyCon where + getUnique tc = tyConUnique tc + +instance Outputable TyCon where + -- At the moment a promoted TyCon has the same Name as its + -- corresponding TyCon, so we add the quote to distinguish it here + ppr tc = pprPromotionQuote tc <> ppr (tyConName tc) <> pp_tc + where + pp_tc = getPprStyle $ \sty -> if ((debugStyle sty || dumpStyle sty) && isTcTyCon tc) + then text "[tc]" + else empty + +-- | Paints a picture of what a 'TyCon' represents, in broad strokes. +-- This is used towards more informative error messages. +data TyConFlavour + = ClassFlavour + | TupleFlavour Boxity + | SumFlavour + | DataTypeFlavour + | NewtypeFlavour + | AbstractTypeFlavour + | DataFamilyFlavour (Maybe TyCon) -- Just tc <=> (tc == associated class) + | OpenTypeFamilyFlavour (Maybe TyCon) -- Just tc <=> (tc == associated class) + | ClosedTypeFamilyFlavour + | TypeSynonymFlavour + | BuiltInTypeFlavour -- ^ e.g., the @(->)@ 'TyCon'. + | PromotedDataConFlavour + deriving Eq + +instance Outputable TyConFlavour where + ppr = text . go + where + go ClassFlavour = "class" + go (TupleFlavour boxed) | isBoxed boxed = "tuple" + | otherwise = "unboxed tuple" + go SumFlavour = "unboxed sum" + go DataTypeFlavour = "data type" + go NewtypeFlavour = "newtype" + go AbstractTypeFlavour = "abstract type" + go (DataFamilyFlavour (Just _)) = "associated data family" + go (DataFamilyFlavour Nothing) = "data family" + go (OpenTypeFamilyFlavour (Just _)) = "associated type family" + go (OpenTypeFamilyFlavour Nothing) = "type family" + go ClosedTypeFamilyFlavour = "type family" + go TypeSynonymFlavour = "type synonym" + go BuiltInTypeFlavour = "built-in type" + go PromotedDataConFlavour = "promoted data constructor" + +tyConFlavour :: TyCon -> TyConFlavour +tyConFlavour (AlgTyCon { algTcParent = parent, algTcRhs = rhs }) + | ClassTyCon _ _ <- parent = ClassFlavour + | otherwise = case rhs of + TupleTyCon { tup_sort = sort } + -> TupleFlavour (tupleSortBoxity sort) + SumTyCon {} -> SumFlavour + DataTyCon {} -> DataTypeFlavour + NewTyCon {} -> NewtypeFlavour + AbstractTyCon {} -> AbstractTypeFlavour +tyConFlavour (FamilyTyCon { famTcFlav = flav, famTcParent = parent }) + = case flav of + DataFamilyTyCon{} -> DataFamilyFlavour parent + OpenSynFamilyTyCon -> OpenTypeFamilyFlavour parent + ClosedSynFamilyTyCon{} -> ClosedTypeFamilyFlavour + AbstractClosedSynFamilyTyCon -> ClosedTypeFamilyFlavour + BuiltInSynFamTyCon{} -> ClosedTypeFamilyFlavour +tyConFlavour (SynonymTyCon {}) = TypeSynonymFlavour +tyConFlavour (FunTyCon {}) = BuiltInTypeFlavour +tyConFlavour (PrimTyCon {}) = BuiltInTypeFlavour +tyConFlavour (PromotedDataCon {}) = PromotedDataConFlavour +tyConFlavour (TcTyCon { tcTyConFlavour = flav }) = flav + +-- | Can this flavour of 'TyCon' appear unsaturated? +tcFlavourMustBeSaturated :: TyConFlavour -> Bool +tcFlavourMustBeSaturated ClassFlavour = False +tcFlavourMustBeSaturated DataTypeFlavour = False +tcFlavourMustBeSaturated NewtypeFlavour = False +tcFlavourMustBeSaturated DataFamilyFlavour{} = False +tcFlavourMustBeSaturated TupleFlavour{} = False +tcFlavourMustBeSaturated SumFlavour = False +tcFlavourMustBeSaturated AbstractTypeFlavour = False +tcFlavourMustBeSaturated BuiltInTypeFlavour = False +tcFlavourMustBeSaturated PromotedDataConFlavour = False +tcFlavourMustBeSaturated TypeSynonymFlavour = True +tcFlavourMustBeSaturated OpenTypeFamilyFlavour{} = True +tcFlavourMustBeSaturated ClosedTypeFamilyFlavour = True + +-- | Is this flavour of 'TyCon' an open type family or a data family? +tcFlavourIsOpen :: TyConFlavour -> Bool +tcFlavourIsOpen DataFamilyFlavour{} = True +tcFlavourIsOpen OpenTypeFamilyFlavour{} = True +tcFlavourIsOpen ClosedTypeFamilyFlavour = False +tcFlavourIsOpen ClassFlavour = False +tcFlavourIsOpen DataTypeFlavour = False +tcFlavourIsOpen NewtypeFlavour = False +tcFlavourIsOpen TupleFlavour{} = False +tcFlavourIsOpen SumFlavour = False +tcFlavourIsOpen AbstractTypeFlavour = False +tcFlavourIsOpen BuiltInTypeFlavour = False +tcFlavourIsOpen PromotedDataConFlavour = False +tcFlavourIsOpen TypeSynonymFlavour = False + +pprPromotionQuote :: TyCon -> SDoc +-- Promoted data constructors already have a tick in their OccName +pprPromotionQuote tc + = case tc of + PromotedDataCon {} -> char '\'' -- Always quote promoted DataCons in types + _ -> empty + +instance NamedThing TyCon where + getName = tyConName + +instance Data.Data TyCon where + -- don't traverse? + toConstr _ = abstractConstr "TyCon" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "TyCon" + +instance Binary Injectivity where + put_ bh NotInjective = putByte bh 0 + put_ bh (Injective xs) = putByte bh 1 >> put_ bh xs + + get bh = do { h <- getByte bh + ; case h of + 0 -> return NotInjective + _ -> do { xs <- get bh + ; return (Injective xs) } } + +{- +************************************************************************ +* * + Walking over recursive TyCons +* * +************************************************************************ + +Note [Expanding newtypes and products] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When expanding a type to expose a data-type constructor, we need to be +careful about newtypes, lest we fall into an infinite loop. Here are +the key examples: + + newtype Id x = MkId x + newtype Fix f = MkFix (f (Fix f)) + newtype T = MkT (T -> T) + + Type Expansion + -------------------------- + T T -> T + Fix Maybe Maybe (Fix Maybe) + Id (Id Int) Int + Fix Id NO NO NO + +Notice that + * We can expand T, even though it's recursive. + * We can expand Id (Id Int), even though the Id shows up + twice at the outer level, because Id is non-recursive + +So, when expanding, we keep track of when we've seen a recursive +newtype at outermost level; and bail out if we see it again. + +We sometimes want to do the same for product types, so that the +strictness analyser doesn't unbox infinitely deeply. + +More precisely, we keep a *count* of how many times we've seen it. +This is to account for + data instance T (a,b) = MkT (T a) (T b) +Then (#10482) if we have a type like + T (Int,(Int,(Int,(Int,Int)))) +we can still unbox deeply enough during strictness analysis. +We have to treat T as potentially recursive, but it's still +good to be able to unwrap multiple layers. + +The function that manages all this is checkRecTc. +-} + +data RecTcChecker = RC !Int (NameEnv Int) + -- The upper bound, and the number of times + -- we have encountered each TyCon + +-- | Initialise a 'RecTcChecker' with 'defaultRecTcMaxBound'. +initRecTc :: RecTcChecker +initRecTc = RC defaultRecTcMaxBound emptyNameEnv + +-- | The default upper bound (100) for the number of times a 'RecTcChecker' is +-- allowed to encounter each 'TyCon'. +defaultRecTcMaxBound :: Int +defaultRecTcMaxBound = 100 +-- Should we have a flag for this? + +-- | Change the upper bound for the number of times a 'RecTcChecker' is allowed +-- to encounter each 'TyCon'. +setRecTcMaxBound :: Int -> RecTcChecker -> RecTcChecker +setRecTcMaxBound new_bound (RC _old_bound rec_nts) = RC new_bound rec_nts + +checkRecTc :: RecTcChecker -> TyCon -> Maybe RecTcChecker +-- Nothing => Recursion detected +-- Just rec_tcs => Keep going +checkRecTc (RC bound rec_nts) tc + = case lookupNameEnv rec_nts tc_name of + Just n | n >= bound -> Nothing + | otherwise -> Just (RC bound (extendNameEnv rec_nts tc_name (n+1))) + Nothing -> Just (RC bound (extendNameEnv rec_nts tc_name 1)) + where + tc_name = tyConName tc + +-- | Returns whether or not this 'TyCon' is definite, or a hole +-- that may be filled in at some later point. See Note [Skolem abstract data] +tyConSkolem :: TyCon -> Bool +tyConSkolem = isHoleName . tyConName + +-- Note [Skolem abstract data] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Skolem abstract data arises from data declarations in an hsig file. +-- +-- The best analogy is to interpret the types declared in signature files as +-- elaborating to universally quantified type variables; e.g., +-- +-- unit p where +-- signature H where +-- data T +-- data S +-- module M where +-- import H +-- f :: (T ~ S) => a -> b +-- f x = x +-- +-- elaborates as (with some fake structural types): +-- +-- p :: forall t s. { f :: forall a b. t ~ s => a -> b } +-- p = { f = \x -> x } -- ill-typed +-- +-- It is clear that inside p, t ~ s is not provable (and +-- if we tried to write a function to cast t to s, that +-- would not work), but if we call p @Int @Int, clearly Int ~ Int +-- is provable. The skolem variables are all distinct from +-- one another, but we can't make assumptions like "f is +-- inaccessible", because the skolem variables will get +-- instantiated eventually! +-- +-- Skolem abstractness can apply to "non-abstract" data as well): +-- +-- unit p where +-- signature H1 where +-- data T = MkT +-- signature H2 where +-- data T = MkT +-- module M where +-- import qualified H1 +-- import qualified H2 +-- f :: (H1.T ~ H2.T) => a -> b +-- f x = x +-- +-- This is why the test is on the original name of the TyCon, +-- not whether it is abstract or not. diff --git a/compiler/types/TyCon.hs-boot b/compiler/types/TyCon.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/types/TyCon.hs-boot @@ -0,0 +1,9 @@ +module TyCon where + +import GhcPrelude + +data TyCon + +isTupleTyCon :: TyCon -> Bool +isUnboxedTupleTyCon :: TyCon -> Bool +isFunTyCon :: TyCon -> Bool diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs new file mode 100644 --- /dev/null +++ b/compiler/types/Type.hs @@ -0,0 +1,3137 @@ +-- (c) The University of Glasgow 2006 +-- (c) The GRASP/AQUA Project, Glasgow University, 1998 +-- +-- Type - public interface + +{-# LANGUAGE CPP, FlexibleContexts #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | Main functions for manipulating types and type-related things +module Type ( + -- Note some of this is just re-exports from TyCon.. + + -- * Main data types representing Types + -- $type_classification + + -- $representation_types + TyThing(..), Type, ArgFlag(..), AnonArgFlag(..), ForallVisFlag(..), + KindOrType, PredType, ThetaType, + Var, TyVar, isTyVar, TyCoVar, TyCoBinder, TyCoVarBinder, TyVarBinder, + KnotTied, + + -- ** Constructing and deconstructing types + mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, repGetTyVar_maybe, + getCastedTyVar_maybe, tyVarKind, varType, + + mkAppTy, mkAppTys, splitAppTy, splitAppTys, repSplitAppTys, + splitAppTy_maybe, repSplitAppTy_maybe, tcRepSplitAppTy_maybe, + + mkVisFunTy, mkInvisFunTy, mkVisFunTys, mkInvisFunTys, + splitFunTy, splitFunTy_maybe, + splitFunTys, funResultTy, funArgTy, + + mkTyConApp, mkTyConTy, + tyConAppTyCon_maybe, tyConAppTyConPicky_maybe, + tyConAppArgs_maybe, tyConAppTyCon, tyConAppArgs, + splitTyConApp_maybe, splitTyConApp, tyConAppArgN, nextRole, + tcSplitTyConApp_maybe, + splitListTyConApp_maybe, + repSplitTyConApp_maybe, + + mkForAllTy, mkForAllTys, mkTyCoInvForAllTys, + mkSpecForAllTy, mkSpecForAllTys, + mkVisForAllTys, mkTyCoInvForAllTy, + mkInvForAllTy, mkInvForAllTys, + splitForAllTys, splitForAllTysSameVis, splitForAllVarBndrs, + splitForAllTy_maybe, splitForAllTy, + splitForAllTy_ty_maybe, splitForAllTy_co_maybe, + splitPiTy_maybe, splitPiTy, splitPiTys, + mkTyConBindersPreferAnon, + mkPiTy, mkPiTys, + mkLamType, mkLamTypes, + piResultTy, piResultTys, + applyTysX, dropForAlls, + + mkNumLitTy, isNumLitTy, + mkStrLitTy, isStrLitTy, + isLitTy, + + getRuntimeRep_maybe, kindRep_maybe, kindRep, + + mkCastTy, mkCoercionTy, splitCastTy_maybe, + + userTypeError_maybe, pprUserTypeErrorTy, + + coAxNthLHS, + stripCoercionTy, splitCoercionType_maybe, + + splitPiTysInvisible, splitPiTysInvisibleN, + invisibleTyBndrCount, + filterOutInvisibleTypes, filterOutInferredTypes, + partitionInvisibleTypes, partitionInvisibles, + tyConArgFlags, appTyArgFlags, + synTyConResKind, + + modifyJoinResTy, setJoinResTy, + + -- Analyzing types + TyCoMapper(..), mapType, mapCoercion, + + -- (Newtypes) + newTyConInstRhs, + + -- Pred types + mkFamilyTyConApp, + isDictLikeTy, + mkPrimEqPred, mkReprPrimEqPred, mkPrimEqPredRole, + equalityTyCon, + mkHeteroPrimEqPred, mkHeteroReprPrimEqPred, + mkClassPred, + isClassPred, isEqPrimPred, isEqPred, isEqPredClass, + isIPPred, isIPPred_maybe, isIPTyCon, isIPClass, + isCTupleClass, + + -- Deconstructing predicate types + PredTree(..), EqRel(..), eqRelRole, classifyPredType, + getClassPredTys, getClassPredTys_maybe, + getEqPredTys, getEqPredTys_maybe, getEqPredRole, + predTypeEqRel, + + -- ** Binders + sameVis, + mkTyCoVarBinder, mkTyCoVarBinders, + mkTyVarBinders, + mkAnonBinder, + isAnonTyCoBinder, + binderVar, binderVars, binderType, binderArgFlag, + tyCoBinderType, tyCoBinderVar_maybe, + tyBinderType, + binderRelevantType_maybe, + isVisibleArgFlag, isInvisibleArgFlag, isVisibleBinder, + isInvisibleBinder, isNamedBinder, + tyConBindersTyCoBinders, + + -- ** Common type constructors + funTyCon, + + -- ** Predicates on types + isTyVarTy, isFunTy, isDictTy, isPredTy, isCoercionTy, + isCoercionTy_maybe, isForAllTy, + isForAllTy_ty, isForAllTy_co, + isPiTy, isTauTy, isFamFreeTy, + isCoVarType, isEvVarType, + + isValidJoinPointType, + + -- (Lifting and boxity) + isLiftedType_maybe, isUnliftedType, isUnboxedTupleType, isUnboxedSumType, + isAlgType, isDataFamilyAppType, + isPrimitiveType, isStrictType, + isRuntimeRepTy, isRuntimeRepVar, isRuntimeRepKindedTy, + dropRuntimeRepArgs, + getRuntimeRep, + + -- * Main data types representing Kinds + Kind, + + -- ** Finding the kind of a type + typeKind, tcTypeKind, isTypeLevPoly, resultIsLevPoly, + tcIsLiftedTypeKind, tcIsConstraintKind, tcReturnsConstraintKind, + + -- ** Common Kind + liftedTypeKind, + + -- * Type free variables + tyCoFVsOfType, tyCoFVsBndr, tyCoFVsVarBndr, tyCoFVsVarBndrs, + tyCoVarsOfType, tyCoVarsOfTypes, + tyCoVarsOfTypeDSet, + coVarsOfType, + coVarsOfTypes, + closeOverKindsDSet, closeOverKindsFV, closeOverKindsList, + closeOverKinds, + + noFreeVarsOfType, + splitVisVarsOfType, splitVisVarsOfTypes, + expandTypeSynonyms, + typeSize, occCheckExpand, + + -- * Well-scoped lists of variables + dVarSetElemsWellScoped, scopedSort, tyCoVarsOfTypeWellScoped, + tyCoVarsOfTypesWellScoped, tyCoVarsOfBindersWellScoped, + + -- * Type comparison + eqType, eqTypeX, eqTypes, nonDetCmpType, nonDetCmpTypes, nonDetCmpTypeX, + nonDetCmpTypesX, nonDetCmpTc, + eqVarBndrs, + + -- * Forcing evaluation of types + seqType, seqTypes, + + -- * Other views onto Types + coreView, tcView, + + tyConsOfType, + + -- * Main type substitution data types + TvSubstEnv, -- Representation widely visible + TCvSubst(..), -- Representation visible to a few friends + + -- ** Manipulating type substitutions + emptyTvSubstEnv, emptyTCvSubst, mkEmptyTCvSubst, + + mkTCvSubst, zipTvSubst, mkTvSubstPrs, + zipTCvSubst, + notElemTCvSubst, + getTvSubstEnv, setTvSubstEnv, + zapTCvSubst, getTCvInScope, getTCvSubstRangeFVs, + extendTCvInScope, extendTCvInScopeList, extendTCvInScopeSet, + extendTCvSubst, extendCvSubst, + extendTvSubst, extendTvSubstBinderAndInScope, + extendTvSubstList, extendTvSubstAndInScope, + extendTCvSubstList, + extendTvSubstWithClone, + extendTCvSubstWithClone, + isInScope, composeTCvSubstEnv, composeTCvSubst, zipTyEnv, zipCoEnv, + isEmptyTCvSubst, unionTCvSubst, + + -- ** Performing substitution on types and kinds + substTy, substTys, substTyWith, substTysWith, substTheta, + substTyAddInScope, + substTyUnchecked, substTysUnchecked, substThetaUnchecked, + substTyWithUnchecked, + substCoUnchecked, substCoWithUnchecked, + substTyVarBndr, substTyVarBndrs, substTyVar, substTyVars, + substVarBndr, substVarBndrs, + cloneTyVarBndr, cloneTyVarBndrs, lookupTyVar, + + -- * Pretty-printing + pprType, pprParendType, pprPrecType, + pprTypeApp, pprTyThingCategory, pprShortTyThing, + pprTCvBndr, pprTCvBndrs, pprForAll, pprUserForAll, + pprSigmaType, pprWithExplicitKindsWhen, + pprTheta, pprThetaArrowTy, pprClassPred, + pprKind, pprParendKind, pprSourceTyCon, + PprPrec(..), topPrec, sigPrec, opPrec, funPrec, appPrec, maybeParen, + pprTyVar, pprTyVars, + pprWithTYPE, + + -- * Tidying type related things up for printing + tidyType, tidyTypes, + tidyOpenType, tidyOpenTypes, + tidyOpenKind, + tidyVarBndr, tidyVarBndrs, tidyFreeTyCoVars, + tidyOpenTyCoVar, tidyOpenTyCoVars, + tidyTyCoVarOcc, + tidyTopType, + tidyKind, + tidyTyCoVarBinder, tidyTyCoVarBinders + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import BasicTypes + +-- We import the representation and primitive functions from TyCoRep. +-- Many things are reexported, but not the representation! + +import Kind +import TyCoRep + +-- friends: +import Var +import VarEnv +import VarSet +import UniqSet + +import Class +import TyCon +import TysPrim +import {-# SOURCE #-} TysWiredIn ( listTyCon, typeNatKind, unitTy + , typeSymbolKind, liftedTypeKind + , constraintKind ) +import PrelNames +import CoAxiom +import {-# SOURCE #-} Coercion( mkNomReflCo, mkGReflCo, mkReflCo + , mkTyConAppCo, mkAppCo, mkCoVarCo, mkAxiomRuleCo + , mkForAllCo, mkFunCo, mkAxiomInstCo, mkUnivCo + , mkSymCo, mkTransCo, mkNthCo, mkLRCo, mkInstCo + , mkKindCo, mkSubCo, mkFunCo, mkAxiomInstCo + , decomposePiCos, coercionKind, coercionType + , isReflexiveCo, seqCo ) + +-- others +import Util +import FV +import Outputable +import FastString +import Pair +import DynFlags ( gopt_set, GeneralFlag(Opt_PrintExplicitRuntimeReps) ) +import ListSetOps +import Unique ( nonDetCmpUnique ) + +import Maybes ( orElse ) +import Data.Maybe ( isJust ) +import Control.Monad ( guard ) + +-- $type_classification +-- #type_classification# +-- +-- Types are one of: +-- +-- [Unboxed] Iff its representation is other than a pointer +-- Unboxed types are also unlifted. +-- +-- [Lifted] Iff it has bottom as an element. +-- Closures always have lifted types: i.e. any +-- let-bound identifier in Core must have a lifted +-- type. Operationally, a lifted object is one that +-- can be entered. +-- Only lifted types may be unified with a type variable. +-- +-- [Algebraic] Iff it is a type with one or more constructors, whether +-- declared with @data@ or @newtype@. +-- An algebraic type is one that can be deconstructed +-- with a case expression. This is /not/ the same as +-- lifted types, because we also include unboxed +-- tuples in this classification. +-- +-- [Data] Iff it is a type declared with @data@, or a boxed tuple. +-- +-- [Primitive] Iff it is a built-in type that can't be expressed in Haskell. +-- +-- Currently, all primitive types are unlifted, but that's not necessarily +-- the case: for example, @Int@ could be primitive. +-- +-- Some primitive types are unboxed, such as @Int#@, whereas some are boxed +-- but unlifted (such as @ByteArray#@). The only primitive types that we +-- classify as algebraic are the unboxed tuples. +-- +-- Some examples of type classifications that may make this a bit clearer are: +-- +-- @ +-- Type primitive boxed lifted algebraic +-- ----------------------------------------------------------------------------- +-- Int# Yes No No No +-- ByteArray# Yes Yes No No +-- (\# a, b \#) Yes No No Yes +-- (\# a | b \#) Yes No No Yes +-- ( a, b ) No Yes Yes Yes +-- [a] No Yes Yes Yes +-- @ + +-- $representation_types +-- A /source type/ is a type that is a separate type as far as the type checker is +-- concerned, but which has a more low-level representation as far as Core-to-Core +-- passes and the rest of the back end is concerned. +-- +-- You don't normally have to worry about this, as the utility functions in +-- this module will automatically convert a source into a representation type +-- if they are spotted, to the best of its abilities. If you don't want this +-- to happen, use the equivalent functions from the "TcType" module. + +{- +************************************************************************ +* * + Type representation +* * +************************************************************************ + +Note [coreView vs tcView] +~~~~~~~~~~~~~~~~~~~~~~~~~ +So far as the typechecker is concerned, 'Constraint' and 'TYPE +LiftedRep' are distinct kinds. + +But in Core these two are treated as identical. + +We implement this by making 'coreView' convert 'Constraint' to 'TYPE +LiftedRep' on the fly. The function tcView (used in the type checker) +does not do this. + +See also #11715, which tracks removing this inconsistency. + +-} + +-- | Gives the typechecker view of a type. This unwraps synonyms but +-- leaves 'Constraint' alone. c.f. coreView, which turns Constraint into +-- TYPE LiftedRep. Returns Nothing if no unwrapping happens. +-- See also Note [coreView vs tcView] +{-# INLINE tcView #-} +tcView :: Type -> Maybe Type +tcView (TyConApp tc tys) | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys + = Just (mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys') + -- The free vars of 'rhs' should all be bound by 'tenv', so it's + -- ok to use 'substTy' here. + -- See also Note [The substitution invariant] in TyCoRep. + -- Its important to use mkAppTys, rather than (foldl AppTy), + -- because the function part might well return a + -- partially-applied type constructor; indeed, usually will! +tcView _ = Nothing + +{-# INLINE coreView #-} +coreView :: Type -> Maybe Type +-- ^ This function Strips off the /top layer only/ of a type synonym +-- application (if any) its underlying representation type. +-- Returns Nothing if there is nothing to look through. +-- This function considers 'Constraint' to be a synonym of @TYPE LiftedRep@. +-- +-- By being non-recursive and inlined, this case analysis gets efficiently +-- joined onto the case analysis that the caller is already doing +coreView ty@(TyConApp tc tys) + | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys + = Just (mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys') + -- This equation is exactly like tcView + + -- At the Core level, Constraint = Type + -- See Note [coreView vs tcView] + | isConstraintKindCon tc + = ASSERT2( null tys, ppr ty ) + Just liftedTypeKind + +coreView _ = Nothing + +----------------------------------------------- +expandTypeSynonyms :: Type -> Type +-- ^ Expand out all type synonyms. Actually, it'd suffice to expand out +-- just the ones that discard type variables (e.g. type Funny a = Int) +-- But we don't know which those are currently, so we just expand all. +-- +-- 'expandTypeSynonyms' only expands out type synonyms mentioned in the type, +-- not in the kinds of any TyCon or TyVar mentioned in the type. +-- +-- Keep this synchronized with 'synonymTyConsOfType' +expandTypeSynonyms ty + = go (mkEmptyTCvSubst in_scope) ty + where + in_scope = mkInScopeSet (tyCoVarsOfType ty) + + go subst (TyConApp tc tys) + | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc expanded_tys + = let subst' = mkTvSubst in_scope (mkVarEnv tenv) + -- Make a fresh substitution; rhs has nothing to + -- do with anything that has happened so far + -- NB: if you make changes here, be sure to build an + -- /idempotent/ substitution, even in the nested case + -- type T a b = a -> b + -- type S x y = T y x + -- (#11665) + in mkAppTys (go subst' rhs) tys' + | otherwise + = TyConApp tc expanded_tys + where + expanded_tys = (map (go subst) tys) + + go _ (LitTy l) = LitTy l + go subst (TyVarTy tv) = substTyVar subst tv + go subst (AppTy t1 t2) = mkAppTy (go subst t1) (go subst t2) + go subst ty@(FunTy _ arg res) + = ty { ft_arg = go subst arg, ft_res = go subst res } + go subst (ForAllTy (Bndr tv vis) t) + = let (subst', tv') = substVarBndrUsing go subst tv in + ForAllTy (Bndr tv' vis) (go subst' t) + go subst (CastTy ty co) = mkCastTy (go subst ty) (go_co subst co) + go subst (CoercionTy co) = mkCoercionTy (go_co subst co) + + go_mco _ MRefl = MRefl + go_mco subst (MCo co) = MCo (go_co subst co) + + go_co subst (Refl ty) + = mkNomReflCo (go subst ty) + go_co subst (GRefl r ty mco) + = mkGReflCo r (go subst ty) (go_mco subst mco) + -- NB: coercions are always expanded upon creation + go_co subst (TyConAppCo r tc args) + = mkTyConAppCo r tc (map (go_co subst) args) + go_co subst (AppCo co arg) + = mkAppCo (go_co subst co) (go_co subst arg) + go_co subst (ForAllCo tv kind_co co) + = let (subst', tv', kind_co') = go_cobndr subst tv kind_co in + mkForAllCo tv' kind_co' (go_co subst' co) + go_co subst (FunCo r co1 co2) + = mkFunCo r (go_co subst co1) (go_co subst co2) + go_co subst (CoVarCo cv) + = substCoVar subst cv + go_co subst (AxiomInstCo ax ind args) + = mkAxiomInstCo ax ind (map (go_co subst) args) + go_co subst (UnivCo p r t1 t2) + = mkUnivCo (go_prov subst p) r (go subst t1) (go subst t2) + go_co subst (SymCo co) + = mkSymCo (go_co subst co) + go_co subst (TransCo co1 co2) + = mkTransCo (go_co subst co1) (go_co subst co2) + go_co subst (NthCo r n co) + = mkNthCo r n (go_co subst co) + go_co subst (LRCo lr co) + = mkLRCo lr (go_co subst co) + go_co subst (InstCo co arg) + = mkInstCo (go_co subst co) (go_co subst arg) + go_co subst (KindCo co) + = mkKindCo (go_co subst co) + go_co subst (SubCo co) + = mkSubCo (go_co subst co) + go_co subst (AxiomRuleCo ax cs) + = AxiomRuleCo ax (map (go_co subst) cs) + go_co _ (HoleCo h) + = pprPanic "expandTypeSynonyms hit a hole" (ppr h) + + go_prov _ UnsafeCoerceProv = UnsafeCoerceProv + go_prov subst (PhantomProv co) = PhantomProv (go_co subst co) + go_prov subst (ProofIrrelProv co) = ProofIrrelProv (go_co subst co) + go_prov _ p@(PluginProv _) = p + + -- the "False" and "const" are to accommodate the type of + -- substForAllCoBndrUsing, which is general enough to + -- handle coercion optimization (which sometimes swaps the + -- order of a coercion) + go_cobndr subst = substForAllCoBndrUsing False (go_co subst) subst + +{- +************************************************************************ +* * + Analyzing types +* * +************************************************************************ + +These functions do a map-like operation over types, performing some operation +on all variables and binding sites. Primarily used for zonking. + +Note [Efficiency for mapCoercion ForAllCo case] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As noted in Note [Forall coercions] in TyCoRep, a ForAllCo is a bit redundant. +It stores a TyCoVar and a Coercion, where the kind of the TyCoVar always matches +the left-hand kind of the coercion. This is convenient lots of the time, but +not when mapping a function over a coercion. + +The problem is that tcm_tybinder will affect the TyCoVar's kind and +mapCoercion will affect the Coercion, and we hope that the results will be +the same. Even if they are the same (which should generally happen with +correct algorithms), then there is an efficiency issue. In particular, +this problem seems to make what should be a linear algorithm into a potentially +exponential one. But it's only going to be bad in the case where there's +lots of foralls in the kinds of other foralls. Like this: + + forall a : (forall b : (forall c : ...). ...). ... + +This construction seems unlikely. So we'll do the inefficient, easy way +for now. + +Note [Specialising mappers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +These INLINABLE pragmas are indispensable. mapType/mapCoercion are used +to implement zonking, and it's vital that they get specialised to the TcM +monad. This specialisation happens automatically (that is, without a +SPECIALISE pragma) as long as the definitions are INLINABLE. For example, +this one change made a 20% allocation difference in perf/compiler/T5030. + +-} + +-- | This describes how a "map" operation over a type/coercion should behave +data TyCoMapper env m + = TyCoMapper + { tcm_tyvar :: env -> TyVar -> m Type + , tcm_covar :: env -> CoVar -> m Coercion + , tcm_hole :: env -> CoercionHole -> m Coercion + -- ^ What to do with coercion holes. + -- See Note [Coercion holes] in TyCoRep. + + , tcm_tycobinder :: env -> TyCoVar -> ArgFlag -> m (env, TyCoVar) + -- ^ The returned env is used in the extended scope + + , tcm_tycon :: TyCon -> m TyCon + -- ^ This is used only for TcTyCons + -- a) To zonk TcTyCons + -- b) To turn TcTyCons into TyCons. + -- See Note [Type checking recursive type and class declarations] + -- in TcTyClsDecls + } + +{-# INLINABLE mapType #-} -- See Note [Specialising mappers] +mapType :: Monad m => TyCoMapper env m -> env -> Type -> m Type +mapType mapper@(TyCoMapper { tcm_tyvar = tyvar + , tcm_tycobinder = tycobinder + , tcm_tycon = tycon }) + env ty + = go ty + where + go (TyVarTy tv) = tyvar env tv + go (AppTy t1 t2) = mkAppTy <$> go t1 <*> go t2 + go ty@(LitTy {}) = return ty + go (CastTy ty co) = mkCastTy <$> go ty <*> mapCoercion mapper env co + go (CoercionTy co) = CoercionTy <$> mapCoercion mapper env co + + go ty@(FunTy _ arg res) + = do { arg' <- go arg; res' <- go res + ; return (ty { ft_arg = arg', ft_res = res' }) } + + go ty@(TyConApp tc tys) + | isTcTyCon tc + = do { tc' <- tycon tc + ; mkTyConApp tc' <$> mapM go tys } + + -- Not a TcTyCon + | null tys -- Avoid allocation in this very + = return ty -- common case (E.g. Int, LiftedRep etc) + + | otherwise + = mkTyConApp tc <$> mapM go tys + + go (ForAllTy (Bndr tv vis) inner) + = do { (env', tv') <- tycobinder env tv vis + ; inner' <- mapType mapper env' inner + ; return $ ForAllTy (Bndr tv' vis) inner' } + +{-# INLINABLE mapCoercion #-} -- See Note [Specialising mappers] +mapCoercion :: Monad m + => TyCoMapper env m -> env -> Coercion -> m Coercion +mapCoercion mapper@(TyCoMapper { tcm_covar = covar + , tcm_hole = cohole + , tcm_tycobinder = tycobinder + , tcm_tycon = tycon }) + env co + = go co + where + go_mco MRefl = return MRefl + go_mco (MCo co) = MCo <$> (go co) + + go (Refl ty) = Refl <$> mapType mapper env ty + go (GRefl r ty mco) = mkGReflCo r <$> mapType mapper env ty <*> (go_mco mco) + go (TyConAppCo r tc args) + = do { tc' <- if isTcTyCon tc + then tycon tc + else return tc + ; mkTyConAppCo r tc' <$> mapM go args } + go (AppCo c1 c2) = mkAppCo <$> go c1 <*> go c2 + go (ForAllCo tv kind_co co) + = do { kind_co' <- go kind_co + ; (env', tv') <- tycobinder env tv Inferred + ; co' <- mapCoercion mapper env' co + ; return $ mkForAllCo tv' kind_co' co' } + -- See Note [Efficiency for mapCoercion ForAllCo case] + go (FunCo r c1 c2) = mkFunCo r <$> go c1 <*> go c2 + go (CoVarCo cv) = covar env cv + go (AxiomInstCo ax i args) + = mkAxiomInstCo ax i <$> mapM go args + go (HoleCo hole) = cohole env hole + go (UnivCo p r t1 t2) + = mkUnivCo <$> go_prov p <*> pure r + <*> mapType mapper env t1 <*> mapType mapper env t2 + go (SymCo co) = mkSymCo <$> go co + go (TransCo c1 c2) = mkTransCo <$> go c1 <*> go c2 + go (AxiomRuleCo r cos) = AxiomRuleCo r <$> mapM go cos + go (NthCo r i co) = mkNthCo r i <$> go co + go (LRCo lr co) = mkLRCo lr <$> go co + go (InstCo co arg) = mkInstCo <$> go co <*> go arg + go (KindCo co) = mkKindCo <$> go co + go (SubCo co) = mkSubCo <$> go co + + go_prov UnsafeCoerceProv = return UnsafeCoerceProv + go_prov (PhantomProv co) = PhantomProv <$> go co + go_prov (ProofIrrelProv co) = ProofIrrelProv <$> go co + go_prov p@(PluginProv _) = return p + +{- +************************************************************************ +* * +\subsection{Constructor-specific functions} +* * +************************************************************************ + + +--------------------------------------------------------------------- + TyVarTy + ~~~~~~~ +-} + +-- | Attempts to obtain the type variable underlying a 'Type', and panics with the +-- given message if this is not a type variable type. See also 'getTyVar_maybe' +getTyVar :: String -> Type -> TyVar +getTyVar msg ty = case getTyVar_maybe ty of + Just tv -> tv + Nothing -> panic ("getTyVar: " ++ msg) + +isTyVarTy :: Type -> Bool +isTyVarTy ty = isJust (getTyVar_maybe ty) + +-- | Attempts to obtain the type variable underlying a 'Type' +getTyVar_maybe :: Type -> Maybe TyVar +getTyVar_maybe ty | Just ty' <- coreView ty = getTyVar_maybe ty' + | otherwise = repGetTyVar_maybe ty + +-- | If the type is a tyvar, possibly under a cast, returns it, along +-- with the coercion. Thus, the co is :: kind tv ~N kind ty +getCastedTyVar_maybe :: Type -> Maybe (TyVar, CoercionN) +getCastedTyVar_maybe ty | Just ty' <- coreView ty = getCastedTyVar_maybe ty' +getCastedTyVar_maybe (CastTy (TyVarTy tv) co) = Just (tv, co) +getCastedTyVar_maybe (TyVarTy tv) + = Just (tv, mkReflCo Nominal (tyVarKind tv)) +getCastedTyVar_maybe _ = Nothing + +-- | Attempts to obtain the type variable underlying a 'Type', without +-- any expansion +repGetTyVar_maybe :: Type -> Maybe TyVar +repGetTyVar_maybe (TyVarTy tv) = Just tv +repGetTyVar_maybe _ = Nothing + +{- +--------------------------------------------------------------------- + AppTy + ~~~~~ +We need to be pretty careful with AppTy to make sure we obey the +invariant that a TyConApp is always visibly so. mkAppTy maintains the +invariant: use it. + +Note [Decomposing fat arrow c=>t] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Can we unify (a b) with (Eq a => ty)? If we do so, we end up with +a partial application like ((=>) Eq a) which doesn't make sense in +source Haskell. In contrast, we *can* unify (a b) with (t1 -> t2). +Here's an example (#9858) of how you might do it: + i :: (Typeable a, Typeable b) => Proxy (a b) -> TypeRep + i p = typeRep p + + j = i (Proxy :: Proxy (Eq Int => Int)) +The type (Proxy (Eq Int => Int)) is only accepted with -XImpredicativeTypes, +but suppose we want that. But then in the call to 'i', we end +up decomposing (Eq Int => Int), and we definitely don't want that. + +This really only applies to the type checker; in Core, '=>' and '->' +are the same, as are 'Constraint' and '*'. But for now I've put +the test in repSplitAppTy_maybe, which applies throughout, because +the other calls to splitAppTy are in Unify, which is also used by +the type checker (e.g. when matching type-function equations). + +-} + +-- | Applies a type to another, as in e.g. @k a@ +mkAppTy :: Type -> Type -> Type + -- See Note [Respecting definitional equality], invariant (EQ1). +mkAppTy (CastTy fun_ty co) arg_ty + | ([arg_co], res_co) <- decomposePiCos co (coercionKind co) [arg_ty] + = (fun_ty `mkAppTy` (arg_ty `mkCastTy` arg_co)) `mkCastTy` res_co + +mkAppTy (TyConApp tc tys) ty2 = mkTyConApp tc (tys ++ [ty2]) +mkAppTy ty1 ty2 = AppTy ty1 ty2 + -- Note that the TyConApp could be an + -- under-saturated type synonym. GHC allows that; e.g. + -- type Foo k = k a -> k a + -- type Id x = x + -- foo :: Foo Id -> Foo Id + -- + -- Here Id is partially applied in the type sig for Foo, + -- but once the type synonyms are expanded all is well + -- + -- Moreover in TcHsTypes.tcInferApps we build up a type + -- (T t1 t2 t3) one argument at a type, thus forming + -- (T t1), (T t1 t2), etc + +mkAppTys :: Type -> [Type] -> Type +mkAppTys ty1 [] = ty1 +mkAppTys (CastTy fun_ty co) arg_tys -- much more efficient then nested mkAppTy + -- Why do this? See (EQ1) of + -- Note [Respecting definitional equality] + -- in TyCoRep + = foldl' AppTy ((mkAppTys fun_ty casted_arg_tys) `mkCastTy` res_co) leftovers + where + (arg_cos, res_co) = decomposePiCos co (coercionKind co) arg_tys + (args_to_cast, leftovers) = splitAtList arg_cos arg_tys + casted_arg_tys = zipWith mkCastTy args_to_cast arg_cos +mkAppTys (TyConApp tc tys1) tys2 = mkTyConApp tc (tys1 ++ tys2) +mkAppTys ty1 tys2 = foldl' AppTy ty1 tys2 + +------------- +splitAppTy_maybe :: Type -> Maybe (Type, Type) +-- ^ Attempt to take a type application apart, whether it is a +-- function, type constructor, or plain type application. Note +-- that type family applications are NEVER unsaturated by this! +splitAppTy_maybe ty | Just ty' <- coreView ty + = splitAppTy_maybe ty' +splitAppTy_maybe ty = repSplitAppTy_maybe ty + +------------- +repSplitAppTy_maybe :: HasDebugCallStack => Type -> Maybe (Type,Type) +-- ^ Does the AppTy split as in 'splitAppTy_maybe', but assumes that +-- any Core view stuff is already done +repSplitAppTy_maybe (FunTy _ ty1 ty2) + = Just (TyConApp funTyCon [rep1, rep2, ty1], ty2) + where + rep1 = getRuntimeRep ty1 + rep2 = getRuntimeRep ty2 + +repSplitAppTy_maybe (AppTy ty1 ty2) + = Just (ty1, ty2) + +repSplitAppTy_maybe (TyConApp tc tys) + | not (mustBeSaturated tc) || tys `lengthExceeds` tyConArity tc + , Just (tys', ty') <- snocView tys + = Just (TyConApp tc tys', ty') -- Never create unsaturated type family apps! + +repSplitAppTy_maybe _other = Nothing + +-- This one doesn't break apart (c => t). +-- See Note [Decomposing fat arrow c=>t] +-- Defined here to avoid module loops between Unify and TcType. +tcRepSplitAppTy_maybe :: Type -> Maybe (Type,Type) +-- ^ Does the AppTy split as in 'tcSplitAppTy_maybe', but assumes that +-- any coreView stuff is already done. Refuses to look through (c => t) +tcRepSplitAppTy_maybe (FunTy { ft_af = af, ft_arg = ty1, ft_res = ty2 }) + | InvisArg <- af + = Nothing -- See Note [Decomposing fat arrow c=>t] + + | otherwise + = Just (TyConApp funTyCon [rep1, rep2, ty1], ty2) + where + rep1 = getRuntimeRep ty1 + rep2 = getRuntimeRep ty2 + +tcRepSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2) +tcRepSplitAppTy_maybe (TyConApp tc tys) + | not (mustBeSaturated tc) || tys `lengthExceeds` tyConArity tc + , Just (tys', ty') <- snocView tys + = Just (TyConApp tc tys', ty') -- Never create unsaturated type family apps! +tcRepSplitAppTy_maybe _other = Nothing + +------------- +splitAppTy :: Type -> (Type, Type) +-- ^ Attempts to take a type application apart, as in 'splitAppTy_maybe', +-- and panics if this is not possible +splitAppTy ty = case splitAppTy_maybe ty of + Just pr -> pr + Nothing -> panic "splitAppTy" + +------------- +splitAppTys :: Type -> (Type, [Type]) +-- ^ Recursively splits a type as far as is possible, leaving a residual +-- type being applied to and the type arguments applied to it. Never fails, +-- even if that means returning an empty list of type applications. +splitAppTys ty = split ty ty [] + where + split orig_ty ty args | Just ty' <- coreView ty = split orig_ty ty' args + split _ (AppTy ty arg) args = split ty ty (arg:args) + split _ (TyConApp tc tc_args) args + = let -- keep type families saturated + n | mustBeSaturated tc = tyConArity tc + | otherwise = 0 + (tc_args1, tc_args2) = splitAt n tc_args + in + (TyConApp tc tc_args1, tc_args2 ++ args) + split _ (FunTy _ ty1 ty2) args + = ASSERT( null args ) + (TyConApp funTyCon [], [rep1, rep2, ty1, ty2]) + where + rep1 = getRuntimeRep ty1 + rep2 = getRuntimeRep ty2 + + split orig_ty _ args = (orig_ty, args) + +-- | Like 'splitAppTys', but doesn't look through type synonyms +repSplitAppTys :: HasDebugCallStack => Type -> (Type, [Type]) +repSplitAppTys ty = split ty [] + where + split (AppTy ty arg) args = split ty (arg:args) + split (TyConApp tc tc_args) args + = let n | mustBeSaturated tc = tyConArity tc + | otherwise = 0 + (tc_args1, tc_args2) = splitAt n tc_args + in + (TyConApp tc tc_args1, tc_args2 ++ args) + split (FunTy _ ty1 ty2) args + = ASSERT( null args ) + (TyConApp funTyCon [], [rep1, rep2, ty1, ty2]) + where + rep1 = getRuntimeRep ty1 + rep2 = getRuntimeRep ty2 + + split ty args = (ty, args) + +{- + LitTy + ~~~~~ +-} + +mkNumLitTy :: Integer -> Type +mkNumLitTy n = LitTy (NumTyLit n) + +-- | Is this a numeric literal. We also look through type synonyms. +isNumLitTy :: Type -> Maybe Integer +isNumLitTy ty | Just ty1 <- coreView ty = isNumLitTy ty1 +isNumLitTy (LitTy (NumTyLit n)) = Just n +isNumLitTy _ = Nothing + +mkStrLitTy :: FastString -> Type +mkStrLitTy s = LitTy (StrTyLit s) + +-- | Is this a symbol literal. We also look through type synonyms. +isStrLitTy :: Type -> Maybe FastString +isStrLitTy ty | Just ty1 <- coreView ty = isStrLitTy ty1 +isStrLitTy (LitTy (StrTyLit s)) = Just s +isStrLitTy _ = Nothing + +-- | Is this a type literal (symbol or numeric). +isLitTy :: Type -> Maybe TyLit +isLitTy ty | Just ty1 <- coreView ty = isLitTy ty1 +isLitTy (LitTy l) = Just l +isLitTy _ = Nothing + +-- | Is this type a custom user error? +-- If so, give us the kind and the error message. +userTypeError_maybe :: Type -> Maybe Type +userTypeError_maybe t + = do { (tc, _kind : msg : _) <- splitTyConApp_maybe t + -- There may be more than 2 arguments, if the type error is + -- used as a type constructor (e.g. at kind `Type -> Type`). + + ; guard (tyConName tc == errorMessageTypeErrorFamName) + ; return msg } + +-- | Render a type corresponding to a user type error into a SDoc. +pprUserTypeErrorTy :: Type -> SDoc +pprUserTypeErrorTy ty = + case splitTyConApp_maybe ty of + + -- Text "Something" + Just (tc,[txt]) + | tyConName tc == typeErrorTextDataConName + , Just str <- isStrLitTy txt -> ftext str + + -- ShowType t + Just (tc,[_k,t]) + | tyConName tc == typeErrorShowTypeDataConName -> ppr t + + -- t1 :<>: t2 + Just (tc,[t1,t2]) + | tyConName tc == typeErrorAppendDataConName -> + pprUserTypeErrorTy t1 <> pprUserTypeErrorTy t2 + + -- t1 :$$: t2 + Just (tc,[t1,t2]) + | tyConName tc == typeErrorVAppendDataConName -> + pprUserTypeErrorTy t1 $$ pprUserTypeErrorTy t2 + + -- An unevaluated type function + _ -> ppr ty + + + + +{- +--------------------------------------------------------------------- + FunTy + ~~~~~ + +Note [Representation of function types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Functions (e.g. Int -> Char) can be thought of as being applications +of funTyCon (known in Haskell surface syntax as (->)), + + (->) :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep) + (a :: TYPE r1) (b :: TYPE r2). + a -> b -> Type + +However, for efficiency's sake we represent saturated applications of (->) +with FunTy. For instance, the type, + + (->) r1 r2 a b + +is equivalent to, + + FunTy (Anon a) b + +Note how the RuntimeReps are implied in the FunTy representation. For this +reason we must be careful when recontructing the TyConApp representation (see, +for instance, splitTyConApp_maybe). + +In the compiler we maintain the invariant that all saturated applications of +(->) are represented with FunTy. + +See #11714. +-} + +splitFunTy :: Type -> (Type, Type) +-- ^ Attempts to extract the argument and result types from a type, and +-- panics if that is not possible. See also 'splitFunTy_maybe' +splitFunTy ty | Just ty' <- coreView ty = splitFunTy ty' +splitFunTy (FunTy _ arg res) = (arg, res) +splitFunTy other = pprPanic "splitFunTy" (ppr other) + +splitFunTy_maybe :: Type -> Maybe (Type, Type) +-- ^ Attempts to extract the argument and result types from a type +splitFunTy_maybe ty | Just ty' <- coreView ty = splitFunTy_maybe ty' +splitFunTy_maybe (FunTy _ arg res) = Just (arg, res) +splitFunTy_maybe _ = Nothing + +splitFunTys :: Type -> ([Type], Type) +splitFunTys ty = split [] ty ty + where + split args orig_ty ty | Just ty' <- coreView ty = split args orig_ty ty' + split args _ (FunTy _ arg res) = split (arg:args) res res + split args orig_ty _ = (reverse args, orig_ty) + +funResultTy :: Type -> Type +-- ^ Extract the function result type and panic if that is not possible +funResultTy ty | Just ty' <- coreView ty = funResultTy ty' +funResultTy (FunTy { ft_res = res }) = res +funResultTy ty = pprPanic "funResultTy" (ppr ty) + +funArgTy :: Type -> Type +-- ^ Extract the function argument type and panic if that is not possible +funArgTy ty | Just ty' <- coreView ty = funArgTy ty' +funArgTy (FunTy { ft_arg = arg }) = arg +funArgTy ty = pprPanic "funArgTy" (ppr ty) + +-- ^ Just like 'piResultTys' but for a single argument +-- Try not to iterate 'piResultTy', because it's inefficient to substitute +-- one variable at a time; instead use 'piResultTys" +piResultTy :: HasDebugCallStack => Type -> Type -> Type +piResultTy ty arg = case piResultTy_maybe ty arg of + Just res -> res + Nothing -> pprPanic "piResultTy" (ppr ty $$ ppr arg) + +piResultTy_maybe :: Type -> Type -> Maybe Type +-- We don't need a 'tc' version, because +-- this function behaves the same for Type and Constraint +piResultTy_maybe ty arg + | Just ty' <- coreView ty = piResultTy_maybe ty' arg + + | FunTy { ft_res = res } <- ty + = Just res + + | ForAllTy (Bndr tv _) res <- ty + = let empty_subst = mkEmptyTCvSubst $ mkInScopeSet $ + tyCoVarsOfTypes [arg,res] + in Just (substTy (extendTCvSubst empty_subst tv arg) res) + + | otherwise + = Nothing + +-- | (piResultTys f_ty [ty1, .., tyn]) gives the type of (f ty1 .. tyn) +-- where f :: f_ty +-- 'piResultTys' is interesting because: +-- 1. 'f_ty' may have more for-alls than there are args +-- 2. Less obviously, it may have fewer for-alls +-- For case 2. think of: +-- piResultTys (forall a.a) [forall b.b, Int] +-- This really can happen, but only (I think) in situations involving +-- undefined. For example: +-- undefined :: forall a. a +-- Term: undefined @(forall b. b->b) @Int +-- This term should have type (Int -> Int), but notice that +-- there are more type args than foralls in 'undefined's type. + +-- If you edit this function, you may need to update the GHC formalism +-- See Note [GHC Formalism] in coreSyn/CoreLint.hs + +-- This is a heavily used function (e.g. from typeKind), +-- so we pay attention to efficiency, especially in the special case +-- where there are no for-alls so we are just dropping arrows from +-- a function type/kind. +piResultTys :: HasDebugCallStack => Type -> [Type] -> Type +piResultTys ty [] = ty +piResultTys ty orig_args@(arg:args) + | Just ty' <- coreView ty + = piResultTys ty' orig_args + + | FunTy { ft_res = res } <- ty + = piResultTys res args + + | ForAllTy (Bndr tv _) res <- ty + = go (extendTCvSubst init_subst tv arg) res args + + | otherwise + = pprPanic "piResultTys1" (ppr ty $$ ppr orig_args) + where + init_subst = mkEmptyTCvSubst $ mkInScopeSet (tyCoVarsOfTypes (ty:orig_args)) + + go :: TCvSubst -> Type -> [Type] -> Type + go subst ty [] = substTy subst ty + + go subst ty all_args@(arg:args) + | Just ty' <- coreView ty + = go subst ty' all_args + + | FunTy { ft_res = res } <- ty + = go subst res args + + | ForAllTy (Bndr tv _) res <- ty + = go (extendTCvSubst subst tv arg) res args + + | not (isEmptyTCvSubst subst) -- See Note [Care with kind instantiation] + = go init_subst + (substTy subst ty) + all_args + + | otherwise + = -- We have not run out of arguments, but the function doesn't + -- have the right kind to apply to them; so panic. + -- Without the explicit isEmptyVarEnv test, an ill-kinded type + -- would give an infniite loop, which is very unhelpful + -- c.f. #15473 + pprPanic "piResultTys2" (ppr ty $$ ppr orig_args $$ ppr all_args) + +applyTysX :: [TyVar] -> Type -> [Type] -> Type +-- applyTyxX beta-reduces (/\tvs. body_ty) arg_tys +-- Assumes that (/\tvs. body_ty) is closed +applyTysX tvs body_ty arg_tys + = ASSERT2( arg_tys `lengthAtLeast` n_tvs, pp_stuff ) + ASSERT2( tyCoVarsOfType body_ty `subVarSet` mkVarSet tvs, pp_stuff ) + mkAppTys (substTyWith tvs (take n_tvs arg_tys) body_ty) + (drop n_tvs arg_tys) + where + pp_stuff = vcat [ppr tvs, ppr body_ty, ppr arg_tys] + n_tvs = length tvs + + + +{- Note [Care with kind instantiation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + T :: forall k. k +and we are finding the kind of + T (forall b. b -> b) * Int +Then + T (forall b. b->b) :: k[ k :-> forall b. b->b] + :: forall b. b -> b +So + T (forall b. b->b) * :: (b -> b)[ b :-> *] + :: * -> * + +In other words we must intantiate the forall! + +Similarly (#15428) + S :: forall k f. k -> f k +and we are finding the kind of + S * (* ->) Int Bool +We have + S * (* ->) :: (k -> f k)[ k :-> *, f :-> (* ->)] + :: * -> * -> * +So again we must instantiate. + +The same thing happens in ToIface.toIfaceAppArgsX. + + +--------------------------------------------------------------------- + TyConApp + ~~~~~~~~ +-} + +-- | A key function: builds a 'TyConApp' or 'FunTy' as appropriate to +-- its arguments. Applies its arguments to the constructor from left to right. +mkTyConApp :: TyCon -> [Type] -> Type +mkTyConApp tycon tys + | isFunTyCon tycon + , [_rep1,_rep2,ty1,ty2] <- tys + = FunTy { ft_af = VisArg, ft_arg = ty1, ft_res = ty2 } + -- The FunTyCon (->) is always a visible one + + | otherwise + = TyConApp tycon tys + +-- splitTyConApp "looks through" synonyms, because they don't +-- mean a distinct type, but all other type-constructor applications +-- including functions are returned as Just .. + +-- | Retrieve the tycon heading this type, if there is one. Does /not/ +-- look through synonyms. +tyConAppTyConPicky_maybe :: Type -> Maybe TyCon +tyConAppTyConPicky_maybe (TyConApp tc _) = Just tc +tyConAppTyConPicky_maybe (FunTy {}) = Just funTyCon +tyConAppTyConPicky_maybe _ = Nothing + + +-- | The same as @fst . splitTyConApp@ +tyConAppTyCon_maybe :: Type -> Maybe TyCon +tyConAppTyCon_maybe ty | Just ty' <- coreView ty = tyConAppTyCon_maybe ty' +tyConAppTyCon_maybe (TyConApp tc _) = Just tc +tyConAppTyCon_maybe (FunTy {}) = Just funTyCon +tyConAppTyCon_maybe _ = Nothing + +tyConAppTyCon :: Type -> TyCon +tyConAppTyCon ty = tyConAppTyCon_maybe ty `orElse` pprPanic "tyConAppTyCon" (ppr ty) + +-- | The same as @snd . splitTyConApp@ +tyConAppArgs_maybe :: Type -> Maybe [Type] +tyConAppArgs_maybe ty | Just ty' <- coreView ty = tyConAppArgs_maybe ty' +tyConAppArgs_maybe (TyConApp _ tys) = Just tys +tyConAppArgs_maybe (FunTy _ arg res) + | Just rep1 <- getRuntimeRep_maybe arg + , Just rep2 <- getRuntimeRep_maybe res + = Just [rep1, rep2, arg, res] +tyConAppArgs_maybe _ = Nothing + +tyConAppArgs :: Type -> [Type] +tyConAppArgs ty = tyConAppArgs_maybe ty `orElse` pprPanic "tyConAppArgs" (ppr ty) + +tyConAppArgN :: Int -> Type -> Type +-- Executing Nth +tyConAppArgN n ty + = case tyConAppArgs_maybe ty of + Just tys -> ASSERT2( tys `lengthExceeds` n, ppr n <+> ppr tys ) tys `getNth` n + Nothing -> pprPanic "tyConAppArgN" (ppr n <+> ppr ty) + +-- | Attempts to tease a type apart into a type constructor and the application +-- of a number of arguments to that constructor. Panics if that is not possible. +-- See also 'splitTyConApp_maybe' +splitTyConApp :: Type -> (TyCon, [Type]) +splitTyConApp ty = case splitTyConApp_maybe ty of + Just stuff -> stuff + Nothing -> pprPanic "splitTyConApp" (ppr ty) + +-- | Attempts to tease a type apart into a type constructor and the application +-- of a number of arguments to that constructor +splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) +splitTyConApp_maybe ty | Just ty' <- coreView ty = splitTyConApp_maybe ty' +splitTyConApp_maybe ty = repSplitTyConApp_maybe ty + +------------------- +repSplitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) +-- ^ Like 'splitTyConApp_maybe', but doesn't look through synonyms. This +-- assumes the synonyms have already been dealt with. +-- +-- Moreover, for a FunTy, it only succeeds if the argument types +-- have enough info to extract the runtime-rep arguments that +-- the funTyCon requires. This will usually be true; +-- but may be temporarily false during canonicalization: +-- see Note [FunTy and decomposing tycon applications] in TcCanonical +-- +repSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) +repSplitTyConApp_maybe (FunTy _ arg res) + | Just arg_rep <- getRuntimeRep_maybe arg + , Just res_rep <- getRuntimeRep_maybe res + = Just (funTyCon, [arg_rep, res_rep, arg, res]) +repSplitTyConApp_maybe _ = Nothing + +------------------- +-- | Attempts to tease a list type apart and gives the type of the elements if +-- successful (looks through type synonyms) +splitListTyConApp_maybe :: Type -> Maybe Type +splitListTyConApp_maybe ty = case splitTyConApp_maybe ty of + Just (tc,[e]) | tc == listTyCon -> Just e + _other -> Nothing + +nextRole :: Type -> Role +nextRole ty + | Just (tc, tys) <- splitTyConApp_maybe ty + , let num_tys = length tys + , num_tys < tyConArity tc + = tyConRoles tc `getNth` num_tys + + | otherwise + = Nominal + +newTyConInstRhs :: TyCon -> [Type] -> Type +-- ^ Unwrap one 'layer' of newtype on a type constructor and its +-- arguments, using an eta-reduced version of the @newtype@ if possible. +-- This requires tys to have at least @newTyConInstArity tycon@ elements. +newTyConInstRhs tycon tys + = ASSERT2( tvs `leLength` tys, ppr tycon $$ ppr tys $$ ppr tvs ) + applyTysX tvs rhs tys + where + (tvs, rhs) = newTyConEtadRhs tycon + +{- +--------------------------------------------------------------------- + CastTy + ~~~~~~ +A casted type has its *kind* casted into something new. +-} + +splitCastTy_maybe :: Type -> Maybe (Type, Coercion) +splitCastTy_maybe ty | Just ty' <- coreView ty = splitCastTy_maybe ty' +splitCastTy_maybe (CastTy ty co) = Just (ty, co) +splitCastTy_maybe _ = Nothing + +-- | Make a 'CastTy'. The Coercion must be nominal. Checks the +-- Coercion for reflexivity, dropping it if it's reflexive. +-- See Note [Respecting definitional equality] in TyCoRep +mkCastTy :: Type -> Coercion -> Type +mkCastTy ty co | isReflexiveCo co = ty -- (EQ2) from the Note +-- NB: Do the slow check here. This is important to keep the splitXXX +-- functions working properly. Otherwise, we may end up with something +-- like (((->) |> something_reflexive_but_not_obviously_so) biz baz) +-- fails under splitFunTy_maybe. This happened with the cheaper check +-- in test dependent/should_compile/dynamic-paper. + +mkCastTy (CastTy ty co1) co2 + -- (EQ3) from the Note + = mkCastTy ty (co1 `mkTransCo` co2) + -- call mkCastTy again for the reflexivity check + +mkCastTy (ForAllTy (Bndr tv vis) inner_ty) co + -- (EQ4) from the Note + | isTyVar tv + , let fvs = tyCoVarsOfCo co + = -- have to make sure that pushing the co in doesn't capture the bound var! + if tv `elemVarSet` fvs + then let empty_subst = mkEmptyTCvSubst (mkInScopeSet fvs) + (subst, tv') = substVarBndr empty_subst tv + in ForAllTy (Bndr tv' vis) (substTy subst inner_ty `mkCastTy` co) + else ForAllTy (Bndr tv vis) (inner_ty `mkCastTy` co) + +mkCastTy ty co = CastTy ty co + +tyConBindersTyCoBinders :: [TyConBinder] -> [TyCoBinder] +-- Return the tyConBinders in TyCoBinder form +tyConBindersTyCoBinders = map to_tyb + where + to_tyb (Bndr tv (NamedTCB vis)) = Named (Bndr tv vis) + to_tyb (Bndr tv (AnonTCB af)) = Anon af (varType tv) + +{- +-------------------------------------------------------------------- + CoercionTy + ~~~~~~~~~~ +CoercionTy allows us to inject coercions into types. A CoercionTy +should appear only in the right-hand side of an application. +-} + +mkCoercionTy :: Coercion -> Type +mkCoercionTy = CoercionTy + +isCoercionTy :: Type -> Bool +isCoercionTy (CoercionTy _) = True +isCoercionTy _ = False + +isCoercionTy_maybe :: Type -> Maybe Coercion +isCoercionTy_maybe (CoercionTy co) = Just co +isCoercionTy_maybe _ = Nothing + +stripCoercionTy :: Type -> Coercion +stripCoercionTy (CoercionTy co) = co +stripCoercionTy ty = pprPanic "stripCoercionTy" (ppr ty) + +{- +--------------------------------------------------------------------- + SynTy + ~~~~~ + +Notes on type synonyms +~~~~~~~~~~~~~~~~~~~~~~ +The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try +to return type synonyms wherever possible. Thus + + type Foo a = a -> a + +we want + splitFunTys (a -> Foo a) = ([a], Foo a) +not ([a], a -> a) + +The reason is that we then get better (shorter) type signatures in +interfaces. Notably this plays a role in tcTySigs in TcBinds.hs. + + +--------------------------------------------------------------------- + ForAllTy + ~~~~~~~~ +-} + +-- | Make a dependent forall over an 'Inferred' variable +mkTyCoInvForAllTy :: TyCoVar -> Type -> Type +mkTyCoInvForAllTy tv ty + | isCoVar tv + , not (tv `elemVarSet` tyCoVarsOfType ty) + = mkVisFunTy (varType tv) ty + | otherwise + = ForAllTy (Bndr tv Inferred) ty + +-- | Like 'mkTyCoInvForAllTy', but tv should be a tyvar +mkInvForAllTy :: TyVar -> Type -> Type +mkInvForAllTy tv ty = ASSERT( isTyVar tv ) + ForAllTy (Bndr tv Inferred) ty + +-- | Like 'mkForAllTys', but assumes all variables are dependent and +-- 'Inferred', a common case +mkTyCoInvForAllTys :: [TyCoVar] -> Type -> Type +mkTyCoInvForAllTys tvs ty = foldr mkTyCoInvForAllTy ty tvs + +-- | Like 'mkTyCoInvForAllTys', but tvs should be a list of tyvar +mkInvForAllTys :: [TyVar] -> Type -> Type +mkInvForAllTys tvs ty = foldr mkInvForAllTy ty tvs + +-- | Like 'mkForAllTy', but assumes the variable is dependent and 'Specified', +-- a common case +mkSpecForAllTy :: TyVar -> Type -> Type +mkSpecForAllTy tv ty = ASSERT( isTyVar tv ) + -- covar is always Inferred, so input should be tyvar + ForAllTy (Bndr tv Specified) ty + +-- | Like 'mkForAllTys', but assumes all variables are dependent and +-- 'Specified', a common case +mkSpecForAllTys :: [TyVar] -> Type -> Type +mkSpecForAllTys tvs ty = foldr mkSpecForAllTy ty tvs + +-- | Like mkForAllTys, but assumes all variables are dependent and visible +mkVisForAllTys :: [TyVar] -> Type -> Type +mkVisForAllTys tvs = ASSERT( all isTyVar tvs ) + -- covar is always Inferred, so all inputs should be tyvar + mkForAllTys [ Bndr tv Required | tv <- tvs ] + +mkLamType :: Var -> Type -> Type +-- ^ Makes a @(->)@ type or an implicit forall type, depending +-- on whether it is given a type variable or a term variable. +-- This is used, for example, when producing the type of a lambda. +-- Always uses Inferred binders. +mkLamTypes :: [Var] -> Type -> Type +-- ^ 'mkLamType' for multiple type or value arguments + +mkLamType v body_ty + | isTyVar v + = ForAllTy (Bndr v Inferred) body_ty + + | isCoVar v + , v `elemVarSet` tyCoVarsOfType body_ty + = ForAllTy (Bndr v Required) body_ty + + | isPredTy arg_ty -- See Note [mkLamType: dictionary arguments] + = mkInvisFunTy arg_ty body_ty + + | otherwise + = mkVisFunTy arg_ty body_ty + where + arg_ty = varType v + +mkLamTypes vs ty = foldr mkLamType ty vs + +{- Note [mkLamType: dictionary arguments] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we have (\ (d :: Ord a). blah), we want to give it type + (Ord a => blah_ty) +with a fat arrow; that is, using mkInvisFunTy, not mkVisFunTy. + +Why? After all, we are in Core, where (=>) and (->) behave the same. +Yes, but the /specialiser/ does treat dictionary arguments specially. +Suppose we do w/w on 'foo' in module A, thus (#11272, #6056) + foo :: Ord a => Int -> blah + foo a d x = case x of I# x' -> $wfoo @a d x' + + $wfoo :: Ord a => Int# -> blah + +Now in module B we see (foo @Int dOrdInt). The specialiser will +specialise this to $sfoo, where + $sfoo :: Int -> blah + $sfoo x = case x of I# x' -> $wfoo @Int dOrdInt x' + +Now we /must/ also specialise $wfoo! But it wasn't user-written, +and has a type built with mkLamTypes. + +Conclusion: the easiest thing is to make mkLamType build + (c => ty) +when the argument is a predicate type. See TyCoRep +Note [Types for coercions, predicates, and evidence] +-} + +-- | Given a list of type-level vars and the free vars of a result kind, +-- makes TyCoBinders, preferring anonymous binders +-- if the variable is, in fact, not dependent. +-- e.g. mkTyConBindersPreferAnon [(k:*),(b:k),(c:k)] (k->k) +-- We want (k:*) Named, (b:k) Anon, (c:k) Anon +-- +-- All non-coercion binders are /visible/. +mkTyConBindersPreferAnon :: [TyVar] -- ^ binders + -> TyCoVarSet -- ^ free variables of result + -> [TyConBinder] +mkTyConBindersPreferAnon vars inner_tkvs = ASSERT( all isTyVar vars) + fst (go vars) + where + go :: [TyVar] -> ([TyConBinder], VarSet) -- also returns the free vars + go [] = ([], inner_tkvs) + go (v:vs) | v `elemVarSet` fvs + = ( Bndr v (NamedTCB Required) : binders + , fvs `delVarSet` v `unionVarSet` kind_vars ) + | otherwise + = ( Bndr v (AnonTCB VisArg) : binders + , fvs `unionVarSet` kind_vars ) + where + (binders, fvs) = go vs + kind_vars = tyCoVarsOfType $ tyVarKind v + +-- | Take a ForAllTy apart, returning the list of tycovars and the result type. +-- This always succeeds, even if it returns only an empty list. Note that the +-- result type returned may have free variables that were bound by a forall. +splitForAllTys :: Type -> ([TyCoVar], Type) +splitForAllTys ty = split ty ty [] + where + split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs + split _ (ForAllTy (Bndr tv _) ty) tvs = split ty ty (tv:tvs) + split orig_ty _ tvs = (reverse tvs, orig_ty) + +-- | Like 'splitForAllTys', but only splits a 'ForAllTy' if +-- @'sameVis' argf supplied_argf@ is 'True', where @argf@ is the visibility +-- of the @ForAllTy@'s binder and @supplied_argf@ is the visibility provided +-- as an argument to this function. +splitForAllTysSameVis :: ArgFlag -> Type -> ([TyCoVar], Type) +splitForAllTysSameVis supplied_argf ty = split ty ty [] + where + split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs + split _ (ForAllTy (Bndr tv argf) ty) tvs + | argf `sameVis` supplied_argf = split ty ty (tv:tvs) + split orig_ty _ tvs = (reverse tvs, orig_ty) + +-- | Like splitForAllTys, but split only for tyvars. +-- This always succeeds, even if it returns only an empty list. Note that the +-- result type returned may have free variables that were bound by a forall. +splitTyVarForAllTys :: Type -> ([TyVar], Type) +splitTyVarForAllTys ty = split ty ty [] + where + split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs + split _ (ForAllTy (Bndr tv _) ty) tvs | isTyVar tv = split ty ty (tv:tvs) + split orig_ty _ tvs = (reverse tvs, orig_ty) + +-- | Checks whether this is a proper forall (with a named binder) +isForAllTy :: Type -> Bool +isForAllTy ty | Just ty' <- coreView ty = isForAllTy ty' +isForAllTy (ForAllTy {}) = True +isForAllTy _ = False + +-- | Like `isForAllTy`, but returns True only if it is a tyvar binder +isForAllTy_ty :: Type -> Bool +isForAllTy_ty ty | Just ty' <- coreView ty = isForAllTy_ty ty' +isForAllTy_ty (ForAllTy (Bndr tv _) _) | isTyVar tv = True +isForAllTy_ty _ = False + +-- | Like `isForAllTy`, but returns True only if it is a covar binder +isForAllTy_co :: Type -> Bool +isForAllTy_co ty | Just ty' <- coreView ty = isForAllTy_co ty' +isForAllTy_co (ForAllTy (Bndr tv _) _) | isCoVar tv = True +isForAllTy_co _ = False + +-- | Is this a function or forall? +isPiTy :: Type -> Bool +isPiTy ty | Just ty' <- coreView ty = isPiTy ty' +isPiTy (ForAllTy {}) = True +isPiTy (FunTy {}) = True +isPiTy _ = False + +-- | Is this a function? +isFunTy :: Type -> Bool +isFunTy ty | Just ty' <- coreView ty = isFunTy ty' +isFunTy (FunTy {}) = True +isFunTy _ = False + +-- | Take a forall type apart, or panics if that is not possible. +splitForAllTy :: Type -> (TyCoVar, Type) +splitForAllTy ty + | Just answer <- splitForAllTy_maybe ty = answer + | otherwise = pprPanic "splitForAllTy" (ppr ty) + +-- | Drops all ForAllTys +dropForAlls :: Type -> Type +dropForAlls ty = go ty + where + go ty | Just ty' <- coreView ty = go ty' + go (ForAllTy _ res) = go res + go res = res + +-- | Attempts to take a forall type apart, but only if it's a proper forall, +-- with a named binder +splitForAllTy_maybe :: Type -> Maybe (TyCoVar, Type) +splitForAllTy_maybe ty = go ty + where + go ty | Just ty' <- coreView ty = go ty' + go (ForAllTy (Bndr tv _) ty) = Just (tv, ty) + go _ = Nothing + +-- | Like splitForAllTy_maybe, but only returns Just if it is a tyvar binder. +splitForAllTy_ty_maybe :: Type -> Maybe (TyCoVar, Type) +splitForAllTy_ty_maybe ty = go ty + where + go ty | Just ty' <- coreView ty = go ty' + go (ForAllTy (Bndr tv _) ty) | isTyVar tv = Just (tv, ty) + go _ = Nothing + +-- | Like splitForAllTy_maybe, but only returns Just if it is a covar binder. +splitForAllTy_co_maybe :: Type -> Maybe (TyCoVar, Type) +splitForAllTy_co_maybe ty = go ty + where + go ty | Just ty' <- coreView ty = go ty' + go (ForAllTy (Bndr tv _) ty) | isCoVar tv = Just (tv, ty) + go _ = Nothing + +-- | Attempts to take a forall type apart; works with proper foralls and +-- functions +splitPiTy_maybe :: Type -> Maybe (TyCoBinder, Type) +splitPiTy_maybe ty = go ty + where + go ty | Just ty' <- coreView ty = go ty' + go (ForAllTy bndr ty) = Just (Named bndr, ty) + go (FunTy { ft_af = af, ft_arg = arg, ft_res = res}) + = Just (Anon af arg, res) + go _ = Nothing + +-- | Takes a forall type apart, or panics +splitPiTy :: Type -> (TyCoBinder, Type) +splitPiTy ty + | Just answer <- splitPiTy_maybe ty = answer + | otherwise = pprPanic "splitPiTy" (ppr ty) + +-- | Split off all TyCoBinders to a type, splitting both proper foralls +-- and functions +splitPiTys :: Type -> ([TyCoBinder], Type) +splitPiTys ty = split ty ty [] + where + split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs + split _ (ForAllTy b res) bs = split res res (Named b : bs) + split _ (FunTy { ft_af = af, ft_arg = arg, ft_res = res }) bs + = split res res (Anon af arg : bs) + split orig_ty _ bs = (reverse bs, orig_ty) + +-- | Like 'splitPiTys' but split off only /named/ binders +-- and returns TyCoVarBinders rather than TyCoBinders +splitForAllVarBndrs :: Type -> ([TyCoVarBinder], Type) +splitForAllVarBndrs ty = split ty ty [] + where + split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs + split _ (ForAllTy b res) bs = split res res (b:bs) + split orig_ty _ bs = (reverse bs, orig_ty) +{-# INLINE splitForAllVarBndrs #-} + +invisibleTyBndrCount :: Type -> Int +-- Returns the number of leading invisible forall'd binders in the type +-- Includes invisible predicate arguments; e.g. for +-- e.g. forall {k}. (k ~ *) => k -> k +-- returns 2 not 1 +invisibleTyBndrCount ty = length (fst (splitPiTysInvisible ty)) + +-- Like splitPiTys, but returns only *invisible* binders, including constraints +-- Stops at the first visible binder +splitPiTysInvisible :: Type -> ([TyCoBinder], Type) +splitPiTysInvisible ty = split ty ty [] + where + split orig_ty ty bs + | Just ty' <- coreView ty = split orig_ty ty' bs + split _ (ForAllTy b res) bs + | Bndr _ vis <- b + , isInvisibleArgFlag vis = split res res (Named b : bs) + split _ (FunTy { ft_af = InvisArg, ft_arg = arg, ft_res = res }) bs + = split res res (Anon InvisArg arg : bs) + split orig_ty _ bs = (reverse bs, orig_ty) + +splitPiTysInvisibleN :: Int -> Type -> ([TyCoBinder], Type) +-- Same as splitPiTysInvisible, but stop when +-- - you have found 'n' TyCoBinders, +-- - or you run out of invisible binders +splitPiTysInvisibleN n ty = split n ty ty [] + where + split n orig_ty ty bs + | n == 0 = (reverse bs, orig_ty) + | Just ty' <- coreView ty = split n orig_ty ty' bs + | ForAllTy b res <- ty + , Bndr _ vis <- b + , isInvisibleArgFlag vis = split (n-1) res res (Named b : bs) + | FunTy { ft_af = InvisArg, ft_arg = arg, ft_res = res } <- ty + = split (n-1) res res (Anon InvisArg arg : bs) + | otherwise = (reverse bs, orig_ty) + +-- | Given a 'TyCon' and a list of argument types, filter out any invisible +-- (i.e., 'Inferred' or 'Specified') arguments. +filterOutInvisibleTypes :: TyCon -> [Type] -> [Type] +filterOutInvisibleTypes tc tys = snd $ partitionInvisibleTypes tc tys + +-- | Given a 'TyCon' and a list of argument types, filter out any 'Inferred' +-- arguments. +filterOutInferredTypes :: TyCon -> [Type] -> [Type] +filterOutInferredTypes tc tys = + filterByList (map (/= Inferred) $ tyConArgFlags tc tys) tys + +-- | Given a 'TyCon' and a list of argument types, partition the arguments +-- into: +-- +-- 1. 'Inferred' or 'Specified' (i.e., invisible) arguments and +-- +-- 2. 'Required' (i.e., visible) arguments +partitionInvisibleTypes :: TyCon -> [Type] -> ([Type], [Type]) +partitionInvisibleTypes tc tys = + partitionByList (map isInvisibleArgFlag $ tyConArgFlags tc tys) tys + +-- | Given a list of things paired with their visibilities, partition the +-- things into (invisible things, visible things). +partitionInvisibles :: [(a, ArgFlag)] -> ([a], [a]) +partitionInvisibles = partitionWith pick_invis + where + pick_invis :: (a, ArgFlag) -> Either a a + pick_invis (thing, vis) | isInvisibleArgFlag vis = Left thing + | otherwise = Right thing + +-- | Given a 'TyCon' and a list of argument types to which the 'TyCon' is +-- applied, determine each argument's visibility +-- ('Inferred', 'Specified', or 'Required'). +-- +-- Wrinkle: consider the following scenario: +-- +-- > T :: forall k. k -> k +-- > tyConArgFlags T [forall m. m -> m -> m, S, R, Q] +-- +-- After substituting, we get +-- +-- > T (forall m. m -> m -> m) :: (forall m. m -> m -> m) -> forall n. n -> n -> n +-- +-- Thus, the first argument is invisible, @S@ is visible, @R@ is invisible again, +-- and @Q@ is visible. +tyConArgFlags :: TyCon -> [Type] -> [ArgFlag] +tyConArgFlags tc = fun_kind_arg_flags (tyConKind tc) + +-- | Given a 'Type' and a list of argument types to which the 'Type' is +-- applied, determine each argument's visibility +-- ('Inferred', 'Specified', or 'Required'). +-- +-- Most of the time, the arguments will be 'Required', but not always. Consider +-- @f :: forall a. a -> Type@. In @f Type Bool@, the first argument (@Type@) is +-- 'Specified' and the second argument (@Bool@) is 'Required'. It is precisely +-- this sort of higher-rank situation in which 'appTyArgFlags' comes in handy, +-- since @f Type Bool@ would be represented in Core using 'AppTy's. +-- (See also #15792). +appTyArgFlags :: Type -> [Type] -> [ArgFlag] +appTyArgFlags ty = fun_kind_arg_flags (typeKind ty) + +-- | Given a function kind and a list of argument types (where each argument's +-- kind aligns with the corresponding position in the argument kind), determine +-- each argument's visibility ('Inferred', 'Specified', or 'Required'). +fun_kind_arg_flags :: Kind -> [Type] -> [ArgFlag] +fun_kind_arg_flags = go emptyTCvSubst + where + go subst ki arg_tys + | Just ki' <- coreView ki = go subst ki' arg_tys + go _ _ [] = [] + go subst (ForAllTy (Bndr tv argf) res_ki) (arg_ty:arg_tys) + = argf : go subst' res_ki arg_tys + where + subst' = extendTvSubst subst tv arg_ty + go subst (TyVarTy tv) arg_tys + | Just ki <- lookupTyVar subst tv = go subst ki arg_tys + go _ _ arg_tys = map (const Required) arg_tys + -- something is ill-kinded. But this can happen + -- when printing errors. Assume everything is Required. + +-- @isTauTy@ tests if a type has no foralls +isTauTy :: Type -> Bool +isTauTy ty | Just ty' <- coreView ty = isTauTy ty' +isTauTy (TyVarTy _) = True +isTauTy (LitTy {}) = True +isTauTy (TyConApp tc tys) = all isTauTy tys && isTauTyCon tc +isTauTy (AppTy a b) = isTauTy a && isTauTy b +isTauTy (FunTy _ a b) = isTauTy a && isTauTy b +isTauTy (ForAllTy {}) = False +isTauTy (CastTy ty _) = isTauTy ty +isTauTy (CoercionTy _) = False -- Not sure about this + +{- +%************************************************************************ +%* * + TyCoBinders +%* * +%************************************************************************ +-} + +-- | Make an anonymous binder +mkAnonBinder :: AnonArgFlag -> Type -> TyCoBinder +mkAnonBinder = Anon + +-- | Does this binder bind a variable that is /not/ erased? Returns +-- 'True' for anonymous binders. +isAnonTyCoBinder :: TyCoBinder -> Bool +isAnonTyCoBinder (Named {}) = False +isAnonTyCoBinder (Anon {}) = True + +tyCoBinderVar_maybe :: TyCoBinder -> Maybe TyCoVar +tyCoBinderVar_maybe (Named tv) = Just $ binderVar tv +tyCoBinderVar_maybe _ = Nothing + +tyCoBinderType :: TyCoBinder -> Type +-- Barely used +tyCoBinderType (Named tvb) = binderType tvb +tyCoBinderType (Anon _ ty) = ty + +tyBinderType :: TyBinder -> Type +tyBinderType (Named (Bndr tv _)) + = ASSERT( isTyVar tv ) + tyVarKind tv +tyBinderType (Anon _ ty) = ty + +-- | Extract a relevant type, if there is one. +binderRelevantType_maybe :: TyCoBinder -> Maybe Type +binderRelevantType_maybe (Named {}) = Nothing +binderRelevantType_maybe (Anon _ ty) = Just ty + +{- +%************************************************************************ +%* * + Pred +* * +************************************************************************ + +Predicates on PredType + +Note [Evidence for quantified constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The superclass mechanism in TcCanonical.makeSuperClasses risks +taking a quantified constraint like + (forall a. C a => a ~ b) +and generate superclass evidence + (forall a. C a => a ~# b) + +This is a funny thing: neither isPredTy nor isCoVarType are true +of it. So we are careful not to generate it in the first place: +see Note [Equality superclasses in quantified constraints] +in TcCanonical. +-} + +-- | Split a type constructor application into its type constructor and +-- applied types. Note that this may fail in the case of a 'FunTy' with an +-- argument of unknown kind 'FunTy' (e.g. @FunTy (a :: k) Int@. since the kind +-- of @a@ isn't of the form @TYPE rep@). Consequently, you may need to zonk your +-- type before using this function. +-- +-- If you only need the 'TyCon', consider using 'tcTyConAppTyCon_maybe'. +tcSplitTyConApp_maybe :: HasCallStack => Type -> Maybe (TyCon, [Type]) +-- Defined here to avoid module loops between Unify and TcType. +tcSplitTyConApp_maybe ty | Just ty' <- tcView ty = tcSplitTyConApp_maybe ty' +tcSplitTyConApp_maybe ty = repSplitTyConApp_maybe ty + +-- tcIsConstraintKind stuf only makes sense in the typechecker +-- After that Constraint = Type +-- See Note [coreView vs tcView] +-- Defined here because it is used in isPredTy and tcRepSplitAppTy_maybe (sigh) +tcIsConstraintKind :: Kind -> Bool +tcIsConstraintKind ty + | Just (tc, args) <- tcSplitTyConApp_maybe ty -- Note: tcSplit here + , isConstraintKindCon tc + = ASSERT2( null args, ppr ty ) True + + | otherwise + = False + +-- | Is this kind equivalent to @*@? +-- +-- This considers 'Constraint' to be distinct from @*@. For a version that +-- treats them as the same type, see 'isLiftedTypeKind'. +tcIsLiftedTypeKind :: Kind -> Bool +tcIsLiftedTypeKind ty + | Just (tc, [arg]) <- tcSplitTyConApp_maybe ty -- Note: tcSplit here + , tc `hasKey` tYPETyConKey + = isLiftedRuntimeRep arg + | otherwise + = False + +tcReturnsConstraintKind :: Kind -> Bool +-- True <=> the Kind ultimately returns a Constraint +-- E.g. * -> Constraint +-- forall k. k -> Constraint +tcReturnsConstraintKind kind + | Just kind' <- tcView kind = tcReturnsConstraintKind kind' +tcReturnsConstraintKind (ForAllTy _ ty) = tcReturnsConstraintKind ty +tcReturnsConstraintKind (FunTy { ft_res = ty }) = tcReturnsConstraintKind ty +tcReturnsConstraintKind (TyConApp tc _) = isConstraintKindCon tc +tcReturnsConstraintKind _ = False + +isEvVarType :: Type -> Bool +-- True of (a) predicates, of kind Constraint, such as (Eq a), and (a ~ b) +-- (b) coercion types, such as (t1 ~# t2) or (t1 ~R# t2) +-- See Note [Types for coercions, predicates, and evidence] +-- See Note [Evidence for quantified constraints] +isEvVarType ty = isCoVarType ty || isPredTy ty + +-- | Does this type classify a core (unlifted) Coercion? +-- At either role nominal or representational +-- (t1 ~# t2) or (t1 ~R# t2) +-- See Note [Types for coercions, predicates, and evidence] +isCoVarType :: Type -> Bool +isCoVarType ty = isEqPrimPred ty + +isEqPredClass :: Class -> Bool +-- True of (~) and (~~) +isEqPredClass cls = cls `hasKey` eqTyConKey + || cls `hasKey` heqTyConKey + +isClassPred, isEqPred, isEqPrimPred, isIPPred :: PredType -> Bool +isClassPred ty = case tyConAppTyCon_maybe ty of + Just tyCon | isClassTyCon tyCon -> True + _ -> False + +isEqPred ty -- True of (a ~ b) and (a ~~ b) + -- ToDo: should we check saturation? + | Just tc <- tyConAppTyCon_maybe ty + , Just cls <- tyConClass_maybe tc + = isEqPredClass cls + | otherwise + = False + +isEqPrimPred ty -- True of (a ~# b) (a ~R# b) + -- ToDo: should we check saturation? + | Just tc <- tyConAppTyCon_maybe ty + = tc `hasKey` eqPrimTyConKey || tc `hasKey` eqReprPrimTyConKey + | otherwise + = False + +isIPPred ty = case tyConAppTyCon_maybe ty of + Just tc -> isIPTyCon tc + _ -> False + +isIPTyCon :: TyCon -> Bool +isIPTyCon tc = tc `hasKey` ipClassKey + -- Class and its corresponding TyCon have the same Unique + +isIPClass :: Class -> Bool +isIPClass cls = cls `hasKey` ipClassKey + +isCTupleClass :: Class -> Bool +isCTupleClass cls = isTupleTyCon (classTyCon cls) + +isIPPred_maybe :: Type -> Maybe (FastString, Type) +isIPPred_maybe ty = + do (tc,[t1,t2]) <- splitTyConApp_maybe ty + guard (isIPTyCon tc) + x <- isStrLitTy t1 + return (x,t2) + +{- +Make PredTypes + +--------------------- Equality types --------------------------------- +-} + +-- | Makes a lifted equality predicate at the given role +mkPrimEqPredRole :: Role -> Type -> Type -> PredType +mkPrimEqPredRole Nominal = mkPrimEqPred +mkPrimEqPredRole Representational = mkReprPrimEqPred +mkPrimEqPredRole Phantom = panic "mkPrimEqPredRole phantom" + +-- | Creates a primitive type equality predicate. +-- Invariant: the types are not Coercions +mkPrimEqPred :: Type -> Type -> Type +mkPrimEqPred ty1 ty2 + = TyConApp eqPrimTyCon [k1, k2, ty1, ty2] + where + k1 = typeKind ty1 + k2 = typeKind ty2 + +-- | Creates a primite type equality predicate with explicit kinds +mkHeteroPrimEqPred :: Kind -> Kind -> Type -> Type -> Type +mkHeteroPrimEqPred k1 k2 ty1 ty2 = TyConApp eqPrimTyCon [k1, k2, ty1, ty2] + +-- | Creates a primitive representational type equality predicate +-- with explicit kinds +mkHeteroReprPrimEqPred :: Kind -> Kind -> Type -> Type -> Type +mkHeteroReprPrimEqPred k1 k2 ty1 ty2 + = TyConApp eqReprPrimTyCon [k1, k2, ty1, ty2] + +-- | Try to split up a coercion type into the types that it coerces +splitCoercionType_maybe :: Type -> Maybe (Type, Type) +splitCoercionType_maybe ty + = do { (tc, [_, _, ty1, ty2]) <- splitTyConApp_maybe ty + ; guard $ tc `hasKey` eqPrimTyConKey || tc `hasKey` eqReprPrimTyConKey + ; return (ty1, ty2) } + +mkReprPrimEqPred :: Type -> Type -> Type +mkReprPrimEqPred ty1 ty2 + = TyConApp eqReprPrimTyCon [k1, k2, ty1, ty2] + where + k1 = typeKind ty1 + k2 = typeKind ty2 + +equalityTyCon :: Role -> TyCon +equalityTyCon Nominal = eqPrimTyCon +equalityTyCon Representational = eqReprPrimTyCon +equalityTyCon Phantom = eqPhantPrimTyCon + +-- --------------------- Dictionary types --------------------------------- + +mkClassPred :: Class -> [Type] -> PredType +mkClassPred clas tys = TyConApp (classTyCon clas) tys + +isDictTy :: Type -> Bool +isDictTy = isClassPred + +isDictLikeTy :: Type -> Bool +-- Note [Dictionary-like types] +isDictLikeTy ty | Just ty' <- coreView ty = isDictLikeTy ty' +isDictLikeTy ty = case splitTyConApp_maybe ty of + Just (tc, tys) | isClassTyCon tc -> True + | isTupleTyCon tc -> all isDictLikeTy tys + _other -> False + +{- Note [Dictionary-like types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Being "dictionary-like" means either a dictionary type or a tuple thereof. +In GHC 6.10 we build implication constraints which construct such tuples, +and if we land up with a binding + t :: (C [a], Eq [a]) + t = blah +then we want to treat t as cheap under "-fdicts-cheap" for example. +(Implication constraints are normally inlined, but sadly not if the +occurrence is itself inside an INLINE function! Until we revise the +handling of implication constraints, that is.) This turned out to +be important in getting good arities in DPH code. Example: + + class C a + class D a where { foo :: a -> a } + instance C a => D (Maybe a) where { foo x = x } + + bar :: (C a, C b) => a -> b -> (Maybe a, Maybe b) + {-# INLINE bar #-} + bar x y = (foo (Just x), foo (Just y)) + +Then 'bar' should jolly well have arity 4 (two dicts, two args), but +we ended up with something like + bar = __inline_me__ (\d1,d2. let t :: (D (Maybe a), D (Maybe b)) = ... + in \x,y. ) + +This is all a bit ad-hoc; eg it relies on knowing that implication +constraints build tuples. + +ToDo: it would be far easier just to use isPredTy. +-} + +-- | A choice of equality relation. This is separate from the type 'Role' +-- because 'Phantom' does not define a (non-trivial) equality relation. +data EqRel = NomEq | ReprEq + deriving (Eq, Ord) + +instance Outputable EqRel where + ppr NomEq = text "nominal equality" + ppr ReprEq = text "representational equality" + +eqRelRole :: EqRel -> Role +eqRelRole NomEq = Nominal +eqRelRole ReprEq = Representational + +data PredTree + = ClassPred Class [Type] + | EqPred EqRel Type Type + | IrredPred PredType + | ForAllPred [TyCoVarBinder] [PredType] PredType + -- ForAllPred: see Note [Quantified constraints] in TcCanonical + -- NB: There is no TuplePred case + -- Tuple predicates like (Eq a, Ord b) are just treated + -- as ClassPred, as if we had a tuple class with two superclasses + -- class (c1, c2) => (%,%) c1 c2 + +classifyPredType :: PredType -> PredTree +classifyPredType ev_ty = case splitTyConApp_maybe ev_ty of + Just (tc, [_, _, ty1, ty2]) + | tc `hasKey` eqReprPrimTyConKey -> EqPred ReprEq ty1 ty2 + | tc `hasKey` eqPrimTyConKey -> EqPred NomEq ty1 ty2 + + Just (tc, tys) + | Just clas <- tyConClass_maybe tc + -> ClassPred clas tys + + _ | (tvs, rho) <- splitForAllVarBndrs ev_ty + , (theta, pred) <- splitFunTys rho + , not (null tvs && null theta) + -> ForAllPred tvs theta pred + + | otherwise + -> IrredPred ev_ty + +getClassPredTys :: HasDebugCallStack => PredType -> (Class, [Type]) +getClassPredTys ty = case getClassPredTys_maybe ty of + Just (clas, tys) -> (clas, tys) + Nothing -> pprPanic "getClassPredTys" (ppr ty) + +getClassPredTys_maybe :: PredType -> Maybe (Class, [Type]) +getClassPredTys_maybe ty = case splitTyConApp_maybe ty of + Just (tc, tys) | Just clas <- tyConClass_maybe tc -> Just (clas, tys) + _ -> Nothing + +getEqPredTys :: PredType -> (Type, Type) +getEqPredTys ty + = case splitTyConApp_maybe ty of + Just (tc, [_, _, ty1, ty2]) + | tc `hasKey` eqPrimTyConKey + || tc `hasKey` eqReprPrimTyConKey + -> (ty1, ty2) + _ -> pprPanic "getEqPredTys" (ppr ty) + +getEqPredTys_maybe :: PredType -> Maybe (Role, Type, Type) +getEqPredTys_maybe ty + = case splitTyConApp_maybe ty of + Just (tc, [_, _, ty1, ty2]) + | tc `hasKey` eqPrimTyConKey -> Just (Nominal, ty1, ty2) + | tc `hasKey` eqReprPrimTyConKey -> Just (Representational, ty1, ty2) + _ -> Nothing + +getEqPredRole :: PredType -> Role +getEqPredRole ty = eqRelRole (predTypeEqRel ty) + +-- | Get the equality relation relevant for a pred type. +predTypeEqRel :: PredType -> EqRel +predTypeEqRel ty + | Just (tc, _) <- splitTyConApp_maybe ty + , tc `hasKey` eqReprPrimTyConKey + = ReprEq + | otherwise + = NomEq + +{- +%************************************************************************ +%* * + Well-scoped tyvars +* * +************************************************************************ + +Note [ScopedSort] +~~~~~~~~~~~~~~~~~ +Consider + + foo :: Proxy a -> Proxy (b :: k) -> Proxy (a :: k2) -> () + +This function type is implicitly generalised over [a, b, k, k2]. These +variables will be Specified; that is, they will be available for visible +type application. This is because they are written in the type signature +by the user. + +However, we must ask: what order will they appear in? In cases without +dependency, this is easy: we just use the lexical left-to-right ordering +of first occurrence. With dependency, we cannot get off the hook so +easily. + +We thus state: + + * These variables appear in the order as given by ScopedSort, where + the input to ScopedSort is the left-to-right order of first occurrence. + +Note that this applies only to *implicit* quantification, without a +`forall`. If the user writes a `forall`, then we just use the order given. + +ScopedSort is defined thusly (as proposed in #15743): + * Work left-to-right through the input list, with a cursor. + * If variable v at the cursor is depended on by any earlier variable w, + move v immediately before the leftmost such w. + +INVARIANT: The prefix of variables before the cursor form a valid telescope. + +Note that ScopedSort makes sense only after type inference is done and all +types/kinds are fully settled and zonked. + +-} + +-- | Do a topological sort on a list of tyvars, +-- so that binders occur before occurrences +-- E.g. given [ a::k, k::*, b::k ] +-- it'll return a well-scoped list [ k::*, a::k, b::k ] +-- +-- This is a deterministic sorting operation +-- (that is, doesn't depend on Uniques). +-- +-- It is also meant to be stable: that is, variables should not +-- be reordered unnecessarily. This is specified in Note [ScopedSort] +-- See also Note [Ordering of implicit variables] in RnTypes + +scopedSort :: [TyCoVar] -> [TyCoVar] +scopedSort = go [] [] + where + go :: [TyCoVar] -- already sorted, in reverse order + -> [TyCoVarSet] -- each set contains all the variables which must be placed + -- before the tv corresponding to the set; they are accumulations + -- of the fvs in the sorted tvs' kinds + + -- This list is in 1-to-1 correspondence with the sorted tyvars + -- INVARIANT: + -- all (\tl -> all (`subVarSet` head tl) (tail tl)) (tails fv_list) + -- That is, each set in the list is a superset of all later sets. + + -> [TyCoVar] -- yet to be sorted + -> [TyCoVar] + go acc _fv_list [] = reverse acc + go acc fv_list (tv:tvs) + = go acc' fv_list' tvs + where + (acc', fv_list') = insert tv acc fv_list + + insert :: TyCoVar -- var to insert + -> [TyCoVar] -- sorted list, in reverse order + -> [TyCoVarSet] -- list of fvs, as above + -> ([TyCoVar], [TyCoVarSet]) -- augmented lists + insert tv [] [] = ([tv], [tyCoVarsOfType (tyVarKind tv)]) + insert tv (a:as) (fvs:fvss) + | tv `elemVarSet` fvs + , (as', fvss') <- insert tv as fvss + = (a:as', fvs `unionVarSet` fv_tv : fvss') + + | otherwise + = (tv:a:as, fvs `unionVarSet` fv_tv : fvs : fvss) + where + fv_tv = tyCoVarsOfType (tyVarKind tv) + + -- lists not in correspondence + insert _ _ _ = panic "scopedSort" + +-- | Extract a well-scoped list of variables from a deterministic set of +-- variables. The result is deterministic. +-- NB: There used to exist varSetElemsWellScoped :: VarSet -> [Var] which +-- took a non-deterministic set and produced a non-deterministic +-- well-scoped list. If you care about the list being well-scoped you also +-- most likely care about it being in deterministic order. +dVarSetElemsWellScoped :: DVarSet -> [Var] +dVarSetElemsWellScoped = scopedSort . dVarSetElems + +-- | Get the free vars of a type in scoped order +tyCoVarsOfTypeWellScoped :: Type -> [TyVar] +tyCoVarsOfTypeWellScoped = scopedSort . tyCoVarsOfTypeList + +-- | Get the free vars of types in scoped order +tyCoVarsOfTypesWellScoped :: [Type] -> [TyVar] +tyCoVarsOfTypesWellScoped = scopedSort . tyCoVarsOfTypesList + +-- | Given the suffix of a telescope, returns the prefix. +-- Ex: given [(k :: j), (a :: Proxy k)], returns [(j :: *)]. +tyCoVarsOfBindersWellScoped :: [TyVar] -> [TyVar] +tyCoVarsOfBindersWellScoped tvs + = tyCoVarsOfTypeWellScoped (mkInvForAllTys tvs unitTy) + +------------- Closing over kinds ----------------- + +-- | Add the kind variables free in the kinds of the tyvars in the given set. +-- Returns a non-deterministic set. +closeOverKinds :: TyVarSet -> TyVarSet +closeOverKinds = fvVarSet . closeOverKindsFV . nonDetEltsUniqSet + -- It's OK to use nonDetEltsUniqSet here because we immediately forget + -- about the ordering by returning a set. + +-- | Given a list of tyvars returns a deterministic FV computation that +-- returns the given tyvars with the kind variables free in the kinds of the +-- given tyvars. +closeOverKindsFV :: [TyVar] -> FV +closeOverKindsFV tvs = + mapUnionFV (tyCoFVsOfType . tyVarKind) tvs `unionFV` mkFVs tvs + +-- | Add the kind variables free in the kinds of the tyvars in the given set. +-- Returns a deterministically ordered list. +closeOverKindsList :: [TyVar] -> [TyVar] +closeOverKindsList tvs = fvVarList $ closeOverKindsFV tvs + +-- | Add the kind variables free in the kinds of the tyvars in the given set. +-- Returns a deterministic set. +closeOverKindsDSet :: DTyVarSet -> DTyVarSet +closeOverKindsDSet = fvDVarSet . closeOverKindsFV . dVarSetElems + +{- +************************************************************************ +* * +\subsection{Type families} +* * +************************************************************************ +-} + +mkFamilyTyConApp :: TyCon -> [Type] -> Type +-- ^ Given a family instance TyCon and its arg types, return the +-- corresponding family type. E.g: +-- +-- > data family T a +-- > data instance T (Maybe b) = MkT b +-- +-- Where the instance tycon is :RTL, so: +-- +-- > mkFamilyTyConApp :RTL Int = T (Maybe Int) +mkFamilyTyConApp tc tys + | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc + , let tvs = tyConTyVars tc + fam_subst = ASSERT2( tvs `equalLength` tys, ppr tc <+> ppr tys ) + zipTvSubst tvs tys + = mkTyConApp fam_tc (substTys fam_subst fam_tys) + | otherwise + = mkTyConApp tc tys + +-- | Get the type on the LHS of a coercion induced by a type/data +-- family instance. +coAxNthLHS :: CoAxiom br -> Int -> Type +coAxNthLHS ax ind = + mkTyConApp (coAxiomTyCon ax) (coAxBranchLHS (coAxiomNthBranch ax ind)) + +-- | Pretty prints a 'TyCon', using the family instance in case of a +-- representation tycon. For example: +-- +-- > data T [a] = ... +-- +-- In that case we want to print @T [a]@, where @T@ is the family 'TyCon' +pprSourceTyCon :: TyCon -> SDoc +pprSourceTyCon tycon + | Just (fam_tc, tys) <- tyConFamInst_maybe tycon + = ppr $ fam_tc `TyConApp` tys -- can't be FunTyCon + | otherwise + = ppr tycon + +isFamFreeTy :: Type -> Bool +isFamFreeTy ty | Just ty' <- coreView ty = isFamFreeTy ty' +isFamFreeTy (TyVarTy _) = True +isFamFreeTy (LitTy {}) = True +isFamFreeTy (TyConApp tc tys) = all isFamFreeTy tys && isFamFreeTyCon tc +isFamFreeTy (AppTy a b) = isFamFreeTy a && isFamFreeTy b +isFamFreeTy (FunTy _ a b) = isFamFreeTy a && isFamFreeTy b +isFamFreeTy (ForAllTy _ ty) = isFamFreeTy ty +isFamFreeTy (CastTy ty _) = isFamFreeTy ty +isFamFreeTy (CoercionTy _) = False -- Not sure about this + +{- +************************************************************************ +* * +\subsection{Liftedness} +* * +************************************************************************ +-} + +-- | Returns Just True if this type is surely lifted, Just False +-- if it is surely unlifted, Nothing if we can't be sure (i.e., it is +-- levity polymorphic), and panics if the kind does not have the shape +-- TYPE r. +isLiftedType_maybe :: HasDebugCallStack => Type -> Maybe Bool +isLiftedType_maybe ty = go (getRuntimeRep ty) + where + go rr | Just rr' <- coreView rr = go rr' + | isLiftedRuntimeRep rr = Just True + | TyConApp {} <- rr = Just False -- Everything else is unlifted + | otherwise = Nothing -- levity polymorphic + +-- | See "Type#type_classification" for what an unlifted type is. +-- Panics on levity polymorphic types. +isUnliftedType :: HasDebugCallStack => Type -> Bool + -- isUnliftedType returns True for forall'd unlifted types: + -- x :: forall a. Int# + -- I found bindings like these were getting floated to the top level. + -- They are pretty bogus types, mind you. It would be better never to + -- construct them +isUnliftedType ty + = not (isLiftedType_maybe ty `orElse` + pprPanic "isUnliftedType" (ppr ty <+> dcolon <+> ppr (typeKind ty))) + +-- | Is this a type of kind RuntimeRep? (e.g. LiftedRep) +isRuntimeRepKindedTy :: Type -> Bool +isRuntimeRepKindedTy = isRuntimeRepTy . typeKind + +-- | Drops prefix of RuntimeRep constructors in 'TyConApp's. Useful for e.g. +-- dropping 'LiftedRep arguments of unboxed tuple TyCon applications: +-- +-- dropRuntimeRepArgs [ 'LiftedRep, 'IntRep +-- , String, Int# ] == [String, Int#] +-- +dropRuntimeRepArgs :: [Type] -> [Type] +dropRuntimeRepArgs = dropWhile isRuntimeRepKindedTy + +-- | Extract the RuntimeRep classifier of a type. For instance, +-- @getRuntimeRep_maybe Int = LiftedRep@. Returns 'Nothing' if this is not +-- possible. +getRuntimeRep_maybe :: HasDebugCallStack + => Type -> Maybe Type +getRuntimeRep_maybe = kindRep_maybe . typeKind + +-- | Extract the RuntimeRep classifier of a type. For instance, +-- @getRuntimeRep_maybe Int = LiftedRep@. Panics if this is not possible. +getRuntimeRep :: HasDebugCallStack => Type -> Type +getRuntimeRep ty + = case getRuntimeRep_maybe ty of + Just r -> r + Nothing -> pprPanic "getRuntimeRep" (ppr ty <+> dcolon <+> ppr (typeKind ty)) + +isUnboxedTupleType :: Type -> Bool +isUnboxedTupleType ty + = tyConAppTyCon (getRuntimeRep ty) `hasKey` tupleRepDataConKey + -- NB: Do not use typePrimRep, as that can't tell the difference between + -- unboxed tuples and unboxed sums + + +isUnboxedSumType :: Type -> Bool +isUnboxedSumType ty + = tyConAppTyCon (getRuntimeRep ty) `hasKey` sumRepDataConKey + +-- | See "Type#type_classification" for what an algebraic type is. +-- Should only be applied to /types/, as opposed to e.g. partially +-- saturated type constructors +isAlgType :: Type -> Bool +isAlgType ty + = case splitTyConApp_maybe ty of + Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc ) + isAlgTyCon tc + _other -> False + +-- | Check whether a type is a data family type +isDataFamilyAppType :: Type -> Bool +isDataFamilyAppType ty = case tyConAppTyCon_maybe ty of + Just tc -> isDataFamilyTyCon tc + _ -> False + +-- | Computes whether an argument (or let right hand side) should +-- be computed strictly or lazily, based only on its type. +-- Currently, it's just 'isUnliftedType'. Panics on levity-polymorphic types. +isStrictType :: HasDebugCallStack => Type -> Bool +isStrictType = isUnliftedType + +isPrimitiveType :: Type -> Bool +-- ^ Returns true of types that are opaque to Haskell. +isPrimitiveType ty = case splitTyConApp_maybe ty of + Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc ) + isPrimTyCon tc + _ -> False + +{- +************************************************************************ +* * +\subsection{Join points} +* * +************************************************************************ +-} + +-- | Determine whether a type could be the type of a join point of given total +-- arity, according to the polymorphism rule. A join point cannot be polymorphic +-- in its return type, since given +-- join j @a @b x y z = e1 in e2, +-- the types of e1 and e2 must be the same, and a and b are not in scope for e2. +-- (See Note [The polymorphism rule of join points] in CoreSyn.) Returns False +-- also if the type simply doesn't have enough arguments. +-- +-- Note that we need to know how many arguments (type *and* value) the putative +-- join point takes; for instance, if +-- j :: forall a. a -> Int +-- then j could be a binary join point returning an Int, but it could *not* be a +-- unary join point returning a -> Int. +-- +-- TODO: See Note [Excess polymorphism and join points] +isValidJoinPointType :: JoinArity -> Type -> Bool +isValidJoinPointType arity ty + = valid_under emptyVarSet arity ty + where + valid_under tvs arity ty + | arity == 0 + = isEmptyVarSet (tvs `intersectVarSet` tyCoVarsOfType ty) + | Just (t, ty') <- splitForAllTy_maybe ty + = valid_under (tvs `extendVarSet` t) (arity-1) ty' + | Just (_, res_ty) <- splitFunTy_maybe ty + = valid_under tvs (arity-1) res_ty + | otherwise + = False + +{- Note [Excess polymorphism and join points] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In principle, if a function would be a join point except that it fails +the polymorphism rule (see Note [The polymorphism rule of join points] in +CoreSyn), it can still be made a join point with some effort. This is because +all tail calls must return the same type (they return to the same context!), and +thus if the return type depends on an argument, that argument must always be the +same. + +For instance, consider: + + let f :: forall a. a -> Char -> [a] + f @a x c = ... f @a y 'a' ... + in ... f @Int 1 'b' ... f @Int 2 'c' ... + +(where the calls are tail calls). `f` fails the polymorphism rule because its +return type is [a], where [a] is bound. But since the type argument is always +'Int', we can rewrite it as: + + let f' :: Int -> Char -> [Int] + f' x c = ... f' y 'a' ... + in ... f' 1 'b' ... f 2 'c' ... + +and now we can make f' a join point: + + join f' :: Int -> Char -> [Int] + f' x c = ... jump f' y 'a' ... + in ... jump f' 1 'b' ... jump f' 2 'c' ... + +It's not clear that this comes up often, however. TODO: Measure how often and +add this analysis if necessary. See #14620. + + +************************************************************************ +* * +\subsection{Sequencing on types} +* * +************************************************************************ +-} + +seqType :: Type -> () +seqType (LitTy n) = n `seq` () +seqType (TyVarTy tv) = tv `seq` () +seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2 +seqType (FunTy _ t1 t2) = seqType t1 `seq` seqType t2 +seqType (TyConApp tc tys) = tc `seq` seqTypes tys +seqType (ForAllTy (Bndr tv _) ty) = seqType (varType tv) `seq` seqType ty +seqType (CastTy ty co) = seqType ty `seq` seqCo co +seqType (CoercionTy co) = seqCo co + +seqTypes :: [Type] -> () +seqTypes [] = () +seqTypes (ty:tys) = seqType ty `seq` seqTypes tys + +{- +************************************************************************ +* * + Comparison for types + (We don't use instances so that we know where it happens) +* * +************************************************************************ + +Note [Equality on AppTys] +~~~~~~~~~~~~~~~~~~~~~~~~~ +In our cast-ignoring equality, we want to say that the following two +are equal: + + (Maybe |> co) (Int |> co') ~? Maybe Int + +But the left is an AppTy while the right is a TyConApp. The solution is +to use repSplitAppTy_maybe to break up the TyConApp into its pieces and +then continue. Easy to do, but also easy to forget to do. + +-} + +eqType :: Type -> Type -> Bool +-- ^ Type equality on source types. Does not look through @newtypes@ or +-- 'PredType's, but it does look through type synonyms. +-- This first checks that the kinds of the types are equal and then +-- checks whether the types are equal, ignoring casts and coercions. +-- (The kind check is a recursive call, but since all kinds have type +-- @Type@, there is no need to check the types of kinds.) +-- See also Note [Non-trivial definitional equality] in TyCoRep. +eqType t1 t2 = isEqual $ nonDetCmpType t1 t2 + -- It's OK to use nonDetCmpType here and eqType is deterministic, + -- nonDetCmpType does equality deterministically + +-- | Compare types with respect to a (presumably) non-empty 'RnEnv2'. +eqTypeX :: RnEnv2 -> Type -> Type -> Bool +eqTypeX env t1 t2 = isEqual $ nonDetCmpTypeX env t1 t2 + -- It's OK to use nonDetCmpType here and eqTypeX is deterministic, + -- nonDetCmpTypeX does equality deterministically + +-- | Type equality on lists of types, looking through type synonyms +-- but not newtypes. +eqTypes :: [Type] -> [Type] -> Bool +eqTypes tys1 tys2 = isEqual $ nonDetCmpTypes tys1 tys2 + -- It's OK to use nonDetCmpType here and eqTypes is deterministic, + -- nonDetCmpTypes does equality deterministically + +eqVarBndrs :: RnEnv2 -> [Var] -> [Var] -> Maybe RnEnv2 +-- Check that the var lists are the same length +-- and have matching kinds; if so, extend the RnEnv2 +-- Returns Nothing if they don't match +eqVarBndrs env [] [] + = Just env +eqVarBndrs env (tv1:tvs1) (tv2:tvs2) + | eqTypeX env (varType tv1) (varType tv2) + = eqVarBndrs (rnBndr2 env tv1 tv2) tvs1 tvs2 +eqVarBndrs _ _ _= Nothing + +-- Now here comes the real worker + +{- +Note [nonDetCmpType nondeterminism] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +nonDetCmpType is implemented in terms of nonDetCmpTypeX. nonDetCmpTypeX +uses nonDetCmpTc which compares TyCons by their Unique value. Using Uniques for +ordering leads to nondeterminism. We hit the same problem in the TyVarTy case, +comparing type variables is nondeterministic, note the call to nonDetCmpVar in +nonDetCmpTypeX. +See Note [Unique Determinism] for more details. +-} + +nonDetCmpType :: Type -> Type -> Ordering +nonDetCmpType t1 t2 + -- we know k1 and k2 have the same kind, because they both have kind *. + = nonDetCmpTypeX rn_env t1 t2 + where + rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfTypes [t1, t2])) + +nonDetCmpTypes :: [Type] -> [Type] -> Ordering +nonDetCmpTypes ts1 ts2 = nonDetCmpTypesX rn_env ts1 ts2 + where + rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfTypes (ts1 ++ ts2))) + +-- | An ordering relation between two 'Type's (known below as @t1 :: k1@ +-- and @t2 :: k2@) +data TypeOrdering = TLT -- ^ @t1 < t2@ + | TEQ -- ^ @t1 ~ t2@ and there are no casts in either, + -- therefore we can conclude @k1 ~ k2@ + | TEQX -- ^ @t1 ~ t2@ yet one of the types contains a cast so + -- they may differ in kind. + | TGT -- ^ @t1 > t2@ + deriving (Eq, Ord, Enum, Bounded) + +nonDetCmpTypeX :: RnEnv2 -> Type -> Type -> Ordering -- Main workhorse + -- See Note [Non-trivial definitional equality] in TyCoRep +nonDetCmpTypeX env orig_t1 orig_t2 = + case go env orig_t1 orig_t2 of + -- If there are casts then we also need to do a comparison of the kinds of + -- the types being compared + TEQX -> toOrdering $ go env k1 k2 + ty_ordering -> toOrdering ty_ordering + where + k1 = typeKind orig_t1 + k2 = typeKind orig_t2 + + toOrdering :: TypeOrdering -> Ordering + toOrdering TLT = LT + toOrdering TEQ = EQ + toOrdering TEQX = EQ + toOrdering TGT = GT + + liftOrdering :: Ordering -> TypeOrdering + liftOrdering LT = TLT + liftOrdering EQ = TEQ + liftOrdering GT = TGT + + thenCmpTy :: TypeOrdering -> TypeOrdering -> TypeOrdering + thenCmpTy TEQ rel = rel + thenCmpTy TEQX rel = hasCast rel + thenCmpTy rel _ = rel + + hasCast :: TypeOrdering -> TypeOrdering + hasCast TEQ = TEQX + hasCast rel = rel + + -- Returns both the resulting ordering relation between the two types + -- and whether either contains a cast. + go :: RnEnv2 -> Type -> Type -> TypeOrdering + go env t1 t2 + | Just t1' <- coreView t1 = go env t1' t2 + | Just t2' <- coreView t2 = go env t1 t2' + + go env (TyVarTy tv1) (TyVarTy tv2) + = liftOrdering $ rnOccL env tv1 `nonDetCmpVar` rnOccR env tv2 + go env (ForAllTy (Bndr tv1 _) t1) (ForAllTy (Bndr tv2 _) t2) + = go env (varType tv1) (varType tv2) + `thenCmpTy` go (rnBndr2 env tv1 tv2) t1 t2 + -- See Note [Equality on AppTys] + go env (AppTy s1 t1) ty2 + | Just (s2, t2) <- repSplitAppTy_maybe ty2 + = go env s1 s2 `thenCmpTy` go env t1 t2 + go env ty1 (AppTy s2 t2) + | Just (s1, t1) <- repSplitAppTy_maybe ty1 + = go env s1 s2 `thenCmpTy` go env t1 t2 + go env (FunTy _ s1 t1) (FunTy _ s2 t2) + = go env s1 s2 `thenCmpTy` go env t1 t2 + go env (TyConApp tc1 tys1) (TyConApp tc2 tys2) + = liftOrdering (tc1 `nonDetCmpTc` tc2) `thenCmpTy` gos env tys1 tys2 + go _ (LitTy l1) (LitTy l2) = liftOrdering (compare l1 l2) + go env (CastTy t1 _) t2 = hasCast $ go env t1 t2 + go env t1 (CastTy t2 _) = hasCast $ go env t1 t2 + + go _ (CoercionTy {}) (CoercionTy {}) = TEQ + + -- Deal with the rest: TyVarTy < CoercionTy < AppTy < LitTy < TyConApp < ForAllTy + go _ ty1 ty2 + = liftOrdering $ (get_rank ty1) `compare` (get_rank ty2) + where get_rank :: Type -> Int + get_rank (CastTy {}) + = pprPanic "nonDetCmpTypeX.get_rank" (ppr [ty1,ty2]) + get_rank (TyVarTy {}) = 0 + get_rank (CoercionTy {}) = 1 + get_rank (AppTy {}) = 3 + get_rank (LitTy {}) = 4 + get_rank (TyConApp {}) = 5 + get_rank (FunTy {}) = 6 + get_rank (ForAllTy {}) = 7 + + gos :: RnEnv2 -> [Type] -> [Type] -> TypeOrdering + gos _ [] [] = TEQ + gos _ [] _ = TLT + gos _ _ [] = TGT + gos env (ty1:tys1) (ty2:tys2) = go env ty1 ty2 `thenCmpTy` gos env tys1 tys2 + +------------- +nonDetCmpTypesX :: RnEnv2 -> [Type] -> [Type] -> Ordering +nonDetCmpTypesX _ [] [] = EQ +nonDetCmpTypesX env (t1:tys1) (t2:tys2) = nonDetCmpTypeX env t1 t2 + `thenCmp` + nonDetCmpTypesX env tys1 tys2 +nonDetCmpTypesX _ [] _ = LT +nonDetCmpTypesX _ _ [] = GT + +------------- +-- | Compare two 'TyCon's. NB: This should /never/ see 'Constraint' (as +-- recognized by Kind.isConstraintKindCon) which is considered a synonym for +-- 'Type' in Core. +-- See Note [Kind Constraint and kind Type] in Kind. +-- See Note [nonDetCmpType nondeterminism] +nonDetCmpTc :: TyCon -> TyCon -> Ordering +nonDetCmpTc tc1 tc2 + = ASSERT( not (isConstraintKindCon tc1) && not (isConstraintKindCon tc2) ) + u1 `nonDetCmpUnique` u2 + where + u1 = tyConUnique tc1 + u2 = tyConUnique tc2 + +{- +************************************************************************ +* * + The kind of a type +* * +************************************************************************ + +Note [typeKind vs tcTypeKind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have two functions to get the kind of a type + + * typeKind ignores the distinction between Constraint and * + * tcTypeKind respects the distinction between Constraint and * + +tcTypeKind is used by the type inference engine, for which Constraint +and * are different; after that we use typeKind. + +See also Note [coreView vs tcView] + +Note [Kinding rules for types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In typeKind we consider Constraint and (TYPE LiftedRep) to be identical. +We then have + + t1 : TYPE rep1 + t2 : TYPE rep2 + (FUN) ---------------- + t1 -> t2 : Type + + ty : TYPE rep + `a` is not free in rep +(FORALL) ----------------------- + forall a. ty : TYPE rep + +In tcTypeKind we consider Constraint and (TYPE LiftedRep) to be distinct: + + t1 : TYPE rep1 + t2 : TYPE rep2 + (FUN) ---------------- + t1 -> t2 : Type + + t1 : Constraint + t2 : TYPE rep + (PRED1) ---------------- + t1 => t2 : Type + + t1 : Constraint + t2 : Constraint + (PRED2) --------------------- + t1 => t2 : Constraint + + ty : TYPE rep + `a` is not free in rep +(FORALL1) ----------------------- + forall a. ty : TYPE rep + + ty : Constraint +(FORALL2) ------------------------- + forall a. ty : Constraint + +Note that: +* The only way we distinguish '->' from '=>' is by the fact + that the argument is a PredTy. Both are FunTys + +Note [Phantom type variables in kinds] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + type K (r :: RuntimeRep) = Type -- Note 'r' is unused + data T r :: K r -- T :: forall r -> K r + foo :: forall r. T r + +The body of the forall in foo's type has kind (K r), and +normally it would make no sense to have + forall r. (ty :: K r) +because the kind of the forall would escape the binding +of 'r'. But in this case it's fine because (K r) exapands +to Type, so we expliclity /permit/ the type + forall r. T r + +To accommodate such a type, in typeKind (forall a.ty) we use +occCheckExpand to expand any type synonyms in the kind of 'ty' +to eliminate 'a'. See kinding rule (FORALL) in +Note [Kinding rules for types] + +And in TcValidity.checkEscapingKind, we use also use +occCheckExpand, for the same reason. +-} + +----------------------------- +typeKind :: HasDebugCallStack => Type -> Kind +-- No need to expand synonyms +typeKind (TyConApp tc tys) = piResultTys (tyConKind tc) tys +typeKind (LitTy l) = typeLiteralKind l +typeKind (FunTy {}) = liftedTypeKind +typeKind (TyVarTy tyvar) = tyVarKind tyvar +typeKind (CastTy _ty co) = pSnd $ coercionKind co +typeKind (CoercionTy co) = coercionType co + +typeKind (AppTy fun arg) + = go fun [arg] + where + -- Accumulate the type arugments, so we can call piResultTys, + -- rather than a succession of calls to piResultTy (which is + -- asymptotically costly as the number of arguments increases) + go (AppTy fun arg) args = go fun (arg:args) + go fun args = piResultTys (typeKind fun) args + +typeKind ty@(ForAllTy {}) + = case occCheckExpand tvs body_kind of + -- We must make sure tv does not occur in kind + -- As it is already out of scope! + -- See Note [Phantom type variables in kinds] + Just k' -> k' + Nothing -> pprPanic "typeKind" + (ppr ty $$ ppr tvs $$ ppr body <+> dcolon <+> ppr body_kind) + where + (tvs, body) = splitTyVarForAllTys ty + body_kind = typeKind body + +----------------------------- +tcTypeKind :: HasDebugCallStack => Type -> Kind +-- No need to expand synonyms +tcTypeKind (TyConApp tc tys) = piResultTys (tyConKind tc) tys +tcTypeKind (LitTy l) = typeLiteralKind l +tcTypeKind (TyVarTy tyvar) = tyVarKind tyvar +tcTypeKind (CastTy _ty co) = pSnd $ coercionKind co +tcTypeKind (CoercionTy co) = coercionType co + +tcTypeKind (FunTy { ft_af = af, ft_res = res }) + | InvisArg <- af + , tcIsConstraintKind (tcTypeKind res) + = constraintKind -- Eq a => Ord a :: Constraint + | otherwise -- Eq a => a -> a :: TYPE LiftedRep + = liftedTypeKind -- Eq a => Array# Int :: Type LiftedRep (not TYPE PtrRep) + +tcTypeKind (AppTy fun arg) + = go fun [arg] + where + -- Accumulate the type arugments, so we can call piResultTys, + -- rather than a succession of calls to piResultTy (which is + -- asymptotically costly as the number of arguments increases) + go (AppTy fun arg) args = go fun (arg:args) + go fun args = piResultTys (tcTypeKind fun) args + +tcTypeKind ty@(ForAllTy {}) + | tcIsConstraintKind body_kind + = constraintKind + + | otherwise + = case occCheckExpand tvs body_kind of + -- We must make sure tv does not occur in kind + -- As it is already out of scope! + -- See Note [Phantom type variables in kinds] + Just k' -> k' + Nothing -> pprPanic "tcTypeKind" + (ppr ty $$ ppr tvs $$ ppr body <+> dcolon <+> ppr body_kind) + where + (tvs, body) = splitTyVarForAllTys ty + body_kind = tcTypeKind body + + +isPredTy :: HasDebugCallStack => Type -> Bool +-- See Note [Types for coercions, predicates, and evidence] +isPredTy ty = tcIsConstraintKind (tcTypeKind ty) + +-------------------------- +typeLiteralKind :: TyLit -> Kind +typeLiteralKind (NumTyLit {}) = typeNatKind +typeLiteralKind (StrTyLit {}) = typeSymbolKind + +-- | Returns True if a type is levity polymorphic. Should be the same +-- as (isKindLevPoly . typeKind) but much faster. +-- Precondition: The type has kind (TYPE blah) +isTypeLevPoly :: Type -> Bool +isTypeLevPoly = go + where + go ty@(TyVarTy {}) = check_kind ty + go ty@(AppTy {}) = check_kind ty + go ty@(TyConApp tc _) | not (isTcLevPoly tc) = False + | otherwise = check_kind ty + go (ForAllTy _ ty) = go ty + go (FunTy {}) = False + go (LitTy {}) = False + go ty@(CastTy {}) = check_kind ty + go ty@(CoercionTy {}) = pprPanic "isTypeLevPoly co" (ppr ty) + + check_kind = isKindLevPoly . typeKind + +-- | Looking past all pi-types, is the end result potentially levity polymorphic? +-- Example: True for (forall r (a :: TYPE r). String -> a) +-- Example: False for (forall r1 r2 (a :: TYPE r1) (b :: TYPE r2). a -> b -> Type) +resultIsLevPoly :: Type -> Bool +resultIsLevPoly = isTypeLevPoly . snd . splitPiTys + + +{- ********************************************************************** +* * + Occurs check expansion +%* * +%********************************************************************* -} + +{- Note [Occurs check expansion] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(occurCheckExpand tv xi) expands synonyms in xi just enough to get rid +of occurrences of tv outside type function arguments, if that is +possible; otherwise, it returns Nothing. + +For example, suppose we have + type F a b = [a] +Then + occCheckExpand b (F Int b) = Just [Int] +but + occCheckExpand a (F a Int) = Nothing + +We don't promise to do the absolute minimum amount of expanding +necessary, but we try not to do expansions we don't need to. We +prefer doing inner expansions first. For example, + type F a b = (a, Int, a, [a]) + type G b = Char +We have + occCheckExpand b (F (G b)) = Just (F Char) +even though we could also expand F to get rid of b. +-} + +occCheckExpand :: [Var] -> Type -> Maybe Type +-- See Note [Occurs check expansion] +-- We may have needed to do some type synonym unfolding in order to +-- get rid of the variable (or forall), so we also return the unfolded +-- version of the type, which is guaranteed to be syntactically free +-- of the given type variable. If the type is already syntactically +-- free of the variable, then the same type is returned. +occCheckExpand vs_to_avoid ty + = go (mkVarSet vs_to_avoid, emptyVarEnv) ty + where + go :: (VarSet, VarEnv TyCoVar) -> Type -> Maybe Type + -- The VarSet is the set of variables we are trying to avoid + -- The VarEnv carries mappings necessary + -- because of kind expansion + go cxt@(as, env) (TyVarTy tv') + | tv' `elemVarSet` as = Nothing + | Just tv'' <- lookupVarEnv env tv' = return (mkTyVarTy tv'') + | otherwise = do { tv'' <- go_var cxt tv' + ; return (mkTyVarTy tv'') } + + go _ ty@(LitTy {}) = return ty + go cxt (AppTy ty1 ty2) = do { ty1' <- go cxt ty1 + ; ty2' <- go cxt ty2 + ; return (mkAppTy ty1' ty2') } + go cxt ty@(FunTy _ ty1 ty2) + = do { ty1' <- go cxt ty1 + ; ty2' <- go cxt ty2 + ; return (ty { ft_arg = ty1', ft_res = ty2' }) } + go cxt@(as, env) (ForAllTy (Bndr tv vis) body_ty) + = do { ki' <- go cxt (varType tv) + ; let tv' = setVarType tv ki' + env' = extendVarEnv env tv tv' + as' = as `delVarSet` tv + ; body' <- go (as', env') body_ty + ; return (ForAllTy (Bndr tv' vis) body') } + + -- For a type constructor application, first try expanding away the + -- offending variable from the arguments. If that doesn't work, next + -- see if the type constructor is a type synonym, and if so, expand + -- it and try again. + go cxt ty@(TyConApp tc tys) + = case mapM (go cxt) tys of + Just tys' -> return (mkTyConApp tc tys') + Nothing | Just ty' <- tcView ty -> go cxt ty' + | otherwise -> Nothing + -- Failing that, try to expand a synonym + + go cxt (CastTy ty co) = do { ty' <- go cxt ty + ; co' <- go_co cxt co + ; return (mkCastTy ty' co') } + go cxt (CoercionTy co) = do { co' <- go_co cxt co + ; return (mkCoercionTy co') } + + ------------------ + go_var cxt v = do { k' <- go cxt (varType v) + ; return (setVarType v k') } + -- Works for TyVar and CoVar + -- See Note [Occurrence checking: look inside kinds] + + ------------------ + go_mco _ MRefl = return MRefl + go_mco ctx (MCo co) = MCo <$> go_co ctx co + + ------------------ + go_co cxt (Refl ty) = do { ty' <- go cxt ty + ; return (mkNomReflCo ty') } + go_co cxt (GRefl r ty mco) = do { mco' <- go_mco cxt mco + ; ty' <- go cxt ty + ; return (mkGReflCo r ty' mco') } + -- Note: Coercions do not contain type synonyms + go_co cxt (TyConAppCo r tc args) = do { args' <- mapM (go_co cxt) args + ; return (mkTyConAppCo r tc args') } + go_co cxt (AppCo co arg) = do { co' <- go_co cxt co + ; arg' <- go_co cxt arg + ; return (mkAppCo co' arg') } + go_co cxt@(as, env) (ForAllCo tv kind_co body_co) + = do { kind_co' <- go_co cxt kind_co + ; let tv' = setVarType tv $ + pFst (coercionKind kind_co') + env' = extendVarEnv env tv tv' + as' = as `delVarSet` tv + ; body' <- go_co (as', env') body_co + ; return (ForAllCo tv' kind_co' body') } + go_co cxt (FunCo r co1 co2) = do { co1' <- go_co cxt co1 + ; co2' <- go_co cxt co2 + ; return (mkFunCo r co1' co2') } + go_co cxt@(as,env) (CoVarCo c) + | c `elemVarSet` as = Nothing + | Just c' <- lookupVarEnv env c = return (mkCoVarCo c') + | otherwise = do { c' <- go_var cxt c + ; return (mkCoVarCo c') } + go_co cxt (HoleCo h) = do { c' <- go_var cxt (ch_co_var h) + ; return (HoleCo (h { ch_co_var = c' })) } + go_co cxt (AxiomInstCo ax ind args) = do { args' <- mapM (go_co cxt) args + ; return (mkAxiomInstCo ax ind args') } + go_co cxt (UnivCo p r ty1 ty2) = do { p' <- go_prov cxt p + ; ty1' <- go cxt ty1 + ; ty2' <- go cxt ty2 + ; return (mkUnivCo p' r ty1' ty2') } + go_co cxt (SymCo co) = do { co' <- go_co cxt co + ; return (mkSymCo co') } + go_co cxt (TransCo co1 co2) = do { co1' <- go_co cxt co1 + ; co2' <- go_co cxt co2 + ; return (mkTransCo co1' co2') } + go_co cxt (NthCo r n co) = do { co' <- go_co cxt co + ; return (mkNthCo r n co') } + go_co cxt (LRCo lr co) = do { co' <- go_co cxt co + ; return (mkLRCo lr co') } + go_co cxt (InstCo co arg) = do { co' <- go_co cxt co + ; arg' <- go_co cxt arg + ; return (mkInstCo co' arg') } + go_co cxt (KindCo co) = do { co' <- go_co cxt co + ; return (mkKindCo co') } + go_co cxt (SubCo co) = do { co' <- go_co cxt co + ; return (mkSubCo co') } + go_co cxt (AxiomRuleCo ax cs) = do { cs' <- mapM (go_co cxt) cs + ; return (mkAxiomRuleCo ax cs') } + + ------------------ + go_prov _ UnsafeCoerceProv = return UnsafeCoerceProv + go_prov cxt (PhantomProv co) = PhantomProv <$> go_co cxt co + go_prov cxt (ProofIrrelProv co) = ProofIrrelProv <$> go_co cxt co + go_prov _ p@(PluginProv _) = return p + + +{- +%************************************************************************ +%* * + Miscellaneous functions +%* * +%************************************************************************ + +-} +-- | All type constructors occurring in the type; looking through type +-- synonyms, but not newtypes. +-- When it finds a Class, it returns the class TyCon. +tyConsOfType :: Type -> UniqSet TyCon +tyConsOfType ty + = go ty + where + go :: Type -> UniqSet TyCon -- The UniqSet does duplicate elim + go ty | Just ty' <- coreView ty = go ty' + go (TyVarTy {}) = emptyUniqSet + go (LitTy {}) = emptyUniqSet + go (TyConApp tc tys) = go_tc tc `unionUniqSets` go_s tys + go (AppTy a b) = go a `unionUniqSets` go b + go (FunTy _ a b) = go a `unionUniqSets` go b `unionUniqSets` go_tc funTyCon + go (ForAllTy (Bndr tv _) ty) = go ty `unionUniqSets` go (varType tv) + go (CastTy ty co) = go ty `unionUniqSets` go_co co + go (CoercionTy co) = go_co co + + go_co (Refl ty) = go ty + go_co (GRefl _ ty mco) = go ty `unionUniqSets` go_mco mco + go_co (TyConAppCo _ tc args) = go_tc tc `unionUniqSets` go_cos args + go_co (AppCo co arg) = go_co co `unionUniqSets` go_co arg + go_co (ForAllCo _ kind_co co) = go_co kind_co `unionUniqSets` go_co co + go_co (FunCo _ co1 co2) = go_co co1 `unionUniqSets` go_co co2 + go_co (AxiomInstCo ax _ args) = go_ax ax `unionUniqSets` go_cos args + go_co (UnivCo p _ t1 t2) = go_prov p `unionUniqSets` go t1 `unionUniqSets` go t2 + go_co (CoVarCo {}) = emptyUniqSet + go_co (HoleCo {}) = emptyUniqSet + go_co (SymCo co) = go_co co + go_co (TransCo co1 co2) = go_co co1 `unionUniqSets` go_co co2 + go_co (NthCo _ _ co) = go_co co + go_co (LRCo _ co) = go_co co + go_co (InstCo co arg) = go_co co `unionUniqSets` go_co arg + go_co (KindCo co) = go_co co + go_co (SubCo co) = go_co co + go_co (AxiomRuleCo _ cs) = go_cos cs + + go_mco MRefl = emptyUniqSet + go_mco (MCo co) = go_co co + + go_prov UnsafeCoerceProv = emptyUniqSet + go_prov (PhantomProv co) = go_co co + go_prov (ProofIrrelProv co) = go_co co + go_prov (PluginProv _) = emptyUniqSet + -- this last case can happen from the tyConsOfType used from + -- checkTauTvUpdate + + go_s tys = foldr (unionUniqSets . go) emptyUniqSet tys + go_cos cos = foldr (unionUniqSets . go_co) emptyUniqSet cos + + go_tc tc = unitUniqSet tc + go_ax ax = go_tc $ coAxiomTyCon ax + +-- | Find the result 'Kind' of a type synonym, +-- after applying it to its 'arity' number of type variables +-- Actually this function works fine on data types too, +-- but they'd always return '*', so we never need to ask +synTyConResKind :: TyCon -> Kind +synTyConResKind tycon = piResultTys (tyConKind tycon) (mkTyVarTys (tyConTyVars tycon)) + +-- | Retrieve the free variables in this type, splitting them based +-- on whether they are used visibly or invisibly. Invisible ones come +-- first. +splitVisVarsOfType :: Type -> Pair TyCoVarSet +splitVisVarsOfType orig_ty = Pair invis_vars vis_vars + where + Pair invis_vars1 vis_vars = go orig_ty + invis_vars = invis_vars1 `minusVarSet` vis_vars + + go (TyVarTy tv) = Pair (tyCoVarsOfType $ tyVarKind tv) (unitVarSet tv) + go (AppTy t1 t2) = go t1 `mappend` go t2 + go (TyConApp tc tys) = go_tc tc tys + go (FunTy _ t1 t2) = go t1 `mappend` go t2 + go (ForAllTy (Bndr tv _) ty) + = ((`delVarSet` tv) <$> go ty) `mappend` + (invisible (tyCoVarsOfType $ varType tv)) + go (LitTy {}) = mempty + go (CastTy ty co) = go ty `mappend` invisible (tyCoVarsOfCo co) + go (CoercionTy co) = invisible $ tyCoVarsOfCo co + + invisible vs = Pair vs emptyVarSet + + go_tc tc tys = let (invis, vis) = partitionInvisibleTypes tc tys in + invisible (tyCoVarsOfTypes invis) `mappend` foldMap go vis + +splitVisVarsOfTypes :: [Type] -> Pair TyCoVarSet +splitVisVarsOfTypes = foldMap splitVisVarsOfType + +modifyJoinResTy :: Int -- Number of binders to skip + -> (Type -> Type) -- Function to apply to result type + -> Type -- Type of join point + -> Type -- New type +-- INVARIANT: If any of the first n binders are foralls, those tyvars cannot +-- appear in the original result type. See isValidJoinPointType. +modifyJoinResTy orig_ar f orig_ty + = go orig_ar orig_ty + where + go 0 ty = f ty + go n ty | Just (arg_bndr, res_ty) <- splitPiTy_maybe ty + = mkPiTy arg_bndr (go (n-1) res_ty) + | otherwise + = pprPanic "modifyJoinResTy" (ppr orig_ar <+> ppr orig_ty) + +setJoinResTy :: Int -- Number of binders to skip + -> Type -- New result type + -> Type -- Type of join point + -> Type -- New type +-- INVARIANT: Same as for modifyJoinResTy +setJoinResTy ar new_res_ty ty + = modifyJoinResTy ar (const new_res_ty) ty + + +{- +%************************************************************************ +%* * + Pretty-printing +%* * +%************************************************************************ + +Most pretty-printing is either in TyCoRep or IfaceType. + +-} + +-- | This variant preserves any use of TYPE in a type, effectively +-- locally setting -fprint-explicit-runtime-reps. +pprWithTYPE :: Type -> SDoc +pprWithTYPE ty = updSDocDynFlags (flip gopt_set Opt_PrintExplicitRuntimeReps) $ + ppr ty diff --git a/compiler/types/Type.hs-boot b/compiler/types/Type.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/types/Type.hs-boot @@ -0,0 +1,26 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Type where + +import GhcPrelude +import TyCon +import Var ( TyCoVar ) +import {-# SOURCE #-} TyCoRep( Type, Coercion ) +import Util + +isPredTy :: HasDebugCallStack => Type -> Bool +isCoercionTy :: Type -> Bool + +mkAppTy :: Type -> Type -> Type +mkCastTy :: Type -> Coercion -> Type +piResultTy :: HasDebugCallStack => Type -> Type -> Type + +eqType :: Type -> Type -> Bool + +coreView :: Type -> Maybe Type +tcView :: Type -> Maybe Type + +tyCoVarsOfTypesWellScoped :: [Type] -> [TyCoVar] +tyCoVarsOfTypeWellScoped :: Type -> [TyCoVar] +scopedSort :: [TyCoVar] -> [TyCoVar] +splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) diff --git a/compiler/types/Unify.hs b/compiler/types/Unify.hs new file mode 100644 --- /dev/null +++ b/compiler/types/Unify.hs @@ -0,0 +1,1563 @@ +-- (c) The University of Glasgow 2006 + +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} + +module Unify ( + tcMatchTy, tcMatchTyKi, + tcMatchTys, tcMatchTyKis, + tcMatchTyX, tcMatchTysX, tcMatchTyKisX, + tcMatchTyX_BM, ruleMatchTyKiX, + + -- * Rough matching + roughMatchTcs, instanceCantMatch, + typesCantMatch, + + -- Side-effect free unification + tcUnifyTy, tcUnifyTyKi, tcUnifyTys, tcUnifyTyKis, + tcUnifyTysFG, tcUnifyTyWithTFs, + BindFlag(..), + UnifyResult, UnifyResultM(..), + + -- Matching a type against a lifted type (coercion) + liftCoMatch + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import Var +import VarEnv +import VarSet +import Name( Name ) +import Type hiding ( getTvSubstEnv ) +import Coercion hiding ( getCvSubstEnv ) +import TyCon +import TyCoRep hiding ( getTvSubstEnv, getCvSubstEnv ) +import FV( FV, fvVarSet, fvVarList ) +import Util +import Pair +import Outputable +import UniqFM +import UniqSet + +import Control.Monad +import qualified Control.Monad.Fail as MonadFail +import Control.Applicative hiding ( empty ) +import qualified Control.Applicative + +{- + +Unification is much tricker than you might think. + +1. The substitution we generate binds the *template type variables* + which are given to us explicitly. + +2. We want to match in the presence of foralls; + e.g (forall a. t1) ~ (forall b. t2) + + That is what the RnEnv2 is for; it does the alpha-renaming + that makes it as if a and b were the same variable. + Initialising the RnEnv2, so that it can generate a fresh + binder when necessary, entails knowing the free variables of + both types. + +3. We must be careful not to bind a template type variable to a + locally bound variable. E.g. + (forall a. x) ~ (forall b. b) + where x is the template type variable. Then we do not want to + bind x to a/b! This is a kind of occurs check. + The necessary locals accumulate in the RnEnv2. + +Note [tcMatchTy vs tcMatchTyKi] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This module offers two variants of matching: with kinds and without. +The TyKi variant takes two types, of potentially different kinds, +and matches them. Along the way, it necessarily also matches their +kinds. The Ty variant instead assumes that the kinds are already +eqType and so skips matching up the kinds. + +How do you choose between them? + +1. If you know that the kinds of the two types are eqType, use + the Ty variant. It is more efficient, as it does less work. + +2. If the kinds of variables in the template type might mention type families, + use the Ty variant (and do other work to make sure the kinds + work out). These pure unification functions do a straightforward + syntactic unification and do no complex reasoning about type + families. Note that the types of the variables in instances can indeed + mention type families, so instance lookup must use the Ty variant. + + (Nothing goes terribly wrong -- no panics -- if there might be type + families in kinds in the TyKi variant. You just might get match + failure even though a reducing a type family would lead to success.) + +3. Otherwise, if you're sure that the variable kinds do not mention + type families and you're not already sure that the kind of the template + equals the kind of the target, then use the TyKi version. +-} + +-- | @tcMatchTy t1 t2@ produces a substitution (over fvs(t1)) +-- @s@ such that @s(t1)@ equals @t2@. +-- The returned substitution might bind coercion variables, +-- if the variable is an argument to a GADT constructor. +-- +-- Precondition: typeKind ty1 `eqType` typeKind ty2 +-- +-- We don't pass in a set of "template variables" to be bound +-- by the match, because tcMatchTy (and similar functions) are +-- always used on top-level types, so we can bind any of the +-- free variables of the LHS. +-- See also Note [tcMatchTy vs tcMatchTyKi] +tcMatchTy :: Type -> Type -> Maybe TCvSubst +tcMatchTy ty1 ty2 = tcMatchTys [ty1] [ty2] + +tcMatchTyX_BM :: (TyVar -> BindFlag) -> TCvSubst + -> Type -> Type -> Maybe TCvSubst +tcMatchTyX_BM bind_me subst ty1 ty2 + = tc_match_tys_x bind_me False subst [ty1] [ty2] + +-- | Like 'tcMatchTy', but allows the kinds of the types to differ, +-- and thus matches them as well. +-- See also Note [tcMatchTy vs tcMatchTyKi] +tcMatchTyKi :: Type -> Type -> Maybe TCvSubst +tcMatchTyKi ty1 ty2 + = tc_match_tys (const BindMe) True [ty1] [ty2] + +-- | This is similar to 'tcMatchTy', but extends a substitution +-- See also Note [tcMatchTy vs tcMatchTyKi] +tcMatchTyX :: TCvSubst -- ^ Substitution to extend + -> Type -- ^ Template + -> Type -- ^ Target + -> Maybe TCvSubst +tcMatchTyX subst ty1 ty2 + = tc_match_tys_x (const BindMe) False subst [ty1] [ty2] + +-- | Like 'tcMatchTy' but over a list of types. +-- See also Note [tcMatchTy vs tcMatchTyKi] +tcMatchTys :: [Type] -- ^ Template + -> [Type] -- ^ Target + -> Maybe TCvSubst -- ^ One-shot; in principle the template + -- variables could be free in the target +tcMatchTys tys1 tys2 + = tc_match_tys (const BindMe) False tys1 tys2 + +-- | Like 'tcMatchTyKi' but over a list of types. +-- See also Note [tcMatchTy vs tcMatchTyKi] +tcMatchTyKis :: [Type] -- ^ Template + -> [Type] -- ^ Target + -> Maybe TCvSubst -- ^ One-shot substitution +tcMatchTyKis tys1 tys2 + = tc_match_tys (const BindMe) True tys1 tys2 + +-- | Like 'tcMatchTys', but extending a substitution +-- See also Note [tcMatchTy vs tcMatchTyKi] +tcMatchTysX :: TCvSubst -- ^ Substitution to extend + -> [Type] -- ^ Template + -> [Type] -- ^ Target + -> Maybe TCvSubst -- ^ One-shot substitution +tcMatchTysX subst tys1 tys2 + = tc_match_tys_x (const BindMe) False subst tys1 tys2 + +-- | Like 'tcMatchTyKis', but extending a substitution +-- See also Note [tcMatchTy vs tcMatchTyKi] +tcMatchTyKisX :: TCvSubst -- ^ Substitution to extend + -> [Type] -- ^ Template + -> [Type] -- ^ Target + -> Maybe TCvSubst -- ^ One-shot substitution +tcMatchTyKisX subst tys1 tys2 + = tc_match_tys_x (const BindMe) True subst tys1 tys2 + +-- | Same as tc_match_tys_x, but starts with an empty substitution +tc_match_tys :: (TyVar -> BindFlag) + -> Bool -- ^ match kinds? + -> [Type] + -> [Type] + -> Maybe TCvSubst +tc_match_tys bind_me match_kis tys1 tys2 + = tc_match_tys_x bind_me match_kis (mkEmptyTCvSubst in_scope) tys1 tys2 + where + in_scope = mkInScopeSet (tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2) + +-- | Worker for 'tcMatchTysX' and 'tcMatchTyKisX' +tc_match_tys_x :: (TyVar -> BindFlag) + -> Bool -- ^ match kinds? + -> TCvSubst + -> [Type] + -> [Type] + -> Maybe TCvSubst +tc_match_tys_x bind_me match_kis (TCvSubst in_scope tv_env cv_env) tys1 tys2 + = case tc_unify_tys bind_me + False -- Matching, not unifying + False -- Not an injectivity check + match_kis + (mkRnEnv2 in_scope) tv_env cv_env tys1 tys2 of + Unifiable (tv_env', cv_env') + -> Just $ TCvSubst in_scope tv_env' cv_env' + _ -> Nothing + +-- | This one is called from the expression matcher, +-- which already has a MatchEnv in hand +ruleMatchTyKiX + :: TyCoVarSet -- ^ template variables + -> RnEnv2 + -> TvSubstEnv -- ^ type substitution to extend + -> Type -- ^ Template + -> Type -- ^ Target + -> Maybe TvSubstEnv +ruleMatchTyKiX tmpl_tvs rn_env tenv tmpl target +-- See Note [Kind coercions in Unify] + = case tc_unify_tys (matchBindFun tmpl_tvs) False False + True -- <-- this means to match the kinds + rn_env tenv emptyCvSubstEnv [tmpl] [target] of + Unifiable (tenv', _) -> Just tenv' + _ -> Nothing + +matchBindFun :: TyCoVarSet -> TyVar -> BindFlag +matchBindFun tvs tv = if tv `elemVarSet` tvs then BindMe else Skolem + + +{- ********************************************************************* +* * + Rough matching +* * +********************************************************************* -} + +-- See Note [Rough match] field in InstEnv + +roughMatchTcs :: [Type] -> [Maybe Name] +roughMatchTcs tys = map rough tys + where + rough ty + | Just (ty', _) <- splitCastTy_maybe ty = rough ty' + | Just (tc,_) <- splitTyConApp_maybe ty = Just (tyConName tc) + | otherwise = Nothing + +instanceCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool +-- (instanceCantMatch tcs1 tcs2) returns True if tcs1 cannot +-- possibly be instantiated to actual, nor vice versa; +-- False is non-committal +instanceCantMatch (mt : ts) (ma : as) = itemCantMatch mt ma || instanceCantMatch ts as +instanceCantMatch _ _ = False -- Safe + +itemCantMatch :: Maybe Name -> Maybe Name -> Bool +itemCantMatch (Just t) (Just a) = t /= a +itemCantMatch _ _ = False + + +{- +************************************************************************ +* * + GADTs +* * +************************************************************************ + +Note [Pruning dead case alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider data T a where + T1 :: T Int + T2 :: T a + + newtype X = MkX Int + newtype Y = MkY Char + + type family F a + type instance F Bool = Int + +Now consider case x of { T1 -> e1; T2 -> e2 } + +The question before the house is this: if I know something about the type +of x, can I prune away the T1 alternative? + +Suppose x::T Char. It's impossible to construct a (T Char) using T1, + Answer = YES we can prune the T1 branch (clearly) + +Suppose x::T (F a), where 'a' is in scope. Then 'a' might be instantiated +to 'Bool', in which case x::T Int, so + ANSWER = NO (clearly) + +We see here that we want precisely the apartness check implemented within +tcUnifyTysFG. So that's what we do! Two types cannot match if they are surely +apart. Note that since we are simply dropping dead code, a conservative test +suffices. +-} + +-- | Given a list of pairs of types, are any two members of a pair surely +-- apart, even after arbitrary type function evaluation and substitution? +typesCantMatch :: [(Type,Type)] -> Bool +-- See Note [Pruning dead case alternatives] +typesCantMatch prs = any (uncurry cant_match) prs + where + cant_match :: Type -> Type -> Bool + cant_match t1 t2 = case tcUnifyTysFG (const BindMe) [t1] [t2] of + SurelyApart -> True + _ -> False + +{- +************************************************************************ +* * + Unification +* * +************************************************************************ + +Note [Fine-grained unification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Do the types (x, x) and ([y], y) unify? The answer is seemingly "no" -- +no substitution to finite types makes these match. But, a substitution to +*infinite* types can unify these two types: [x |-> [[[...]]], y |-> [[[...]]] ]. +Why do we care? Consider these two type family instances: + +type instance F x x = Int +type instance F [y] y = Bool + +If we also have + +type instance Looper = [Looper] + +then the instances potentially overlap. The solution is to use unification +over infinite terms. This is possible (see [1] for lots of gory details), but +a full algorithm is a little more power than we need. Instead, we make a +conservative approximation and just omit the occurs check. + +[1]: http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/axioms-extended.pdf + +tcUnifyTys considers an occurs-check problem as the same as general unification +failure. + +tcUnifyTysFG ("fine-grained") returns one of three results: success, occurs-check +failure ("MaybeApart"), or general failure ("SurelyApart"). + +See also #8162. + +It's worth noting that unification in the presence of infinite types is not +complete. This means that, sometimes, a closed type family does not reduce +when it should. See test case indexed-types/should_fail/Overlap15 for an +example. + +Note [The substitution in MaybeApart] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The constructor MaybeApart carries data with it, typically a TvSubstEnv. Why? +Because consider unifying these: + +(a, a, Int) ~ (b, [b], Bool) + +If we go left-to-right, we start with [a |-> b]. Then, on the middle terms, we +apply the subst we have so far and discover that we need [b |-> [b]]. Because +this fails the occurs check, we say that the types are MaybeApart (see above +Note [Fine-grained unification]). But, we can't stop there! Because if we +continue, we discover that Int is SurelyApart from Bool, and therefore the +types are apart. This has practical consequences for the ability for closed +type family applications to reduce. See test case +indexed-types/should_compile/Overlap14. + +Note [Unifying with skolems] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +If we discover that two types unify if and only if a skolem variable is +substituted, we can't properly unify the types. But, that skolem variable +may later be instantiated with a unifyable type. So, we return maybeApart +in these cases. +-} + +-- | Simple unification of two types; all type variables are bindable +-- Precondition: the kinds are already equal +tcUnifyTy :: Type -> Type -- All tyvars are bindable + -> Maybe TCvSubst + -- A regular one-shot (idempotent) substitution +tcUnifyTy t1 t2 = tcUnifyTys (const BindMe) [t1] [t2] + +-- | Like 'tcUnifyTy', but also unifies the kinds +tcUnifyTyKi :: Type -> Type -> Maybe TCvSubst +tcUnifyTyKi t1 t2 = tcUnifyTyKis (const BindMe) [t1] [t2] + +-- | Unify two types, treating type family applications as possibly unifying +-- with anything and looking through injective type family applications. +-- Precondition: kinds are the same +tcUnifyTyWithTFs :: Bool -- ^ True <=> do two-way unification; + -- False <=> do one-way matching. + -- See end of sec 5.2 from the paper + -> Type -> Type -> Maybe TCvSubst +-- This algorithm is an implementation of the "Algorithm U" presented in +-- the paper "Injective type families for Haskell", Figures 2 and 3. +-- The code is incorporated with the standard unifier for convenience, but +-- its operation should match the specification in the paper. +tcUnifyTyWithTFs twoWay t1 t2 + = case tc_unify_tys (const BindMe) twoWay True False + rn_env emptyTvSubstEnv emptyCvSubstEnv + [t1] [t2] of + Unifiable (subst, _) -> Just $ niFixTCvSubst subst + MaybeApart (subst, _) -> Just $ niFixTCvSubst subst + -- we want to *succeed* in questionable cases. This is a + -- pre-unification algorithm. + SurelyApart -> Nothing + where + rn_env = mkRnEnv2 $ mkInScopeSet $ tyCoVarsOfTypes [t1, t2] + +----------------- +tcUnifyTys :: (TyCoVar -> BindFlag) + -> [Type] -> [Type] + -> Maybe TCvSubst + -- ^ A regular one-shot (idempotent) substitution + -- that unifies the erased types. See comments + -- for 'tcUnifyTysFG' + +-- The two types may have common type variables, and indeed do so in the +-- second call to tcUnifyTys in FunDeps.checkClsFD +tcUnifyTys bind_fn tys1 tys2 + = case tcUnifyTysFG bind_fn tys1 tys2 of + Unifiable result -> Just result + _ -> Nothing + +-- | Like 'tcUnifyTys' but also unifies the kinds +tcUnifyTyKis :: (TyCoVar -> BindFlag) + -> [Type] -> [Type] + -> Maybe TCvSubst +tcUnifyTyKis bind_fn tys1 tys2 + = case tcUnifyTyKisFG bind_fn tys1 tys2 of + Unifiable result -> Just result + _ -> Nothing + +-- This type does double-duty. It is used in the UM (unifier monad) and to +-- return the final result. See Note [Fine-grained unification] +type UnifyResult = UnifyResultM TCvSubst +data UnifyResultM a = Unifiable a -- the subst that unifies the types + | MaybeApart a -- the subst has as much as we know + -- it must be part of a most general unifier + -- See Note [The substitution in MaybeApart] + | SurelyApart + deriving Functor + +instance Applicative UnifyResultM where + pure = Unifiable + (<*>) = ap + +instance Monad UnifyResultM where + + SurelyApart >>= _ = SurelyApart + MaybeApart x >>= f = case f x of + Unifiable y -> MaybeApart y + other -> other + Unifiable x >>= f = f x + +instance Alternative UnifyResultM where + empty = SurelyApart + + a@(Unifiable {}) <|> _ = a + _ <|> b@(Unifiable {}) = b + a@(MaybeApart {}) <|> _ = a + _ <|> b@(MaybeApart {}) = b + SurelyApart <|> SurelyApart = SurelyApart + +instance MonadPlus UnifyResultM + +-- | @tcUnifyTysFG bind_tv tys1 tys2@ attepts to find a substitution @s@ (whose +-- domain elements all respond 'BindMe' to @bind_tv@) such that +-- @s(tys1)@ and that of @s(tys2)@ are equal, as witnessed by the returned +-- Coercions. This version requires that the kinds of the types are the same, +-- if you unify left-to-right. +tcUnifyTysFG :: (TyVar -> BindFlag) + -> [Type] -> [Type] + -> UnifyResult +tcUnifyTysFG bind_fn tys1 tys2 + = tc_unify_tys_fg False bind_fn tys1 tys2 + +tcUnifyTyKisFG :: (TyVar -> BindFlag) + -> [Type] -> [Type] + -> UnifyResult +tcUnifyTyKisFG bind_fn tys1 tys2 + = tc_unify_tys_fg True bind_fn tys1 tys2 + +tc_unify_tys_fg :: Bool + -> (TyVar -> BindFlag) + -> [Type] -> [Type] + -> UnifyResult +tc_unify_tys_fg match_kis bind_fn tys1 tys2 + = do { (env, _) <- tc_unify_tys bind_fn True False match_kis env + emptyTvSubstEnv emptyCvSubstEnv + tys1 tys2 + ; return $ niFixTCvSubst env } + where + vars = tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2 + env = mkRnEnv2 $ mkInScopeSet vars + +-- | This function is actually the one to call the unifier -- a little +-- too general for outside clients, though. +tc_unify_tys :: (TyVar -> BindFlag) + -> AmIUnifying -- ^ True <=> unify; False <=> match + -> Bool -- ^ True <=> doing an injectivity check + -> Bool -- ^ True <=> treat the kinds as well + -> RnEnv2 + -> TvSubstEnv -- ^ substitution to extend + -> CvSubstEnv + -> [Type] -> [Type] + -> UnifyResultM (TvSubstEnv, CvSubstEnv) +-- NB: It's tempting to ASSERT here that, if we're not matching kinds, then +-- the kinds of the types should be the same. However, this doesn't work, +-- as the types may be a dependent telescope, where later types have kinds +-- that mention variables occurring earlier in the list of types. Here's an +-- example (from typecheck/should_fail/T12709): +-- template: [rep :: RuntimeRep, a :: TYPE rep] +-- target: [LiftedRep :: RuntimeRep, Int :: TYPE LiftedRep] +-- We can see that matching the first pair will make the kinds of the second +-- pair equal. Yet, we still don't need a separate pass to unify the kinds +-- of these types, so it's appropriate to use the Ty variant of unification. +-- See also Note [tcMatchTy vs tcMatchTyKi]. +tc_unify_tys bind_fn unif inj_check match_kis rn_env tv_env cv_env tys1 tys2 + = initUM tv_env cv_env $ + do { when match_kis $ + unify_tys env kis1 kis2 + ; unify_tys env tys1 tys2 + ; (,) <$> getTvSubstEnv <*> getCvSubstEnv } + where + env = UMEnv { um_bind_fun = bind_fn + , um_skols = emptyVarSet + , um_unif = unif + , um_inj_tf = inj_check + , um_rn_env = rn_env } + + kis1 = map typeKind tys1 + kis2 = map typeKind tys2 + +instance Outputable a => Outputable (UnifyResultM a) where + ppr SurelyApart = text "SurelyApart" + ppr (Unifiable x) = text "Unifiable" <+> ppr x + ppr (MaybeApart x) = text "MaybeApart" <+> ppr x + +{- +************************************************************************ +* * + Non-idempotent substitution +* * +************************************************************************ + +Note [Non-idempotent substitution] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +During unification we use a TvSubstEnv/CvSubstEnv pair that is + (a) non-idempotent + (b) loop-free; ie repeatedly applying it yields a fixed point + +Note [Finding the substitution fixpoint] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Finding the fixpoint of a non-idempotent substitution arising from a +unification is much trickier than it looks, because of kinds. Consider + T k (H k (f:k)) ~ T * (g:*) +If we unify, we get the substitution + [ k -> * + , g -> H k (f:k) ] +To make it idempotent we don't want to get just + [ k -> * + , g -> H * (f:k) ] +We also want to substitute inside f's kind, to get + [ k -> * + , g -> H k (f:*) ] +If we don't do this, we may apply the substitution to something, +and get an ill-formed type, i.e. one where typeKind will fail. +This happened, for example, in #9106. + +It gets worse. In #14164 we wanted to take the fixpoint of +this substitution + [ xs_asV :-> F a_aY6 (z_aY7 :: a_aY6) + (rest_aWF :: G a_aY6 (z_aY7 :: a_aY6)) + , a_aY6 :-> a_aXQ ] + +We have to apply the substitution for a_aY6 two levels deep inside +the invocation of F! We don't have a function that recursively +applies substitutions inside the kinds of variable occurrences (and +probably rightly so). + +So, we work as follows: + + 1. Start with the current substitution (which we are + trying to fixpoint + [ xs :-> F a (z :: a) (rest :: G a (z :: a)) + , a :-> b ] + + 2. Take all the free vars of the range of the substitution: + {a, z, rest, b} + NB: the free variable finder closes over + the kinds of variable occurrences + + 3. If none are in the domain of the substitution, stop. + We have found a fixpoint. + + 4. Remove the variables that are bound by the substitution, leaving + {z, rest, b} + + 5. Do a topo-sort to put them in dependency order: + [ b :: *, z :: a, rest :: G a z ] + + 6. Apply the substitution left-to-right to the kinds of these + tyvars, extending it each time with a new binding, so we + finish up with + [ xs :-> ..as before.. + , a :-> b + , b :-> b :: * + , z :-> z :: b + , rest :-> rest :: G b (z :: b) ] + Note that rest now has the right kind + + 7. Apply this extended substitution (once) to the range of + the /original/ substitution. (Note that we do the + extended substitution would go on forever if you tried + to find its fixpoint, because it maps z to z.) + + 8. And go back to step 1 + +In Step 6 we use the free vars from Step 2 as the initial +in-scope set, because all of those variables appear in the +range of the substitution, so they must all be in the in-scope +set. But NB that the type substitution engine does not look up +variables in the in-scope set; it is used only to ensure no +shadowing. +-} + +niFixTCvSubst :: TvSubstEnv -> TCvSubst +-- Find the idempotent fixed point of the non-idempotent substitution +-- This is surprisingly tricky: +-- see Note [Finding the substitution fixpoint] +-- ToDo: use laziness instead of iteration? +niFixTCvSubst tenv + | not_fixpoint = niFixTCvSubst (mapVarEnv (substTy subst) tenv) + | otherwise = subst + where + range_fvs :: FV + range_fvs = tyCoFVsOfTypes (nonDetEltsUFM tenv) + -- It's OK to use nonDetEltsUFM here because the + -- order of range_fvs, range_tvs is immaterial + + range_tvs :: [TyVar] + range_tvs = fvVarList range_fvs + + not_fixpoint = any in_domain range_tvs + in_domain tv = tv `elemVarEnv` tenv + + free_tvs = scopedSort (filterOut in_domain range_tvs) + + -- See Note [Finding the substitution fixpoint], Step 6 + init_in_scope = mkInScopeSet (fvVarSet range_fvs) + subst = foldl' add_free_tv + (mkTvSubst init_in_scope tenv) + free_tvs + + add_free_tv :: TCvSubst -> TyVar -> TCvSubst + add_free_tv subst tv + = extendTvSubst subst tv (mkTyVarTy tv') + where + tv' = updateTyVarKind (substTy subst) tv + +niSubstTvSet :: TvSubstEnv -> TyCoVarSet -> TyCoVarSet +-- Apply the non-idempotent substitution to a set of type variables, +-- remembering that the substitution isn't necessarily idempotent +-- This is used in the occurs check, before extending the substitution +niSubstTvSet tsubst tvs + = nonDetFoldUniqSet (unionVarSet . get) emptyVarSet tvs + -- It's OK to nonDetFoldUFM here because we immediately forget the + -- ordering by creating a set. + where + get tv + | Just ty <- lookupVarEnv tsubst tv + = niSubstTvSet tsubst (tyCoVarsOfType ty) + + | otherwise + = unitVarSet tv + +{- +************************************************************************ +* * + unify_ty: the main workhorse +* * +************************************************************************ + +Note [Specification of unification] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The pure unifier, unify_ty, defined in this module, tries to work out +a substitution to make two types say True to eqType. NB: eqType is +itself not purely syntactic; it accounts for CastTys; +see Note [Non-trivial definitional equality] in TyCoRep + +Unlike the "impure unifiers" in the typechecker (the eager unifier in +TcUnify, and the constraint solver itself in TcCanonical), the pure +unifier It does /not/ work up to ~. + +The algorithm implemented here is rather delicate, and we depend on it +to uphold certain properties. This is a summary of these required +properties. Any reference to "flattening" refers to the flattening +algorithm in FamInstEnv (See Note [Flattening] in FamInstEnv), not +the flattening algorithm in the solver. + +Notation: + θ,φ substitutions + ξ type-function-free types + τ,σ other types + τ♭ type τ, flattened + + ≡ eqType + +(U1) Soundness. + If (unify τ₁ τ₂) = Unifiable θ, then θ(τ₁) ≡ θ(τ₂). + θ is a most general unifier for τ₁ and τ₂. + +(U2) Completeness. + If (unify ξ₁ ξ₂) = SurelyApart, + then there exists no substitution θ such that θ(ξ₁) ≡ θ(ξ₂). + +These two properties are stated as Property 11 in the "Closed Type Families" +paper (POPL'14). Below, this paper is called [CTF]. + +(U3) Apartness under substitution. + If (unify ξ τ♭) = SurelyApart, then (unify ξ θ(τ)♭) = SurelyApart, + for any θ. (Property 12 from [CTF]) + +(U4) Apart types do not unify. + If (unify ξ τ♭) = SurelyApart, then there exists no θ + such that θ(ξ) = θ(τ). (Property 13 from [CTF]) + +THEOREM. Completeness w.r.t ~ + If (unify τ₁♭ τ₂♭) = SurelyApart, + then there exists no proof that (τ₁ ~ τ₂). + +PROOF. See appendix of [CTF]. + + +The unification algorithm is used for type family injectivity, as described +in the "Injective Type Families" paper (Haskell'15), called [ITF]. When run +in this mode, it has the following properties. + +(I1) If (unify σ τ) = SurelyApart, then σ and τ are not unifiable, even + after arbitrary type family reductions. Note that σ and τ are + not flattened here. + +(I2) If (unify σ τ) = MaybeApart θ, and if some + φ exists such that φ(σ) ~ φ(τ), then φ extends θ. + + +Furthermore, the RULES matching algorithm requires this property, +but only when using this algorithm for matching: + +(M1) If (match σ τ) succeeds with θ, then all matchable tyvars + in σ are bound in θ. + + Property M1 means that we must extend the substitution with, + say (a ↦ a) when appropriate during matching. + See also Note [Self-substitution when matching]. + +(M2) Completeness of matching. + If θ(σ) = τ, then (match σ τ) = Unifiable φ, + where θ is an extension of φ. + +Sadly, property M2 and I2 conflict. Consider + +type family F1 a b where + F1 Int Bool = Char + F1 Double String = Char + +Consider now two matching problems: + +P1. match (F1 a Bool) (F1 Int Bool) +P2. match (F1 a Bool) (F1 Double String) + +In case P1, we must find (a ↦ Int) to satisfy M2. +In case P2, we must /not/ find (a ↦ Double), in order to satisfy I2. (Note +that the correct mapping for I2 is (a ↦ Int). There is no way to discover +this, but we musn't map a to anything else!) + +We thus must parameterize the algorithm over whether it's being used +for an injectivity check (refrain from looking at non-injective arguments +to type families) or not (do indeed look at those arguments). This is +implemented by the uf_inj_tf field of UmEnv. + +(It's all a question of whether or not to include equation (7) from Fig. 2 +of [ITF].) + +This extra parameter is a bit fiddly, perhaps, but seemingly less so than +having two separate, almost-identical algorithms. + +Note [Self-substitution when matching] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +What should happen when we're *matching* (not unifying) a1 with a1? We +should get a substitution [a1 |-> a1]. A successful match should map all +the template variables (except ones that disappear when expanding synonyms). +But when unifying, we don't want to do this, because we'll then fall into +a loop. + +This arrangement affects the code in three places: + - If we're matching a refined template variable, don't recur. Instead, just + check for equality. That is, if we know [a |-> Maybe a] and are matching + (a ~? Maybe Int), we want to just fail. + + - Skip the occurs check when matching. This comes up in two places, because + matching against variables is handled separately from matching against + full-on types. + +Note that this arrangement was provoked by a real failure, where the same +unique ended up in the template as in the target. (It was a rule firing when +compiling Data.List.NonEmpty.) + +Note [Matching coercion variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this: + + type family F a + + data G a where + MkG :: F a ~ Bool => G a + + type family Foo (x :: G a) :: F a + type instance Foo MkG = False + +We would like that to be accepted. For that to work, we need to introduce +a coercion variable on the left and then use it on the right. Accordingly, +at use sites of Foo, we need to be able to use matching to figure out the +value for the coercion. (See the desugared version: + + axFoo :: [a :: *, c :: F a ~ Bool]. Foo (MkG c) = False |> (sym c) + +) We never want this action to happen during *unification* though, when +all bets are off. + +Note [Kind coercions in Unify] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We wish to match/unify while ignoring casts. But, we can't just ignore +them completely, or we'll end up with ill-kinded substitutions. For example, +say we're matching `a` with `ty |> co`. If we just drop the cast, we'll +return [a |-> ty], but `a` and `ty` might have different kinds. We can't +just match/unify their kinds, either, because this might gratuitously +fail. After all, `co` is the witness that the kinds are the same -- they +may look nothing alike. + +So, we pass a kind coercion to the match/unify worker. This coercion witnesses +the equality between the substed kind of the left-hand type and the substed +kind of the right-hand type. Note that we do not unify kinds at the leaves +(as we did previously). We thus have + +INVARIANT: In the call + unify_ty ty1 ty2 kco +it must be that subst(kco) :: subst(kind(ty1)) ~N subst(kind(ty2)), where +`subst` is the ambient substitution in the UM monad. + +To get this coercion, we first have to match/unify +the kinds before looking at the types. Happily, we need look only one level +up, as all kinds are guaranteed to have kind *. + +When we're working with type applications (either TyConApp or AppTy) we +need to worry about establishing INVARIANT, as the kinds of the function +& arguments aren't (necessarily) included in the kind of the result. +When unifying two TyConApps, this is easy, because the two TyCons are +the same. Their kinds are thus the same. As long as we unify left-to-right, +we'll be sure to unify types' kinds before the types themselves. (For example, +think about Proxy :: forall k. k -> *. Unifying the first args matches up +the kinds of the second args.) + +For AppTy, we must unify the kinds of the functions, but once these are +unified, we can continue unifying arguments without worrying further about +kinds. + +The interface to this module includes both "...Ty" functions and +"...TyKi" functions. The former assume that INVARIANT is already +established, either because the kinds are the same or because the +list of types being passed in are the well-typed arguments to some +type constructor (see two paragraphs above). The latter take a separate +pre-pass over the kinds to establish INVARIANT. Sometimes, it's important +not to take the second pass, as it caused #12442. + +We thought, at one point, that this was all unnecessary: why should +casts be in types in the first place? But they are sometimes. In +dependent/should_compile/KindEqualities2, we see, for example the +constraint Num (Int |> (blah ; sym blah)). We naturally want to find +a dictionary for that constraint, which requires dealing with +coercions in this manner. + +Note [Matching in the presence of casts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When matching, it is crucial that no variables from the template +end up in the range of the matching substitution (obviously!). +When unifying, that's not a constraint; instead we take the fixpoint +of the substitution at the end. + +So what should we do with this, when matching? + unify_ty (tmpl |> co) tgt kco + +Previously, wrongly, we pushed 'co' in the (horrid) accumulating +'kco' argument like this: + unify_ty (tmpl |> co) tgt kco + = unify_ty tmpl tgt (kco ; co) + +But that is obviously wrong because 'co' (from the template) ends +up in 'kco', which in turn ends up in the range of the substitution. + +This all came up in #13910. Because we match tycon arguments +left-to-right, the ambient substitution will already have a matching +substitution for any kinds; so there is an easy fix: just apply +the substitution-so-far to the coercion from the LHS. + +Note that + +* When matching, the first arg of unify_ty is always the template; + we never swap round. + +* The above argument is distressingly indirect. We seek a + better way. + +* One better way is to ensure that type patterns (the template + in the matching process) have no casts. See #14119. + +Note [Polykinded tycon applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose T :: forall k. Type -> K +and we are unifying + ty1: T @Type Int :: Type + ty2: T @(Type->Type) Int Int :: Type + +These two TyConApps have the same TyCon at the front but they +(legitimately) have different numbers of arguments. They +are surelyApart, so we can report that without looking any +further (see #15704). +-} + +-------------- unify_ty: the main workhorse ----------- + +type AmIUnifying = Bool -- True <=> Unifying + -- False <=> Matching + +unify_ty :: UMEnv + -> Type -> Type -- Types to be unified and a co + -> CoercionN -- A coercion between their kinds + -- See Note [Kind coercions in Unify] + -> UM () +-- See Note [Specification of unification] +-- Respects newtypes, PredTypes + +unify_ty env ty1 ty2 kco + -- TODO: More commentary needed here + | Just ty1' <- tcView ty1 = unify_ty env ty1' ty2 kco + | Just ty2' <- tcView ty2 = unify_ty env ty1 ty2' kco + | CastTy ty1' co <- ty1 = if um_unif env + then unify_ty env ty1' ty2 (co `mkTransCo` kco) + else -- See Note [Matching in the presence of casts] + do { subst <- getSubst env + ; let co' = substCo subst co + ; unify_ty env ty1' ty2 (co' `mkTransCo` kco) } + | CastTy ty2' co <- ty2 = unify_ty env ty1 ty2' (kco `mkTransCo` mkSymCo co) + +unify_ty env (TyVarTy tv1) ty2 kco + = uVar env tv1 ty2 kco +unify_ty env ty1 (TyVarTy tv2) kco + | um_unif env -- If unifying, can swap args + = uVar (umSwapRn env) tv2 ty1 (mkSymCo kco) + +unify_ty env ty1 ty2 _kco + | Just (tc1, tys1) <- mb_tc_app1 + , Just (tc2, tys2) <- mb_tc_app2 + , tc1 == tc2 || (tcIsLiftedTypeKind ty1 && tcIsLiftedTypeKind ty2) + = if isInjectiveTyCon tc1 Nominal + then unify_tys env tys1 tys2 + else do { let inj | isTypeFamilyTyCon tc1 + = case tyConInjectivityInfo tc1 of + NotInjective -> repeat False + Injective bs -> bs + | otherwise + = repeat False + + (inj_tys1, noninj_tys1) = partitionByList inj tys1 + (inj_tys2, noninj_tys2) = partitionByList inj tys2 + + ; unify_tys env inj_tys1 inj_tys2 + ; unless (um_inj_tf env) $ -- See (end of) Note [Specification of unification] + don'tBeSoSure $ unify_tys env noninj_tys1 noninj_tys2 } + + | Just (tc1, _) <- mb_tc_app1 + , not (isGenerativeTyCon tc1 Nominal) + -- E.g. unify_ty (F ty1) b = MaybeApart + -- because the (F ty1) behaves like a variable + -- NB: if unifying, we have already dealt + -- with the 'ty2 = variable' case + = maybeApart + + | Just (tc2, _) <- mb_tc_app2 + , not (isGenerativeTyCon tc2 Nominal) + , um_unif env + -- E.g. unify_ty [a] (F ty2) = MaybeApart, when unifying (only) + -- because the (F ty2) behaves like a variable + -- NB: we have already dealt with the 'ty1 = variable' case + = maybeApart + + where + mb_tc_app1 = tcSplitTyConApp_maybe ty1 + mb_tc_app2 = tcSplitTyConApp_maybe ty2 + + -- Applications need a bit of care! + -- They can match FunTy and TyConApp, so use splitAppTy_maybe + -- NB: we've already dealt with type variables, + -- so if one type is an App the other one jolly well better be too +unify_ty env (AppTy ty1a ty1b) ty2 _kco + | Just (ty2a, ty2b) <- tcRepSplitAppTy_maybe ty2 + = unify_ty_app env ty1a [ty1b] ty2a [ty2b] + +unify_ty env ty1 (AppTy ty2a ty2b) _kco + | Just (ty1a, ty1b) <- tcRepSplitAppTy_maybe ty1 + = unify_ty_app env ty1a [ty1b] ty2a [ty2b] + +unify_ty _ (LitTy x) (LitTy y) _kco | x == y = return () + +unify_ty env (ForAllTy (Bndr tv1 _) ty1) (ForAllTy (Bndr tv2 _) ty2) kco + = do { unify_ty env (varType tv1) (varType tv2) (mkNomReflCo liftedTypeKind) + ; let env' = umRnBndr2 env tv1 tv2 + ; unify_ty env' ty1 ty2 kco } + +-- See Note [Matching coercion variables] +unify_ty env (CoercionTy co1) (CoercionTy co2) kco + = do { c_subst <- getCvSubstEnv + ; case co1 of + CoVarCo cv + | not (um_unif env) + , not (cv `elemVarEnv` c_subst) + , BindMe <- tvBindFlag env cv + -> do { checkRnEnv env (tyCoVarsOfCo co2) + ; let (co_l, co_r) = decomposeFunCo Nominal kco + -- cv :: t1 ~ t2 + -- co2 :: s1 ~ s2 + -- co_l :: t1 ~ s1 + -- co_r :: t2 ~ s2 + ; extendCvEnv cv (co_l `mkTransCo` + co2 `mkTransCo` + mkSymCo co_r) } + _ -> return () } + +unify_ty _ _ _ _ = surelyApart + +unify_ty_app :: UMEnv -> Type -> [Type] -> Type -> [Type] -> UM () +unify_ty_app env ty1 ty1args ty2 ty2args + | Just (ty1', ty1a) <- repSplitAppTy_maybe ty1 + , Just (ty2', ty2a) <- repSplitAppTy_maybe ty2 + = unify_ty_app env ty1' (ty1a : ty1args) ty2' (ty2a : ty2args) + + | otherwise + = do { let ki1 = typeKind ty1 + ki2 = typeKind ty2 + -- See Note [Kind coercions in Unify] + ; unify_ty env ki1 ki2 (mkNomReflCo liftedTypeKind) + ; unify_ty env ty1 ty2 (mkNomReflCo ki1) + ; unify_tys env ty1args ty2args } + +unify_tys :: UMEnv -> [Type] -> [Type] -> UM () +unify_tys env orig_xs orig_ys + = go orig_xs orig_ys + where + go [] [] = return () + go (x:xs) (y:ys) + -- See Note [Kind coercions in Unify] + = do { unify_ty env x y (mkNomReflCo $ typeKind x) + ; go xs ys } + go _ _ = surelyApart + -- Possibly different saturations of a polykinded tycon + -- See Note [Polykinded tycon applications] + +--------------------------------- +uVar :: UMEnv + -> InTyVar -- Variable to be unified + -> Type -- with this Type + -> Coercion -- :: kind tv ~N kind ty + -> UM () + +uVar env tv1 ty kco + = do { -- Apply the ambient renaming + let tv1' = umRnOccL env tv1 + + -- Check to see whether tv1 is refined by the substitution + ; subst <- getTvSubstEnv + ; case (lookupVarEnv subst tv1') of + Just ty' | um_unif env -- Unifying, so call + -> unify_ty env ty' ty kco -- back into unify + | otherwise + -> -- Matching, we don't want to just recur here. + -- this is because the range of the subst is the target + -- type, not the template type. So, just check for + -- normal type equality. + guard ((ty' `mkCastTy` kco) `eqType` ty) + Nothing -> uUnrefined env tv1' ty ty kco } -- No, continue + +uUnrefined :: UMEnv + -> OutTyVar -- variable to be unified + -> Type -- with this Type + -> Type -- (version w/ expanded synonyms) + -> Coercion -- :: kind tv ~N kind ty + -> UM () + +-- We know that tv1 isn't refined + +uUnrefined env tv1' ty2 ty2' kco + | Just ty2'' <- coreView ty2' + = uUnrefined env tv1' ty2 ty2'' kco -- Unwrap synonyms + -- This is essential, in case we have + -- type Foo a = a + -- and then unify a ~ Foo a + + | TyVarTy tv2 <- ty2' + = do { let tv2' = umRnOccR env tv2 + ; unless (tv1' == tv2' && um_unif env) $ do + -- If we are unifying a ~ a, just return immediately + -- Do not extend the substitution + -- See Note [Self-substitution when matching] + + -- Check to see whether tv2 is refined + { subst <- getTvSubstEnv + ; case lookupVarEnv subst tv2 of + { Just ty' | um_unif env -> uUnrefined env tv1' ty' ty' kco + ; _ -> + + do { -- So both are unrefined + -- Bind one or the other, depending on which is bindable + ; let b1 = tvBindFlag env tv1' + b2 = tvBindFlag env tv2' + ty1 = mkTyVarTy tv1' + ; case (b1, b2) of + (BindMe, _) -> bindTv env tv1' (ty2 `mkCastTy` mkSymCo kco) + (_, BindMe) | um_unif env + -> bindTv (umSwapRn env) tv2 (ty1 `mkCastTy` kco) + + _ | tv1' == tv2' -> return () + -- How could this happen? If we're only matching and if + -- we're comparing forall-bound variables. + + _ -> maybeApart -- See Note [Unification with skolems] + }}}} + +uUnrefined env tv1' ty2 _ kco -- ty2 is not a type variable + = case tvBindFlag env tv1' of + Skolem -> maybeApart -- See Note [Unification with skolems] + BindMe -> bindTv env tv1' (ty2 `mkCastTy` mkSymCo kco) + +bindTv :: UMEnv -> OutTyVar -> Type -> UM () +-- OK, so we want to extend the substitution with tv := ty +-- But first, we must do a couple of checks +bindTv env tv1 ty2 + = do { let free_tvs2 = tyCoVarsOfType ty2 + + -- Make sure tys mentions no local variables + -- E.g. (forall a. b) ~ (forall a. [a]) + -- We should not unify b := [a]! + ; checkRnEnv env free_tvs2 + + -- Occurs check, see Note [Fine-grained unification] + -- Make sure you include 'kco' (which ty2 does) #14846 + ; occurs <- occursCheck env tv1 free_tvs2 + + ; if occurs then maybeApart + else extendTvEnv tv1 ty2 } + +occursCheck :: UMEnv -> TyVar -> VarSet -> UM Bool +occursCheck env tv free_tvs + | um_unif env + = do { tsubst <- getTvSubstEnv + ; return (tv `elemVarSet` niSubstTvSet tsubst free_tvs) } + + | otherwise -- Matching; no occurs check + = return False -- See Note [Self-substitution when matching] + +{- +%************************************************************************ +%* * + Binding decisions +* * +************************************************************************ +-} + +data BindFlag + = BindMe -- A regular type variable + + | Skolem -- This type variable is a skolem constant + -- Don't bind it; it only matches itself + deriving Eq + +{- +************************************************************************ +* * + Unification monad +* * +************************************************************************ +-} + +data UMEnv + = UMEnv { um_unif :: AmIUnifying + + , um_inj_tf :: Bool + -- Checking for injectivity? + -- See (end of) Note [Specification of unification] + + , um_rn_env :: RnEnv2 + -- Renaming InTyVars to OutTyVars; this eliminates + -- shadowing, and lines up matching foralls on the left + -- and right + + , um_skols :: TyVarSet + -- OutTyVars bound by a forall in this unification; + -- Do not bind these in the substitution! + -- See the function tvBindFlag + + , um_bind_fun :: TyVar -> BindFlag + -- User-supplied BindFlag function, + -- for variables not in um_skols + } + +data UMState = UMState + { um_tv_env :: TvSubstEnv + , um_cv_env :: CvSubstEnv } + +newtype UM a = UM { unUM :: UMState -> UnifyResultM (UMState, a) } + +instance Functor UM where + fmap = liftM + +instance Applicative UM where + pure a = UM (\s -> pure (s, a)) + (<*>) = ap + +instance Monad UM where +#if !MIN_VERSION_base(4,13,0) + fail = MonadFail.fail +#endif + m >>= k = UM (\state -> + do { (state', v) <- unUM m state + ; unUM (k v) state' }) + +-- need this instance because of a use of 'guard' above +instance Alternative UM where + empty = UM (\_ -> Control.Applicative.empty) + m1 <|> m2 = UM (\state -> + unUM m1 state <|> + unUM m2 state) + +instance MonadPlus UM + +instance MonadFail.MonadFail UM where + fail _ = UM (\_ -> SurelyApart) -- failed pattern match + +initUM :: TvSubstEnv -- subst to extend + -> CvSubstEnv + -> UM a -> UnifyResultM a +initUM subst_env cv_subst_env um + = case unUM um state of + Unifiable (_, subst) -> Unifiable subst + MaybeApart (_, subst) -> MaybeApart subst + SurelyApart -> SurelyApart + where + state = UMState { um_tv_env = subst_env + , um_cv_env = cv_subst_env } + +tvBindFlag :: UMEnv -> OutTyVar -> BindFlag +tvBindFlag env tv + | tv `elemVarSet` um_skols env = Skolem + | otherwise = um_bind_fun env tv + +getTvSubstEnv :: UM TvSubstEnv +getTvSubstEnv = UM $ \state -> Unifiable (state, um_tv_env state) + +getCvSubstEnv :: UM CvSubstEnv +getCvSubstEnv = UM $ \state -> Unifiable (state, um_cv_env state) + +getSubst :: UMEnv -> UM TCvSubst +getSubst env = do { tv_env <- getTvSubstEnv + ; cv_env <- getCvSubstEnv + ; let in_scope = rnInScopeSet (um_rn_env env) + ; return (mkTCvSubst in_scope (tv_env, cv_env)) } + +extendTvEnv :: TyVar -> Type -> UM () +extendTvEnv tv ty = UM $ \state -> + Unifiable (state { um_tv_env = extendVarEnv (um_tv_env state) tv ty }, ()) + +extendCvEnv :: CoVar -> Coercion -> UM () +extendCvEnv cv co = UM $ \state -> + Unifiable (state { um_cv_env = extendVarEnv (um_cv_env state) cv co }, ()) + +umRnBndr2 :: UMEnv -> TyCoVar -> TyCoVar -> UMEnv +umRnBndr2 env v1 v2 + = env { um_rn_env = rn_env', um_skols = um_skols env `extendVarSet` v' } + where + (rn_env', v') = rnBndr2_var (um_rn_env env) v1 v2 + +checkRnEnv :: UMEnv -> VarSet -> UM () +checkRnEnv env varset + | isEmptyVarSet skol_vars = return () + | varset `disjointVarSet` skol_vars = return () + | otherwise = maybeApart + -- ToDo: why MaybeApart? + -- I think SurelyApart would be right + where + skol_vars = um_skols env + -- NB: That isEmptyVarSet guard is a critical optimization; + -- it means we don't have to calculate the free vars of + -- the type, often saving quite a bit of allocation. + +-- | Converts any SurelyApart to a MaybeApart +don'tBeSoSure :: UM () -> UM () +don'tBeSoSure um = UM $ \ state -> + case unUM um state of + SurelyApart -> MaybeApart (state, ()) + other -> other + +umRnOccL :: UMEnv -> TyVar -> TyVar +umRnOccL env v = rnOccL (um_rn_env env) v + +umRnOccR :: UMEnv -> TyVar -> TyVar +umRnOccR env v = rnOccR (um_rn_env env) v + +umSwapRn :: UMEnv -> UMEnv +umSwapRn env = env { um_rn_env = rnSwap (um_rn_env env) } + +maybeApart :: UM () +maybeApart = UM (\state -> MaybeApart (state, ())) + +surelyApart :: UM a +surelyApart = UM (\_ -> SurelyApart) + +{- +%************************************************************************ +%* * + Matching a (lifted) type against a coercion +%* * +%************************************************************************ + +This section defines essentially an inverse to liftCoSubst. It is defined +here to avoid a dependency from Coercion on this module. + +-} + +data MatchEnv = ME { me_tmpls :: TyVarSet + , me_env :: RnEnv2 } + +-- | 'liftCoMatch' is sort of inverse to 'liftCoSubst'. In particular, if +-- @liftCoMatch vars ty co == Just s@, then @liftCoSubst s ty == co@, +-- where @==@ there means that the result of 'liftCoSubst' has the same +-- type as the original co; but may be different under the hood. +-- That is, it matches a type against a coercion of the same +-- "shape", and returns a lifting substitution which could have been +-- used to produce the given coercion from the given type. +-- Note that this function is incomplete -- it might return Nothing +-- when there does indeed exist a possible lifting context. +-- +-- This function is incomplete in that it doesn't respect the equality +-- in `eqType`. That is, it's possible that this will succeed for t1 and +-- fail for t2, even when t1 `eqType` t2. That's because it depends on +-- there being a very similar structure between the type and the coercion. +-- This incompleteness shouldn't be all that surprising, especially because +-- it depends on the structure of the coercion, which is a silly thing to do. +-- +-- The lifting context produced doesn't have to be exacting in the roles +-- of the mappings. This is because any use of the lifting context will +-- also require a desired role. Thus, this algorithm prefers mapping to +-- nominal coercions where it can do so. +liftCoMatch :: TyCoVarSet -> Type -> Coercion -> Maybe LiftingContext +liftCoMatch tmpls ty co + = do { cenv1 <- ty_co_match menv emptyVarEnv ki ki_co ki_ki_co ki_ki_co + ; cenv2 <- ty_co_match menv cenv1 ty co + (mkNomReflCo co_lkind) (mkNomReflCo co_rkind) + ; return (LC (mkEmptyTCvSubst in_scope) cenv2) } + where + menv = ME { me_tmpls = tmpls, me_env = mkRnEnv2 in_scope } + in_scope = mkInScopeSet (tmpls `unionVarSet` tyCoVarsOfCo co) + -- Like tcMatchTy, assume all the interesting variables + -- in ty are in tmpls + + ki = typeKind ty + ki_co = promoteCoercion co + ki_ki_co = mkNomReflCo liftedTypeKind + + Pair co_lkind co_rkind = coercionKind ki_co + +-- | 'ty_co_match' does all the actual work for 'liftCoMatch'. +ty_co_match :: MatchEnv -- ^ ambient helpful info + -> LiftCoEnv -- ^ incoming subst + -> Type -- ^ ty, type to match + -> Coercion -- ^ co, coercion to match against + -> Coercion -- ^ :: kind of L type of substed ty ~N L kind of co + -> Coercion -- ^ :: kind of R type of substed ty ~N R kind of co + -> Maybe LiftCoEnv +ty_co_match menv subst ty co lkco rkco + | Just ty' <- coreView ty = ty_co_match menv subst ty' co lkco rkco + + -- handle Refl case: + | tyCoVarsOfType ty `isNotInDomainOf` subst + , Just (ty', _) <- isReflCo_maybe co + , ty `eqType` ty' + = Just subst + + where + isNotInDomainOf :: VarSet -> VarEnv a -> Bool + isNotInDomainOf set env + = noneSet (\v -> elemVarEnv v env) set + + noneSet :: (Var -> Bool) -> VarSet -> Bool + noneSet f = allVarSet (not . f) + +ty_co_match menv subst ty co lkco rkco + | CastTy ty' co' <- ty + -- See Note [Matching in the presence of casts] + = let empty_subst = mkEmptyTCvSubst (rnInScopeSet (me_env menv)) + substed_co_l = substCo (liftEnvSubstLeft empty_subst subst) co' + substed_co_r = substCo (liftEnvSubstRight empty_subst subst) co' + in + ty_co_match menv subst ty' co (substed_co_l `mkTransCo` lkco) + (substed_co_r `mkTransCo` rkco) + + | SymCo co' <- co + = swapLiftCoEnv <$> ty_co_match menv (swapLiftCoEnv subst) ty co' rkco lkco + + -- Match a type variable against a non-refl coercion +ty_co_match menv subst (TyVarTy tv1) co lkco rkco + | Just co1' <- lookupVarEnv subst tv1' -- tv1' is already bound to co1 + = if eqCoercionX (nukeRnEnvL rn_env) co1' co + then Just subst + else Nothing -- no match since tv1 matches two different coercions + + | tv1' `elemVarSet` me_tmpls menv -- tv1' is a template var + = if any (inRnEnvR rn_env) (tyCoVarsOfCoList co) + then Nothing -- occurs check failed + else Just $ extendVarEnv subst tv1' $ + castCoercionKindI co (mkSymCo lkco) (mkSymCo rkco) + + | otherwise + = Nothing + + where + rn_env = me_env menv + tv1' = rnOccL rn_env tv1 + + -- just look through SubCo's. We don't really care about roles here. +ty_co_match menv subst ty (SubCo co) lkco rkco + = ty_co_match menv subst ty co lkco rkco + +ty_co_match menv subst (AppTy ty1a ty1b) co _lkco _rkco + | Just (co2, arg2) <- splitAppCo_maybe co -- c.f. Unify.match on AppTy + = ty_co_match_app menv subst ty1a [ty1b] co2 [arg2] +ty_co_match menv subst ty1 (AppCo co2 arg2) _lkco _rkco + | Just (ty1a, ty1b) <- repSplitAppTy_maybe ty1 + -- yes, the one from Type, not TcType; this is for coercion optimization + = ty_co_match_app menv subst ty1a [ty1b] co2 [arg2] + +ty_co_match menv subst (TyConApp tc1 tys) (TyConAppCo _ tc2 cos) _lkco _rkco + = ty_co_match_tc menv subst tc1 tys tc2 cos +ty_co_match menv subst (FunTy _ ty1 ty2) co _lkco _rkco + -- Despite the fact that (->) is polymorphic in four type variables (two + -- runtime rep and two types), we shouldn't need to explicitly unify the + -- runtime reps here; unifying the types themselves should be sufficient. + -- See Note [Representation of function types]. + | Just (tc, [_,_,co1,co2]) <- splitTyConAppCo_maybe co + , tc == funTyCon + = let Pair lkcos rkcos = traverse (fmap mkNomReflCo . coercionKind) [co1,co2] + in ty_co_match_args menv subst [ty1, ty2] [co1, co2] lkcos rkcos + +ty_co_match menv subst (ForAllTy (Bndr tv1 _) ty1) + (ForAllCo tv2 kind_co2 co2) + lkco rkco + | isTyVar tv1 && isTyVar tv2 + = do { subst1 <- ty_co_match menv subst (tyVarKind tv1) kind_co2 + ki_ki_co ki_ki_co + ; let rn_env0 = me_env menv + rn_env1 = rnBndr2 rn_env0 tv1 tv2 + menv' = menv { me_env = rn_env1 } + ; ty_co_match menv' subst1 ty1 co2 lkco rkco } + where + ki_ki_co = mkNomReflCo liftedTypeKind + +-- ty_co_match menv subst (ForAllTy (Bndr cv1 _) ty1) +-- (ForAllCo cv2 kind_co2 co2) +-- lkco rkco +-- | isCoVar cv1 && isCoVar cv2 +-- We seems not to have enough information for this case +-- 1. Given: +-- cv1 :: (s1 :: k1) ~r (s2 :: k2) +-- kind_co2 :: (s1' ~ s2') ~N (t1 ~ t2) +-- eta1 = mkNthCo role 2 (downgradeRole r Nominal kind_co2) +-- :: s1' ~ t1 +-- eta2 = mkNthCo role 3 (downgradeRole r Nominal kind_co2) +-- :: s2' ~ t2 +-- Wanted: +-- subst1 <- ty_co_match menv subst s1 eta1 kco1 kco2 +-- subst2 <- ty_co_match menv subst1 s2 eta2 kco3 kco4 +-- Question: How do we get kcoi? +-- 2. Given: +-- lkco :: <*> -- See Note [Weird typing rule for ForAllTy] in Type +-- rkco :: <*> +-- Wanted: +-- ty_co_match menv' subst2 ty1 co2 lkco' rkco' +-- Question: How do we get lkco' and rkco'? + +ty_co_match _ subst (CoercionTy {}) _ _ _ + = Just subst -- don't inspect coercions + +ty_co_match menv subst ty (GRefl r t (MCo co)) lkco rkco + = ty_co_match menv subst ty (GRefl r t MRefl) lkco (rkco `mkTransCo` mkSymCo co) + +ty_co_match menv subst ty co1 lkco rkco + | Just (CastTy t co, r) <- isReflCo_maybe co1 + -- In @pushRefl@, pushing reflexive coercion inside CastTy will give us + -- t |> co ~ t ; ; t ~ t |> co + -- But transitive coercions are not helpful. Therefore we deal + -- with it here: we do recursion on the smaller reflexive coercion, + -- while propagating the correct kind coercions. + = let kco' = mkSymCo co + in ty_co_match menv subst ty (mkReflCo r t) (lkco `mkTransCo` kco') + (rkco `mkTransCo` kco') + + +ty_co_match menv subst ty co lkco rkco + | Just co' <- pushRefl co = ty_co_match menv subst ty co' lkco rkco + | otherwise = Nothing + +ty_co_match_tc :: MatchEnv -> LiftCoEnv + -> TyCon -> [Type] + -> TyCon -> [Coercion] + -> Maybe LiftCoEnv +ty_co_match_tc menv subst tc1 tys1 tc2 cos2 + = do { guard (tc1 == tc2) + ; ty_co_match_args menv subst tys1 cos2 lkcos rkcos } + where + Pair lkcos rkcos + = traverse (fmap mkNomReflCo . coercionKind) cos2 + +ty_co_match_app :: MatchEnv -> LiftCoEnv + -> Type -> [Type] -> Coercion -> [Coercion] + -> Maybe LiftCoEnv +ty_co_match_app menv subst ty1 ty1args co2 co2args + | Just (ty1', ty1a) <- repSplitAppTy_maybe ty1 + , Just (co2', co2a) <- splitAppCo_maybe co2 + = ty_co_match_app menv subst ty1' (ty1a : ty1args) co2' (co2a : co2args) + + | otherwise + = do { subst1 <- ty_co_match menv subst ki1 ki2 ki_ki_co ki_ki_co + ; let Pair lkco rkco = mkNomReflCo <$> coercionKind ki2 + ; subst2 <- ty_co_match menv subst1 ty1 co2 lkco rkco + ; let Pair lkcos rkcos = traverse (fmap mkNomReflCo . coercionKind) co2args + ; ty_co_match_args menv subst2 ty1args co2args lkcos rkcos } + where + ki1 = typeKind ty1 + ki2 = promoteCoercion co2 + ki_ki_co = mkNomReflCo liftedTypeKind + +ty_co_match_args :: MatchEnv -> LiftCoEnv -> [Type] + -> [Coercion] -> [Coercion] -> [Coercion] + -> Maybe LiftCoEnv +ty_co_match_args _ subst [] [] _ _ = Just subst +ty_co_match_args menv subst (ty:tys) (arg:args) (lkco:lkcos) (rkco:rkcos) + = do { subst' <- ty_co_match menv subst ty arg lkco rkco + ; ty_co_match_args menv subst' tys args lkcos rkcos } +ty_co_match_args _ _ _ _ _ _ = Nothing + +pushRefl :: Coercion -> Maybe Coercion +pushRefl co = + case (isReflCo_maybe co) of + Just (AppTy ty1 ty2, Nominal) + -> Just (AppCo (mkReflCo Nominal ty1) (mkNomReflCo ty2)) + Just (FunTy _ ty1 ty2, r) + | Just rep1 <- getRuntimeRep_maybe ty1 + , Just rep2 <- getRuntimeRep_maybe ty2 + -> Just (TyConAppCo r funTyCon [ mkReflCo r rep1, mkReflCo r rep2 + , mkReflCo r ty1, mkReflCo r ty2 ]) + Just (TyConApp tc tys, r) + -> Just (TyConAppCo r tc (zipWith mkReflCo (tyConRolesX r tc) tys)) + Just (ForAllTy (Bndr tv _) ty, r) + -> Just (ForAllCo tv (mkNomReflCo (varType tv)) (mkReflCo r ty)) + -- NB: NoRefl variant. Otherwise, we get a loop! + _ -> Nothing diff --git a/compiler/utils/Bag.hs b/compiler/utils/Bag.hs new file mode 100644 --- /dev/null +++ b/compiler/utils/Bag.hs @@ -0,0 +1,351 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + + +Bag: an unordered collection with duplicates +-} + +{-# LANGUAGE ScopedTypeVariables, CPP #-} + +module Bag ( + Bag, -- abstract type + + emptyBag, unitBag, unionBags, unionManyBags, + mapBag, + elemBag, lengthBag, + filterBag, partitionBag, partitionBagWith, + concatBag, catBagMaybes, foldBag, foldrBag, foldlBag, + isEmptyBag, isSingletonBag, consBag, snocBag, anyBag, allBag, + listToBag, bagToList, mapAccumBagL, + concatMapBag, concatMapBagPair, mapMaybeBag, + foldrBagM, foldlBagM, mapBagM, mapBagM_, + flatMapBagM, flatMapBagPairM, + mapAndUnzipBagM, mapAccumBagLM, + anyBagM, filterBagM + ) where + +import GhcPrelude + +import Outputable +import Util + +import MonadUtils +import Control.Monad +import Data.Data +import Data.Maybe( mapMaybe ) +import Data.List ( partition, mapAccumL ) +import qualified Data.Foldable as Foldable + +infixr 3 `consBag` +infixl 3 `snocBag` + +data Bag a + = EmptyBag + | UnitBag a + | TwoBags (Bag a) (Bag a) -- INVARIANT: neither branch is empty + | ListBag [a] -- INVARIANT: the list is non-empty + +emptyBag :: Bag a +emptyBag = EmptyBag + +unitBag :: a -> Bag a +unitBag = UnitBag + +lengthBag :: Bag a -> Int +lengthBag EmptyBag = 0 +lengthBag (UnitBag {}) = 1 +lengthBag (TwoBags b1 b2) = lengthBag b1 + lengthBag b2 +lengthBag (ListBag xs) = length xs + +elemBag :: Eq a => a -> Bag a -> Bool +elemBag _ EmptyBag = False +elemBag x (UnitBag y) = x == y +elemBag x (TwoBags b1 b2) = x `elemBag` b1 || x `elemBag` b2 +elemBag x (ListBag ys) = any (x ==) ys + +unionManyBags :: [Bag a] -> Bag a +unionManyBags xs = foldr unionBags EmptyBag xs + +-- This one is a bit stricter! The bag will get completely evaluated. + +unionBags :: Bag a -> Bag a -> Bag a +unionBags EmptyBag b = b +unionBags b EmptyBag = b +unionBags b1 b2 = TwoBags b1 b2 + +consBag :: a -> Bag a -> Bag a +snocBag :: Bag a -> a -> Bag a + +consBag elt bag = (unitBag elt) `unionBags` bag +snocBag bag elt = bag `unionBags` (unitBag elt) + +isEmptyBag :: Bag a -> Bool +isEmptyBag EmptyBag = True +isEmptyBag _ = False -- NB invariants + +isSingletonBag :: Bag a -> Bool +isSingletonBag EmptyBag = False +isSingletonBag (UnitBag _) = True +isSingletonBag (TwoBags _ _) = False -- Neither is empty +isSingletonBag (ListBag xs) = isSingleton xs + +filterBag :: (a -> Bool) -> Bag a -> Bag a +filterBag _ EmptyBag = EmptyBag +filterBag pred b@(UnitBag val) = if pred val then b else EmptyBag +filterBag pred (TwoBags b1 b2) = sat1 `unionBags` sat2 + where sat1 = filterBag pred b1 + sat2 = filterBag pred b2 +filterBag pred (ListBag vs) = listToBag (filter pred vs) + +filterBagM :: Monad m => (a -> m Bool) -> Bag a -> m (Bag a) +filterBagM _ EmptyBag = return EmptyBag +filterBagM pred b@(UnitBag val) = do + flag <- pred val + if flag then return b + else return EmptyBag +filterBagM pred (TwoBags b1 b2) = do + sat1 <- filterBagM pred b1 + sat2 <- filterBagM pred b2 + return (sat1 `unionBags` sat2) +filterBagM pred (ListBag vs) = do + sat <- filterM pred vs + return (listToBag sat) + +allBag :: (a -> Bool) -> Bag a -> Bool +allBag _ EmptyBag = True +allBag p (UnitBag v) = p v +allBag p (TwoBags b1 b2) = allBag p b1 && allBag p b2 +allBag p (ListBag xs) = all p xs + +anyBag :: (a -> Bool) -> Bag a -> Bool +anyBag _ EmptyBag = False +anyBag p (UnitBag v) = p v +anyBag p (TwoBags b1 b2) = anyBag p b1 || anyBag p b2 +anyBag p (ListBag xs) = any p xs + +anyBagM :: Monad m => (a -> m Bool) -> Bag a -> m Bool +anyBagM _ EmptyBag = return False +anyBagM p (UnitBag v) = p v +anyBagM p (TwoBags b1 b2) = do flag <- anyBagM p b1 + if flag then return True + else anyBagM p b2 +anyBagM p (ListBag xs) = anyM p xs + +concatBag :: Bag (Bag a) -> Bag a +concatBag bss = foldrBag add emptyBag bss + where + add bs rs = bs `unionBags` rs + +catBagMaybes :: Bag (Maybe a) -> Bag a +catBagMaybes bs = foldrBag add emptyBag bs + where + add Nothing rs = rs + add (Just x) rs = x `consBag` rs + +partitionBag :: (a -> Bool) -> Bag a -> (Bag a {- Satisfy predictate -}, + Bag a {- Don't -}) +partitionBag _ EmptyBag = (EmptyBag, EmptyBag) +partitionBag pred b@(UnitBag val) + = if pred val then (b, EmptyBag) else (EmptyBag, b) +partitionBag pred (TwoBags b1 b2) + = (sat1 `unionBags` sat2, fail1 `unionBags` fail2) + where (sat1, fail1) = partitionBag pred b1 + (sat2, fail2) = partitionBag pred b2 +partitionBag pred (ListBag vs) = (listToBag sats, listToBag fails) + where (sats, fails) = partition pred vs + + +partitionBagWith :: (a -> Either b c) -> Bag a + -> (Bag b {- Left -}, + Bag c {- Right -}) +partitionBagWith _ EmptyBag = (EmptyBag, EmptyBag) +partitionBagWith pred (UnitBag val) + = case pred val of + Left a -> (UnitBag a, EmptyBag) + Right b -> (EmptyBag, UnitBag b) +partitionBagWith pred (TwoBags b1 b2) + = (sat1 `unionBags` sat2, fail1 `unionBags` fail2) + where (sat1, fail1) = partitionBagWith pred b1 + (sat2, fail2) = partitionBagWith pred b2 +partitionBagWith pred (ListBag vs) = (listToBag sats, listToBag fails) + where (sats, fails) = partitionWith pred vs + +foldBag :: (r -> r -> r) -- Replace TwoBags with this; should be associative + -> (a -> r) -- Replace UnitBag with this + -> r -- Replace EmptyBag with this + -> Bag a + -> r + +{- Standard definition +foldBag t u e EmptyBag = e +foldBag t u e (UnitBag x) = u x +foldBag t u e (TwoBags b1 b2) = (foldBag t u e b1) `t` (foldBag t u e b2) +foldBag t u e (ListBag xs) = foldr (t.u) e xs +-} + +-- More tail-recursive definition, exploiting associativity of "t" +foldBag _ _ e EmptyBag = e +foldBag t u e (UnitBag x) = u x `t` e +foldBag t u e (TwoBags b1 b2) = foldBag t u (foldBag t u e b2) b1 +foldBag t u e (ListBag xs) = foldr (t.u) e xs + +foldrBag :: (a -> r -> r) -> r + -> Bag a + -> r + +foldrBag _ z EmptyBag = z +foldrBag k z (UnitBag x) = k x z +foldrBag k z (TwoBags b1 b2) = foldrBag k (foldrBag k z b2) b1 +foldrBag k z (ListBag xs) = foldr k z xs + +foldlBag :: (r -> a -> r) -> r + -> Bag a + -> r + +foldlBag _ z EmptyBag = z +foldlBag k z (UnitBag x) = k z x +foldlBag k z (TwoBags b1 b2) = foldlBag k (foldlBag k z b1) b2 +foldlBag k z (ListBag xs) = foldl k z xs + +foldrBagM :: (Monad m) => (a -> b -> m b) -> b -> Bag a -> m b +foldrBagM _ z EmptyBag = return z +foldrBagM k z (UnitBag x) = k x z +foldrBagM k z (TwoBags b1 b2) = do { z' <- foldrBagM k z b2; foldrBagM k z' b1 } +foldrBagM k z (ListBag xs) = foldrM k z xs + +foldlBagM :: (Monad m) => (b -> a -> m b) -> b -> Bag a -> m b +foldlBagM _ z EmptyBag = return z +foldlBagM k z (UnitBag x) = k z x +foldlBagM k z (TwoBags b1 b2) = do { z' <- foldlBagM k z b1; foldlBagM k z' b2 } +foldlBagM k z (ListBag xs) = foldlM k z xs + +mapBag :: (a -> b) -> Bag a -> Bag b +mapBag _ EmptyBag = EmptyBag +mapBag f (UnitBag x) = UnitBag (f x) +mapBag f (TwoBags b1 b2) = TwoBags (mapBag f b1) (mapBag f b2) +mapBag f (ListBag xs) = ListBag (map f xs) + +concatMapBag :: (a -> Bag b) -> Bag a -> Bag b +concatMapBag _ EmptyBag = EmptyBag +concatMapBag f (UnitBag x) = f x +concatMapBag f (TwoBags b1 b2) = unionBags (concatMapBag f b1) (concatMapBag f b2) +concatMapBag f (ListBag xs) = foldr (unionBags . f) emptyBag xs + +concatMapBagPair :: (a -> (Bag b, Bag c)) -> Bag a -> (Bag b, Bag c) +concatMapBagPair _ EmptyBag = (EmptyBag, EmptyBag) +concatMapBagPair f (UnitBag x) = f x +concatMapBagPair f (TwoBags b1 b2) = (unionBags r1 r2, unionBags s1 s2) + where + (r1, s1) = concatMapBagPair f b1 + (r2, s2) = concatMapBagPair f b2 +concatMapBagPair f (ListBag xs) = foldr go (emptyBag, emptyBag) xs + where + go a (s1, s2) = (unionBags r1 s1, unionBags r2 s2) + where + (r1, r2) = f a + +mapMaybeBag :: (a -> Maybe b) -> Bag a -> Bag b +mapMaybeBag _ EmptyBag = EmptyBag +mapMaybeBag f (UnitBag x) = case f x of + Nothing -> EmptyBag + Just y -> UnitBag y +mapMaybeBag f (TwoBags b1 b2) = unionBags (mapMaybeBag f b1) (mapMaybeBag f b2) +mapMaybeBag f (ListBag xs) = ListBag (mapMaybe f xs) + +mapBagM :: Monad m => (a -> m b) -> Bag a -> m (Bag b) +mapBagM _ EmptyBag = return EmptyBag +mapBagM f (UnitBag x) = do r <- f x + return (UnitBag r) +mapBagM f (TwoBags b1 b2) = do r1 <- mapBagM f b1 + r2 <- mapBagM f b2 + return (TwoBags r1 r2) +mapBagM f (ListBag xs) = do rs <- mapM f xs + return (ListBag rs) + +mapBagM_ :: Monad m => (a -> m b) -> Bag a -> m () +mapBagM_ _ EmptyBag = return () +mapBagM_ f (UnitBag x) = f x >> return () +mapBagM_ f (TwoBags b1 b2) = mapBagM_ f b1 >> mapBagM_ f b2 +mapBagM_ f (ListBag xs) = mapM_ f xs + +flatMapBagM :: Monad m => (a -> m (Bag b)) -> Bag a -> m (Bag b) +flatMapBagM _ EmptyBag = return EmptyBag +flatMapBagM f (UnitBag x) = f x +flatMapBagM f (TwoBags b1 b2) = do r1 <- flatMapBagM f b1 + r2 <- flatMapBagM f b2 + return (r1 `unionBags` r2) +flatMapBagM f (ListBag xs) = foldrM k EmptyBag xs + where + k x b2 = do { b1 <- f x; return (b1 `unionBags` b2) } + +flatMapBagPairM :: Monad m => (a -> m (Bag b, Bag c)) -> Bag a -> m (Bag b, Bag c) +flatMapBagPairM _ EmptyBag = return (EmptyBag, EmptyBag) +flatMapBagPairM f (UnitBag x) = f x +flatMapBagPairM f (TwoBags b1 b2) = do (r1,s1) <- flatMapBagPairM f b1 + (r2,s2) <- flatMapBagPairM f b2 + return (r1 `unionBags` r2, s1 `unionBags` s2) +flatMapBagPairM f (ListBag xs) = foldrM k (EmptyBag, EmptyBag) xs + where + k x (r2,s2) = do { (r1,s1) <- f x + ; return (r1 `unionBags` r2, s1 `unionBags` s2) } + +mapAndUnzipBagM :: Monad m => (a -> m (b,c)) -> Bag a -> m (Bag b, Bag c) +mapAndUnzipBagM _ EmptyBag = return (EmptyBag, EmptyBag) +mapAndUnzipBagM f (UnitBag x) = do (r,s) <- f x + return (UnitBag r, UnitBag s) +mapAndUnzipBagM f (TwoBags b1 b2) = do (r1,s1) <- mapAndUnzipBagM f b1 + (r2,s2) <- mapAndUnzipBagM f b2 + return (TwoBags r1 r2, TwoBags s1 s2) +mapAndUnzipBagM f (ListBag xs) = do ts <- mapM f xs + let (rs,ss) = unzip ts + return (ListBag rs, ListBag ss) + +mapAccumBagL ::(acc -> x -> (acc, y)) -- ^ combining function + -> acc -- ^ initial state + -> Bag x -- ^ inputs + -> (acc, Bag y) -- ^ final state, outputs +mapAccumBagL _ s EmptyBag = (s, EmptyBag) +mapAccumBagL f s (UnitBag x) = let (s1, x1) = f s x in (s1, UnitBag x1) +mapAccumBagL f s (TwoBags b1 b2) = let (s1, b1') = mapAccumBagL f s b1 + (s2, b2') = mapAccumBagL f s1 b2 + in (s2, TwoBags b1' b2') +mapAccumBagL f s (ListBag xs) = let (s', xs') = mapAccumL f s xs + in (s', ListBag xs') + +mapAccumBagLM :: Monad m + => (acc -> x -> m (acc, y)) -- ^ combining function + -> acc -- ^ initial state + -> Bag x -- ^ inputs + -> m (acc, Bag y) -- ^ final state, outputs +mapAccumBagLM _ s EmptyBag = return (s, EmptyBag) +mapAccumBagLM f s (UnitBag x) = do { (s1, x1) <- f s x; return (s1, UnitBag x1) } +mapAccumBagLM f s (TwoBags b1 b2) = do { (s1, b1') <- mapAccumBagLM f s b1 + ; (s2, b2') <- mapAccumBagLM f s1 b2 + ; return (s2, TwoBags b1' b2') } +mapAccumBagLM f s (ListBag xs) = do { (s', xs') <- mapAccumLM f s xs + ; return (s', ListBag xs') } + +listToBag :: [a] -> Bag a +listToBag [] = EmptyBag +listToBag [x] = UnitBag x +listToBag vs = ListBag vs + +bagToList :: Bag a -> [a] +bagToList b = foldrBag (:) [] b + +instance (Outputable a) => Outputable (Bag a) where + ppr bag = braces (pprWithCommas ppr (bagToList bag)) + +instance Data a => Data (Bag a) where + gfoldl k z b = z listToBag `k` bagToList b -- traverse abstract type abstractly + toConstr _ = abstractConstr $ "Bag("++show (typeOf (undefined::a))++")" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "Bag" + dataCast1 x = gcast1 x + +instance Functor Bag where + fmap = mapBag + +instance Foldable.Foldable Bag where + foldr = foldrBag diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs new file mode 100644 --- /dev/null +++ b/compiler/utils/Binary.hs @@ -0,0 +1,1215 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiWayIf #-} + +{-# OPTIONS_GHC -O2 -funbox-strict-fields #-} +-- We always optimise this, otherwise performance of a non-optimised +-- compiler is severely affected + +-- +-- (c) The University of Glasgow 2002-2006 +-- +-- Binary I/O library, with special tweaks for GHC +-- +-- Based on the nhc98 Binary library, which is copyright +-- (c) Malcolm Wallace and Colin Runciman, University of York, 1998. +-- Under the terms of the license for that software, we must tell you +-- where you can obtain the original version of the Binary library, namely +-- http://www.cs.york.ac.uk/fp/nhc98/ + +module Binary + ( {-type-} Bin, + {-class-} Binary(..), + {-type-} BinHandle, + SymbolTable, Dictionary, + + openBinMem, +-- closeBin, + + seekBin, + seekBy, + tellBin, + castBin, + isEOFBin, + withBinBuffer, + + writeBinMem, + readBinMem, + + putAt, getAt, + + -- * For writing instances + putByte, + getByte, + + -- * Lazy Binary I/O + lazyGet, + lazyPut, + + -- * User data + UserData(..), getUserData, setUserData, + newReadState, newWriteState, + putDictionary, getDictionary, putFS, + ) where + +#include "HsVersions.h" + +-- The *host* architecture version: +#include "../includes/MachDeps.h" + +import GhcPrelude + +import {-# SOURCE #-} Name (Name) +import FastString +import Panic +import UniqFM +import FastMutInt +import Fingerprint +import BasicTypes +import SrcLoc + +import Foreign +import Data.Array +import Data.ByteString (ByteString) +import qualified Data.ByteString.Internal as BS +import qualified Data.ByteString.Unsafe as BS +import Data.IORef +import Data.Char ( ord, chr ) +import Data.Time +import Type.Reflection +import Type.Reflection.Unsafe +import Data.Kind (Type) +import GHC.Exts (TYPE, RuntimeRep(..), VecCount(..), VecElem(..)) +import Control.Monad ( when ) +import System.IO as IO +import System.IO.Unsafe ( unsafeInterleaveIO ) +import System.IO.Error ( mkIOError, eofErrorType ) +import GHC.Real ( Ratio(..) ) +import GHC.Serialized + +type BinArray = ForeignPtr Word8 + +--------------------------------------------------------------- +-- BinHandle +--------------------------------------------------------------- + +data BinHandle + = BinMem { -- binary data stored in an unboxed array + bh_usr :: UserData, -- sigh, need parameterized modules :-) + _off_r :: !FastMutInt, -- the current offset + _sz_r :: !FastMutInt, -- size of the array (cached) + _arr_r :: !(IORef BinArray) -- the array (bounds: (0,size-1)) + } + -- XXX: should really store a "high water mark" for dumping out + -- the binary data to a file. + +getUserData :: BinHandle -> UserData +getUserData bh = bh_usr bh + +setUserData :: BinHandle -> UserData -> BinHandle +setUserData bh us = bh { bh_usr = us } + +-- | Get access to the underlying buffer. +-- +-- It is quite important that no references to the 'ByteString' leak out of the +-- continuation lest terrible things happen. +withBinBuffer :: BinHandle -> (ByteString -> IO a) -> IO a +withBinBuffer (BinMem _ ix_r _ arr_r) action = do + arr <- readIORef arr_r + ix <- readFastMutInt ix_r + withForeignPtr arr $ \ptr -> + BS.unsafePackCStringLen (castPtr ptr, ix) >>= action + + +--------------------------------------------------------------- +-- Bin +--------------------------------------------------------------- + +newtype Bin a = BinPtr Int + deriving (Eq, Ord, Show, Bounded) + +castBin :: Bin a -> Bin b +castBin (BinPtr i) = BinPtr i + +--------------------------------------------------------------- +-- class Binary +--------------------------------------------------------------- + +class Binary a where + put_ :: BinHandle -> a -> IO () + put :: BinHandle -> a -> IO (Bin a) + get :: BinHandle -> IO a + + -- define one of put_, put. Use of put_ is recommended because it + -- is more likely that tail-calls can kick in, and we rarely need the + -- position return value. + put_ bh a = do _ <- put bh a; return () + put bh a = do p <- tellBin bh; put_ bh a; return p + +putAt :: Binary a => BinHandle -> Bin a -> a -> IO () +putAt bh p x = do seekBin bh p; put_ bh x; return () + +getAt :: Binary a => BinHandle -> Bin a -> IO a +getAt bh p = do seekBin bh p; get bh + +openBinMem :: Int -> IO BinHandle +openBinMem size + | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0" + | otherwise = do + arr <- mallocForeignPtrBytes size + arr_r <- newIORef arr + ix_r <- newFastMutInt + writeFastMutInt ix_r 0 + sz_r <- newFastMutInt + writeFastMutInt sz_r size + return (BinMem noUserData ix_r sz_r arr_r) + +tellBin :: BinHandle -> IO (Bin a) +tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix) + +seekBin :: BinHandle -> Bin a -> IO () +seekBin h@(BinMem _ ix_r sz_r _) (BinPtr p) = do + sz <- readFastMutInt sz_r + if (p >= sz) + then do expandBin h p; writeFastMutInt ix_r p + else writeFastMutInt ix_r p + +seekBy :: BinHandle -> Int -> IO () +seekBy h@(BinMem _ ix_r sz_r _) off = do + sz <- readFastMutInt sz_r + ix <- readFastMutInt ix_r + let ix' = ix + off + if (ix' >= sz) + then do expandBin h ix'; writeFastMutInt ix_r ix' + else writeFastMutInt ix_r ix' + +isEOFBin :: BinHandle -> IO Bool +isEOFBin (BinMem _ ix_r sz_r _) = do + ix <- readFastMutInt ix_r + sz <- readFastMutInt sz_r + return (ix >= sz) + +writeBinMem :: BinHandle -> FilePath -> IO () +writeBinMem (BinMem _ ix_r _ arr_r) fn = do + h <- openBinaryFile fn WriteMode + arr <- readIORef arr_r + ix <- readFastMutInt ix_r + withForeignPtr arr $ \p -> hPutBuf h p ix + hClose h + +readBinMem :: FilePath -> IO BinHandle +-- Return a BinHandle with a totally undefined State +readBinMem filename = do + h <- openBinaryFile filename ReadMode + filesize' <- hFileSize h + let filesize = fromIntegral filesize' + arr <- mallocForeignPtrBytes filesize + count <- withForeignPtr arr $ \p -> hGetBuf h p filesize + when (count /= filesize) $ + error ("Binary.readBinMem: only read " ++ show count ++ " bytes") + hClose h + arr_r <- newIORef arr + ix_r <- newFastMutInt + writeFastMutInt ix_r 0 + sz_r <- newFastMutInt + writeFastMutInt sz_r filesize + return (BinMem noUserData ix_r sz_r arr_r) + +-- expand the size of the array to include a specified offset +expandBin :: BinHandle -> Int -> IO () +expandBin (BinMem _ _ sz_r arr_r) off = do + sz <- readFastMutInt sz_r + let sz' = head (dropWhile (<= off) (iterate (* 2) sz)) + arr <- readIORef arr_r + arr' <- mallocForeignPtrBytes sz' + withForeignPtr arr $ \old -> + withForeignPtr arr' $ \new -> + copyBytes new old sz + writeFastMutInt sz_r sz' + writeIORef arr_r arr' + +-- ----------------------------------------------------------------------------- +-- Low-level reading/writing of bytes + +putPrim :: BinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO () +putPrim h@(BinMem _ ix_r sz_r arr_r) size f = do + ix <- readFastMutInt ix_r + sz <- readFastMutInt sz_r + when (ix + size > sz) $ + expandBin h (ix + size) + arr <- readIORef arr_r + withForeignPtr arr $ \op -> f (op `plusPtr` ix) + writeFastMutInt ix_r (ix + size) + +getPrim :: BinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a +getPrim (BinMem _ ix_r sz_r arr_r) size f = do + ix <- readFastMutInt ix_r + sz <- readFastMutInt sz_r + when (ix + size > sz) $ + ioError (mkIOError eofErrorType "Data.Binary.getPrim" Nothing Nothing) + arr <- readIORef arr_r + w <- withForeignPtr arr $ \op -> f (op `plusPtr` ix) + writeFastMutInt ix_r (ix + size) + return w + +putWord8 :: BinHandle -> Word8 -> IO () +putWord8 h w = putPrim h 1 (\op -> poke op w) + +getWord8 :: BinHandle -> IO Word8 +getWord8 h = getPrim h 1 peek + +putWord16 :: BinHandle -> Word16 -> IO () +putWord16 h w = putPrim h 2 (\op -> do + pokeElemOff op 0 (fromIntegral (w `shiftR` 8)) + pokeElemOff op 1 (fromIntegral (w .&. 0xFF)) + ) + +getWord16 :: BinHandle -> IO Word16 +getWord16 h = getPrim h 2 (\op -> do + w0 <- fromIntegral <$> peekElemOff op 0 + w1 <- fromIntegral <$> peekElemOff op 1 + return $! w0 `shiftL` 8 .|. w1 + ) + +putWord32 :: BinHandle -> Word32 -> IO () +putWord32 h w = putPrim h 4 (\op -> do + pokeElemOff op 0 (fromIntegral (w `shiftR` 24)) + pokeElemOff op 1 (fromIntegral ((w `shiftR` 16) .&. 0xFF)) + pokeElemOff op 2 (fromIntegral ((w `shiftR` 8) .&. 0xFF)) + pokeElemOff op 3 (fromIntegral (w .&. 0xFF)) + ) + +getWord32 :: BinHandle -> IO Word32 +getWord32 h = getPrim h 4 (\op -> do + w0 <- fromIntegral <$> peekElemOff op 0 + w1 <- fromIntegral <$> peekElemOff op 1 + w2 <- fromIntegral <$> peekElemOff op 2 + w3 <- fromIntegral <$> peekElemOff op 3 + + return $! (w0 `shiftL` 24) .|. + (w1 `shiftL` 16) .|. + (w2 `shiftL` 8) .|. + w3 + ) + +putWord64 :: BinHandle -> Word64 -> IO () +putWord64 h w = putPrim h 8 (\op -> do + pokeElemOff op 0 (fromIntegral (w `shiftR` 56)) + pokeElemOff op 1 (fromIntegral ((w `shiftR` 48) .&. 0xFF)) + pokeElemOff op 2 (fromIntegral ((w `shiftR` 40) .&. 0xFF)) + pokeElemOff op 3 (fromIntegral ((w `shiftR` 32) .&. 0xFF)) + pokeElemOff op 4 (fromIntegral ((w `shiftR` 24) .&. 0xFF)) + pokeElemOff op 5 (fromIntegral ((w `shiftR` 16) .&. 0xFF)) + pokeElemOff op 6 (fromIntegral ((w `shiftR` 8) .&. 0xFF)) + pokeElemOff op 7 (fromIntegral (w .&. 0xFF)) + ) + +getWord64 :: BinHandle -> IO Word64 +getWord64 h = getPrim h 8 (\op -> do + w0 <- fromIntegral <$> peekElemOff op 0 + w1 <- fromIntegral <$> peekElemOff op 1 + w2 <- fromIntegral <$> peekElemOff op 2 + w3 <- fromIntegral <$> peekElemOff op 3 + w4 <- fromIntegral <$> peekElemOff op 4 + w5 <- fromIntegral <$> peekElemOff op 5 + w6 <- fromIntegral <$> peekElemOff op 6 + w7 <- fromIntegral <$> peekElemOff op 7 + + return $! (w0 `shiftL` 56) .|. + (w1 `shiftL` 48) .|. + (w2 `shiftL` 40) .|. + (w3 `shiftL` 32) .|. + (w4 `shiftL` 24) .|. + (w5 `shiftL` 16) .|. + (w6 `shiftL` 8) .|. + w7 + ) + +putByte :: BinHandle -> Word8 -> IO () +putByte bh w = putWord8 bh w + +getByte :: BinHandle -> IO Word8 +getByte h = getWord8 h + +-- ----------------------------------------------------------------------------- +-- Primitive Word writes + +instance Binary Word8 where + put_ = putWord8 + get = getWord8 + +instance Binary Word16 where + put_ h w = putWord16 h w + get h = getWord16 h + +instance Binary Word32 where + put_ h w = putWord32 h w + get h = getWord32 h + +instance Binary Word64 where + put_ h w = putWord64 h w + get h = getWord64 h + +-- ----------------------------------------------------------------------------- +-- Primitive Int writes + +instance Binary Int8 where + put_ h w = put_ h (fromIntegral w :: Word8) + get h = do w <- get h; return $! (fromIntegral (w::Word8)) + +instance Binary Int16 where + put_ h w = put_ h (fromIntegral w :: Word16) + get h = do w <- get h; return $! (fromIntegral (w::Word16)) + +instance Binary Int32 where + put_ h w = put_ h (fromIntegral w :: Word32) + get h = do w <- get h; return $! (fromIntegral (w::Word32)) + +instance Binary Int64 where + put_ h w = put_ h (fromIntegral w :: Word64) + get h = do w <- get h; return $! (fromIntegral (w::Word64)) + +-- ----------------------------------------------------------------------------- +-- Instances for standard types + +instance Binary () where + put_ _ () = return () + get _ = return () + +instance Binary Bool where + put_ bh b = putByte bh (fromIntegral (fromEnum b)) + get bh = do x <- getWord8 bh; return $! (toEnum (fromIntegral x)) + +instance Binary Char where + put_ bh c = put_ bh (fromIntegral (ord c) :: Word32) + get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word32))) + +instance Binary Int where + put_ bh i = put_ bh (fromIntegral i :: Int64) + get bh = do + x <- get bh + return $! (fromIntegral (x :: Int64)) + +instance Binary a => Binary [a] where + put_ bh l = do + let len = length l + if (len < 0xff) + then putByte bh (fromIntegral len :: Word8) + else do putByte bh 0xff; put_ bh (fromIntegral len :: Word32) + mapM_ (put_ bh) l + get bh = do + b <- getByte bh + len <- if b == 0xff + then get bh + else return (fromIntegral b :: Word32) + let loop 0 = return [] + loop n = do a <- get bh; as <- loop (n-1); return (a:as) + loop len + +instance (Ix a, Binary a, Binary b) => Binary (Array a b) where + put_ bh arr = do + put_ bh $ bounds arr + put_ bh $ elems arr + get bh = do + bounds <- get bh + xs <- get bh + return $ listArray bounds xs + +instance (Binary a, Binary b) => Binary (a,b) where + put_ bh (a,b) = do put_ bh a; put_ bh b + get bh = do a <- get bh + b <- get bh + return (a,b) + +instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where + put_ bh (a,b,c) = do put_ bh a; put_ bh b; put_ bh c + get bh = do a <- get bh + b <- get bh + c <- get bh + return (a,b,c) + +instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where + put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d + get bh = do a <- get bh + b <- get bh + c <- get bh + d <- get bh + return (a,b,c,d) + +instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d, e) where + put_ bh (a,b,c,d, e) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; + get bh = do a <- get bh + b <- get bh + c <- get bh + d <- get bh + e <- get bh + return (a,b,c,d,e) + +instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f) => Binary (a,b,c,d, e, f) where + put_ bh (a,b,c,d, e, f) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f; + get bh = do a <- get bh + b <- get bh + c <- get bh + d <- get bh + e <- get bh + f <- get bh + return (a,b,c,d,e,f) + +instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g) => Binary (a,b,c,d,e,f,g) where + put_ bh (a,b,c,d,e,f,g) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f; put_ bh g + get bh = do a <- get bh + b <- get bh + c <- get bh + d <- get bh + e <- get bh + f <- get bh + g <- get bh + return (a,b,c,d,e,f,g) + +instance Binary a => Binary (Maybe a) where + put_ bh Nothing = putByte bh 0 + put_ bh (Just a) = do putByte bh 1; put_ bh a + get bh = do h <- getWord8 bh + case h of + 0 -> return Nothing + _ -> do x <- get bh; return (Just x) + +instance (Binary a, Binary b) => Binary (Either a b) where + put_ bh (Left a) = do putByte bh 0; put_ bh a + put_ bh (Right b) = do putByte bh 1; put_ bh b + get bh = do h <- getWord8 bh + case h of + 0 -> do a <- get bh ; return (Left a) + _ -> do b <- get bh ; return (Right b) + +instance Binary UTCTime where + put_ bh u = do put_ bh (utctDay u) + put_ bh (utctDayTime u) + get bh = do day <- get bh + dayTime <- get bh + return $ UTCTime { utctDay = day, utctDayTime = dayTime } + +instance Binary Day where + put_ bh d = put_ bh (toModifiedJulianDay d) + get bh = do i <- get bh + return $ ModifiedJulianDay { toModifiedJulianDay = i } + +instance Binary DiffTime where + put_ bh dt = put_ bh (toRational dt) + get bh = do r <- get bh + return $ fromRational r + +--to quote binary-0.3 on this code idea, +-- +-- TODO This instance is not architecture portable. GMP stores numbers as +-- arrays of machine sized words, so the byte format is not portable across +-- architectures with different endianness and word size. +-- +-- This makes it hard (impossible) to make an equivalent instance +-- with code that is compilable with non-GHC. Do we need any instance +-- Binary Integer, and if so, does it have to be blazing fast? Or can +-- we just change this instance to be portable like the rest of the +-- instances? (binary package has code to steal for that) +-- +-- yes, we need Binary Integer and Binary Rational in basicTypes/Literal.hs + +instance Binary Integer where + put_ bh i + | i >= lo32 && i <= hi32 = do + putWord8 bh 0 + put_ bh (fromIntegral i :: Int32) + | otherwise = do + putWord8 bh 1 + put_ bh (show i) + where + lo32 = fromIntegral (minBound :: Int32) + hi32 = fromIntegral (maxBound :: Int32) + + get bh = do + int_kind <- getWord8 bh + case int_kind of + 0 -> fromIntegral <$> (get bh :: IO Int32) + _ -> do str <- get bh + case reads str of + [(i, "")] -> return i + _ -> fail ("Binary integer: got " ++ show str) + + {- + -- This code is currently commented out. + -- See https://gitlab.haskell.org/ghc/ghc/issues/3379#note_104346 for + -- discussion. + + put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#) + put_ bh (J# s# a#) = do + putByte bh 1 + put_ bh (I# s#) + let sz# = sizeofByteArray# a# -- in *bytes* + put_ bh (I# sz#) -- in *bytes* + putByteArray bh a# sz# + + get bh = do + b <- getByte bh + case b of + 0 -> do (I# i#) <- get bh + return (S# i#) + _ -> do (I# s#) <- get bh + sz <- get bh + (BA a#) <- getByteArray bh sz + return (J# s# a#) + +putByteArray :: BinHandle -> ByteArray# -> Int# -> IO () +putByteArray bh a s# = loop 0# + where loop n# + | n# ==# s# = return () + | otherwise = do + putByte bh (indexByteArray a n#) + loop (n# +# 1#) + +getByteArray :: BinHandle -> Int -> IO ByteArray +getByteArray bh (I# sz) = do + (MBA arr) <- newByteArray sz + let loop n + | n ==# sz = return () + | otherwise = do + w <- getByte bh + writeByteArray arr n w + loop (n +# 1#) + loop 0# + freezeByteArray arr + -} + +{- +data ByteArray = BA ByteArray# +data MBA = MBA (MutableByteArray# RealWorld) + +newByteArray :: Int# -> IO MBA +newByteArray sz = IO $ \s -> + case newByteArray# sz s of { (# s, arr #) -> + (# s, MBA arr #) } + +freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray +freezeByteArray arr = IO $ \s -> + case unsafeFreezeByteArray# arr s of { (# s, arr #) -> + (# s, BA arr #) } + +writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO () +writeByteArray arr i (W8# w) = IO $ \s -> + case writeWord8Array# arr i w s of { s -> + (# s, () #) } + +indexByteArray :: ByteArray# -> Int# -> Word8 +indexByteArray a# n# = W8# (indexWord8Array# a# n#) + +-} +instance (Binary a) => Binary (Ratio a) where + put_ bh (a :% b) = do put_ bh a; put_ bh b + get bh = do a <- get bh; b <- get bh; return (a :% b) + +instance Binary (Bin a) where + put_ bh (BinPtr i) = put_ bh (fromIntegral i :: Int32) + get bh = do i <- get bh; return (BinPtr (fromIntegral (i :: Int32))) + +-- ----------------------------------------------------------------------------- +-- Instances for Data.Typeable stuff + +instance Binary TyCon where + put_ bh tc = do + put_ bh (tyConPackage tc) + put_ bh (tyConModule tc) + put_ bh (tyConName tc) + put_ bh (tyConKindArgs tc) + put_ bh (tyConKindRep tc) + get bh = + mkTyCon <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh + +instance Binary VecCount where + put_ bh = putByte bh . fromIntegral . fromEnum + get bh = toEnum . fromIntegral <$> getByte bh + +instance Binary VecElem where + put_ bh = putByte bh . fromIntegral . fromEnum + get bh = toEnum . fromIntegral <$> getByte bh + +instance Binary RuntimeRep where + put_ bh (VecRep a b) = putByte bh 0 >> put_ bh a >> put_ bh b + put_ bh (TupleRep reps) = putByte bh 1 >> put_ bh reps + put_ bh (SumRep reps) = putByte bh 2 >> put_ bh reps + put_ bh LiftedRep = putByte bh 3 + put_ bh UnliftedRep = putByte bh 4 + put_ bh IntRep = putByte bh 5 + put_ bh WordRep = putByte bh 6 + put_ bh Int64Rep = putByte bh 7 + put_ bh Word64Rep = putByte bh 8 + put_ bh AddrRep = putByte bh 9 + put_ bh FloatRep = putByte bh 10 + put_ bh DoubleRep = putByte bh 11 +#if __GLASGOW_HASKELL__ >= 807 + put_ bh Int8Rep = putByte bh 12 + put_ bh Word8Rep = putByte bh 13 + put_ bh Int16Rep = putByte bh 14 + put_ bh Word16Rep = putByte bh 15 +#endif + + get bh = do + tag <- getByte bh + case tag of + 0 -> VecRep <$> get bh <*> get bh + 1 -> TupleRep <$> get bh + 2 -> SumRep <$> get bh + 3 -> pure LiftedRep + 4 -> pure UnliftedRep + 5 -> pure IntRep + 6 -> pure WordRep + 7 -> pure Int64Rep + 8 -> pure Word64Rep + 9 -> pure AddrRep + 10 -> pure FloatRep + 11 -> pure DoubleRep +#if __GLASGOW_HASKELL__ >= 807 + 12 -> pure Int8Rep + 13 -> pure Word8Rep + 14 -> pure Int16Rep + 15 -> pure Word16Rep +#endif + _ -> fail "Binary.putRuntimeRep: invalid tag" + +instance Binary KindRep where + put_ bh (KindRepTyConApp tc k) = putByte bh 0 >> put_ bh tc >> put_ bh k + put_ bh (KindRepVar bndr) = putByte bh 1 >> put_ bh bndr + put_ bh (KindRepApp a b) = putByte bh 2 >> put_ bh a >> put_ bh b + put_ bh (KindRepFun a b) = putByte bh 3 >> put_ bh a >> put_ bh b + put_ bh (KindRepTYPE r) = putByte bh 4 >> put_ bh r + put_ bh (KindRepTypeLit sort r) = putByte bh 5 >> put_ bh sort >> put_ bh r + + get bh = do + tag <- getByte bh + case tag of + 0 -> KindRepTyConApp <$> get bh <*> get bh + 1 -> KindRepVar <$> get bh + 2 -> KindRepApp <$> get bh <*> get bh + 3 -> KindRepFun <$> get bh <*> get bh + 4 -> KindRepTYPE <$> get bh + 5 -> KindRepTypeLit <$> get bh <*> get bh + _ -> fail "Binary.putKindRep: invalid tag" + +instance Binary TypeLitSort where + put_ bh TypeLitSymbol = putByte bh 0 + put_ bh TypeLitNat = putByte bh 1 + get bh = do + tag <- getByte bh + case tag of + 0 -> pure TypeLitSymbol + 1 -> pure TypeLitNat + _ -> fail "Binary.putTypeLitSort: invalid tag" + +putTypeRep :: BinHandle -> TypeRep a -> IO () +-- Special handling for TYPE, (->), and RuntimeRep due to recursive kind +-- relations. +-- See Note [Mutually recursive representations of primitive types] +putTypeRep bh rep + | Just HRefl <- rep `eqTypeRep` (typeRep :: TypeRep Type) + = put_ bh (0 :: Word8) +putTypeRep bh (Con' con ks) = do + put_ bh (1 :: Word8) + put_ bh con + put_ bh ks +putTypeRep bh (App f x) = do + put_ bh (2 :: Word8) + putTypeRep bh f + putTypeRep bh x +putTypeRep bh (Fun arg res) = do + put_ bh (3 :: Word8) + putTypeRep bh arg + putTypeRep bh res +putTypeRep _ _ = fail "Binary.putTypeRep: Impossible" + +getSomeTypeRep :: BinHandle -> IO SomeTypeRep +getSomeTypeRep bh = do + tag <- get bh :: IO Word8 + case tag of + 0 -> return $ SomeTypeRep (typeRep :: TypeRep Type) + 1 -> do con <- get bh :: IO TyCon + ks <- get bh :: IO [SomeTypeRep] + return $ SomeTypeRep $ mkTrCon con ks + + 2 -> do SomeTypeRep f <- getSomeTypeRep bh + SomeTypeRep x <- getSomeTypeRep bh + case typeRepKind f of + Fun arg res -> + case arg `eqTypeRep` typeRepKind x of + Just HRefl -> + case typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of + Just HRefl -> return $ SomeTypeRep $ mkTrApp f x + _ -> failure "Kind mismatch in type application" [] + _ -> failure "Kind mismatch in type application" + [ " Found argument of kind: " ++ show (typeRepKind x) + , " Where the constructor: " ++ show f + , " Expects kind: " ++ show arg + ] + _ -> failure "Applied non-arrow" + [ " Applied type: " ++ show f + , " To argument: " ++ show x + ] + 3 -> do SomeTypeRep arg <- getSomeTypeRep bh + SomeTypeRep res <- getSomeTypeRep bh + if + | App argkcon _ <- typeRepKind arg + , App reskcon _ <- typeRepKind res + , Just HRefl <- argkcon `eqTypeRep` tYPErep + , Just HRefl <- reskcon `eqTypeRep` tYPErep + -> return $ SomeTypeRep $ Fun arg res + | otherwise -> failure "Kind mismatch" [] + _ -> failure "Invalid SomeTypeRep" [] + where + tYPErep :: TypeRep TYPE + tYPErep = typeRep + + failure description info = + fail $ unlines $ [ "Binary.getSomeTypeRep: "++description ] + ++ map (" "++) info + +instance Typeable a => Binary (TypeRep (a :: k)) where + put_ = putTypeRep + get bh = do + SomeTypeRep rep <- getSomeTypeRep bh + case rep `eqTypeRep` expected of + Just HRefl -> pure rep + Nothing -> fail $ unlines + [ "Binary: Type mismatch" + , " Deserialized type: " ++ show rep + , " Expected type: " ++ show expected + ] + where expected = typeRep :: TypeRep a + +instance Binary SomeTypeRep where + put_ bh (SomeTypeRep rep) = putTypeRep bh rep + get = getSomeTypeRep + +-- ----------------------------------------------------------------------------- +-- Lazy reading/writing + +lazyPut :: Binary a => BinHandle -> a -> IO () +lazyPut bh a = do + -- output the obj with a ptr to skip over it: + pre_a <- tellBin bh + put_ bh pre_a -- save a slot for the ptr + put_ bh a -- dump the object + q <- tellBin bh -- q = ptr to after object + putAt bh pre_a q -- fill in slot before a with ptr to q + seekBin bh q -- finally carry on writing at q + +lazyGet :: Binary a => BinHandle -> IO a +lazyGet bh = do + p <- get bh -- a BinPtr + p_a <- tellBin bh + a <- unsafeInterleaveIO $ do + -- NB: Use a fresh off_r variable in the child thread, for thread + -- safety. + off_r <- newFastMutInt + getAt bh { _off_r = off_r } p_a + seekBin bh p -- skip over the object for now + return a + +-- ----------------------------------------------------------------------------- +-- UserData +-- ----------------------------------------------------------------------------- + +-- | Information we keep around during interface file +-- serialization/deserialization. Namely we keep the functions for serializing +-- and deserializing 'Name's and 'FastString's. We do this because we actually +-- use serialization in two distinct settings, +-- +-- * When serializing interface files themselves +-- +-- * When computing the fingerprint of an IfaceDecl (which we computing by +-- hashing its Binary serialization) +-- +-- These two settings have different needs while serializing Names: +-- +-- * Names in interface files are serialized via a symbol table (see Note +-- [Symbol table representation of names] in BinIface). +-- +-- * During fingerprinting a binding Name is serialized as the OccName and a +-- non-binding Name is serialized as the fingerprint of the thing they +-- represent. See Note [Fingerprinting IfaceDecls] for further discussion. +-- +data UserData = + UserData { + -- for *deserialising* only: + ud_get_name :: BinHandle -> IO Name, + ud_get_fs :: BinHandle -> IO FastString, + + -- for *serialising* only: + ud_put_nonbinding_name :: BinHandle -> Name -> IO (), + -- ^ serialize a non-binding 'Name' (e.g. a reference to another + -- binding). + ud_put_binding_name :: BinHandle -> Name -> IO (), + -- ^ serialize a binding 'Name' (e.g. the name of an IfaceDecl) + ud_put_fs :: BinHandle -> FastString -> IO () + } + +newReadState :: (BinHandle -> IO Name) -- ^ how to deserialize 'Name's + -> (BinHandle -> IO FastString) + -> UserData +newReadState get_name get_fs + = UserData { ud_get_name = get_name, + ud_get_fs = get_fs, + ud_put_nonbinding_name = undef "put_nonbinding_name", + ud_put_binding_name = undef "put_binding_name", + ud_put_fs = undef "put_fs" + } + +newWriteState :: (BinHandle -> Name -> IO ()) + -- ^ how to serialize non-binding 'Name's + -> (BinHandle -> Name -> IO ()) + -- ^ how to serialize binding 'Name's + -> (BinHandle -> FastString -> IO ()) + -> UserData +newWriteState put_nonbinding_name put_binding_name put_fs + = UserData { ud_get_name = undef "get_name", + ud_get_fs = undef "get_fs", + ud_put_nonbinding_name = put_nonbinding_name, + ud_put_binding_name = put_binding_name, + ud_put_fs = put_fs + } + +noUserData :: a +noUserData = undef "UserData" + +undef :: String -> a +undef s = panic ("Binary.UserData: no " ++ s) + +--------------------------------------------------------- +-- The Dictionary +--------------------------------------------------------- + +type Dictionary = Array Int FastString -- The dictionary + -- Should be 0-indexed + +putDictionary :: BinHandle -> Int -> UniqFM (Int,FastString) -> IO () +putDictionary bh sz dict = do + put_ bh sz + mapM_ (putFS bh) (elems (array (0,sz-1) (nonDetEltsUFM dict))) + -- It's OK to use nonDetEltsUFM here because the elements have indices + -- that array uses to create order + +getDictionary :: BinHandle -> IO Dictionary +getDictionary bh = do + sz <- get bh + elems <- sequence (take sz (repeat (getFS bh))) + return (listArray (0,sz-1) elems) + +--------------------------------------------------------- +-- The Symbol Table +--------------------------------------------------------- + +-- On disk, the symbol table is an array of IfExtName, when +-- reading it in we turn it into a SymbolTable. + +type SymbolTable = Array Int Name + +--------------------------------------------------------- +-- Reading and writing FastStrings +--------------------------------------------------------- + +putFS :: BinHandle -> FastString -> IO () +putFS bh fs = putBS bh $ bytesFS fs + +getFS :: BinHandle -> IO FastString +getFS bh = do + l <- get bh :: IO Int + getPrim bh l (\src -> pure $! mkFastStringBytes src l ) + +putBS :: BinHandle -> ByteString -> IO () +putBS bh bs = + BS.unsafeUseAsCStringLen bs $ \(ptr, l) -> do + put_ bh l + putPrim bh l (\op -> BS.memcpy op (castPtr ptr) l) + +getBS :: BinHandle -> IO ByteString +getBS bh = do + l <- get bh :: IO Int + BS.create l $ \dest -> do + getPrim bh l (\src -> BS.memcpy dest src l) + +instance Binary ByteString where + put_ bh f = putBS bh f + get bh = getBS bh + +instance Binary FastString where + put_ bh f = + case getUserData bh of + UserData { ud_put_fs = put_fs } -> put_fs bh f + + get bh = + case getUserData bh of + UserData { ud_get_fs = get_fs } -> get_fs bh + +-- Here to avoid loop +instance Binary LeftOrRight where + put_ bh CLeft = putByte bh 0 + put_ bh CRight = putByte bh 1 + + get bh = do { h <- getByte bh + ; case h of + 0 -> return CLeft + _ -> return CRight } + +instance Binary PromotionFlag where + put_ bh NotPromoted = putByte bh 0 + put_ bh IsPromoted = putByte bh 1 + + get bh = do + n <- getByte bh + case n of + 0 -> return NotPromoted + 1 -> return IsPromoted + _ -> fail "Binary(IsPromoted): fail)" + +instance Binary Fingerprint where + put_ h (Fingerprint w1 w2) = do put_ h w1; put_ h w2 + get h = do w1 <- get h; w2 <- get h; return (Fingerprint w1 w2) + +instance Binary FunctionOrData where + put_ bh IsFunction = putByte bh 0 + put_ bh IsData = putByte bh 1 + get bh = do + h <- getByte bh + case h of + 0 -> return IsFunction + 1 -> return IsData + _ -> panic "Binary FunctionOrData" + +instance Binary TupleSort where + put_ bh BoxedTuple = putByte bh 0 + put_ bh UnboxedTuple = putByte bh 1 + put_ bh ConstraintTuple = putByte bh 2 + get bh = do + h <- getByte bh + case h of + 0 -> do return BoxedTuple + 1 -> do return UnboxedTuple + _ -> do return ConstraintTuple + +instance Binary Activation where + put_ bh NeverActive = do + putByte bh 0 + put_ bh AlwaysActive = do + putByte bh 1 + put_ bh (ActiveBefore src aa) = do + putByte bh 2 + put_ bh src + put_ bh aa + put_ bh (ActiveAfter src ab) = do + putByte bh 3 + put_ bh src + put_ bh ab + get bh = do + h <- getByte bh + case h of + 0 -> do return NeverActive + 1 -> do return AlwaysActive + 2 -> do src <- get bh + aa <- get bh + return (ActiveBefore src aa) + _ -> do src <- get bh + ab <- get bh + return (ActiveAfter src ab) + +instance Binary InlinePragma where + put_ bh (InlinePragma s a b c d) = do + put_ bh s + put_ bh a + put_ bh b + put_ bh c + put_ bh d + + get bh = do + s <- get bh + a <- get bh + b <- get bh + c <- get bh + d <- get bh + return (InlinePragma s a b c d) + +instance Binary RuleMatchInfo where + put_ bh FunLike = putByte bh 0 + put_ bh ConLike = putByte bh 1 + get bh = do + h <- getByte bh + if h == 1 then return ConLike + else return FunLike + +instance Binary InlineSpec where + put_ bh NoUserInline = putByte bh 0 + put_ bh Inline = putByte bh 1 + put_ bh Inlinable = putByte bh 2 + put_ bh NoInline = putByte bh 3 + + get bh = do h <- getByte bh + case h of + 0 -> return NoUserInline + 1 -> return Inline + 2 -> return Inlinable + _ -> return NoInline + +instance Binary RecFlag where + put_ bh Recursive = do + putByte bh 0 + put_ bh NonRecursive = do + putByte bh 1 + get bh = do + h <- getByte bh + case h of + 0 -> do return Recursive + _ -> do return NonRecursive + +instance Binary OverlapMode where + put_ bh (NoOverlap s) = putByte bh 0 >> put_ bh s + put_ bh (Overlaps s) = putByte bh 1 >> put_ bh s + put_ bh (Incoherent s) = putByte bh 2 >> put_ bh s + put_ bh (Overlapping s) = putByte bh 3 >> put_ bh s + put_ bh (Overlappable s) = putByte bh 4 >> put_ bh s + get bh = do + h <- getByte bh + case h of + 0 -> (get bh) >>= \s -> return $ NoOverlap s + 1 -> (get bh) >>= \s -> return $ Overlaps s + 2 -> (get bh) >>= \s -> return $ Incoherent s + 3 -> (get bh) >>= \s -> return $ Overlapping s + 4 -> (get bh) >>= \s -> return $ Overlappable s + _ -> panic ("get OverlapMode" ++ show h) + + +instance Binary OverlapFlag where + put_ bh flag = do put_ bh (overlapMode flag) + put_ bh (isSafeOverlap flag) + get bh = do + h <- get bh + b <- get bh + return OverlapFlag { overlapMode = h, isSafeOverlap = b } + +instance Binary FixityDirection where + put_ bh InfixL = do + putByte bh 0 + put_ bh InfixR = do + putByte bh 1 + put_ bh InfixN = do + putByte bh 2 + get bh = do + h <- getByte bh + case h of + 0 -> do return InfixL + 1 -> do return InfixR + _ -> do return InfixN + +instance Binary Fixity where + put_ bh (Fixity src aa ab) = do + put_ bh src + put_ bh aa + put_ bh ab + get bh = do + src <- get bh + aa <- get bh + ab <- get bh + return (Fixity src aa ab) + +instance Binary WarningTxt where + put_ bh (WarningTxt s w) = do + putByte bh 0 + put_ bh s + put_ bh w + put_ bh (DeprecatedTxt s d) = do + putByte bh 1 + put_ bh s + put_ bh d + + get bh = do + h <- getByte bh + case h of + 0 -> do s <- get bh + w <- get bh + return (WarningTxt s w) + _ -> do s <- get bh + d <- get bh + return (DeprecatedTxt s d) + +instance Binary StringLiteral where + put_ bh (StringLiteral st fs) = do + put_ bh st + put_ bh fs + get bh = do + st <- get bh + fs <- get bh + return (StringLiteral st fs) + +instance Binary a => Binary (Located a) where + put_ bh (L l x) = do + put_ bh l + put_ bh x + + get bh = do + l <- get bh + x <- get bh + return (L l x) + +instance Binary RealSrcSpan where + put_ bh ss = do + put_ bh (srcSpanFile ss) + put_ bh (srcSpanStartLine ss) + put_ bh (srcSpanStartCol ss) + put_ bh (srcSpanEndLine ss) + put_ bh (srcSpanEndCol ss) + + get bh = do + f <- get bh + sl <- get bh + sc <- get bh + el <- get bh + ec <- get bh + return (mkRealSrcSpan (mkRealSrcLoc f sl sc) + (mkRealSrcLoc f el ec)) + +instance Binary SrcSpan where + put_ bh (RealSrcSpan ss) = do + putByte bh 0 + put_ bh ss + + put_ bh (UnhelpfulSpan s) = do + putByte bh 1 + put_ bh s + + get bh = do + h <- getByte bh + case h of + 0 -> do ss <- get bh + return (RealSrcSpan ss) + _ -> do s <- get bh + return (UnhelpfulSpan s) + +instance Binary Serialized where + put_ bh (Serialized the_type bytes) = do + put_ bh the_type + put_ bh bytes + get bh = do + the_type <- get bh + bytes <- get bh + return (Serialized the_type bytes) + +instance Binary SourceText where + put_ bh NoSourceText = putByte bh 0 + put_ bh (SourceText s) = do + putByte bh 1 + put_ bh s + + get bh = do + h <- getByte bh + case h of + 0 -> return NoSourceText + 1 -> do + s <- get bh + return (SourceText s) + _ -> panic $ "Binary SourceText:" ++ show h diff --git a/compiler/utils/BooleanFormula.hs b/compiler/utils/BooleanFormula.hs new file mode 100644 --- /dev/null +++ b/compiler/utils/BooleanFormula.hs @@ -0,0 +1,262 @@ +{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, + DeriveTraversable #-} + +-------------------------------------------------------------------------------- +-- | Boolean formulas without quantifiers and without negation. +-- Such a formula consists of variables, conjunctions (and), and disjunctions (or). +-- +-- This module is used to represent minimal complete definitions for classes. +-- +module BooleanFormula ( + BooleanFormula(..), LBooleanFormula, + mkFalse, mkTrue, mkAnd, mkOr, mkVar, + isFalse, isTrue, + eval, simplify, isUnsatisfied, + implies, impliesAtom, + pprBooleanFormula, pprBooleanFormulaNice + ) where + +import GhcPrelude + +import Data.List ( nub, intersperse ) +import Data.Data + +import MonadUtils +import Outputable +import Binary +import SrcLoc +import Unique +import UniqSet + +---------------------------------------------------------------------- +-- Boolean formula type and smart constructors +---------------------------------------------------------------------- + +type LBooleanFormula a = Located (BooleanFormula a) + +data BooleanFormula a = Var a | And [LBooleanFormula a] | Or [LBooleanFormula a] + | Parens (LBooleanFormula a) + deriving (Eq, Data, Functor, Foldable, Traversable) + +mkVar :: a -> BooleanFormula a +mkVar = Var + +mkFalse, mkTrue :: BooleanFormula a +mkFalse = Or [] +mkTrue = And [] + +-- Convert a Bool to a BooleanFormula +mkBool :: Bool -> BooleanFormula a +mkBool False = mkFalse +mkBool True = mkTrue + +-- Make a conjunction, and try to simplify +mkAnd :: Eq a => [LBooleanFormula a] -> BooleanFormula a +mkAnd = maybe mkFalse (mkAnd' . nub) . concatMapM fromAnd + where + -- See Note [Simplification of BooleanFormulas] + fromAnd :: LBooleanFormula a -> Maybe [LBooleanFormula a] + fromAnd (L _ (And xs)) = Just xs + -- assume that xs are already simplified + -- otherwise we would need: fromAnd (And xs) = concat <$> traverse fromAnd xs + fromAnd (L _ (Or [])) = Nothing + -- in case of False we bail out, And [..,mkFalse,..] == mkFalse + fromAnd x = Just [x] + mkAnd' [x] = unLoc x + mkAnd' xs = And xs + +mkOr :: Eq a => [LBooleanFormula a] -> BooleanFormula a +mkOr = maybe mkTrue (mkOr' . nub) . concatMapM fromOr + where + -- See Note [Simplification of BooleanFormulas] + fromOr (L _ (Or xs)) = Just xs + fromOr (L _ (And [])) = Nothing + fromOr x = Just [x] + mkOr' [x] = unLoc x + mkOr' xs = Or xs + + +{- +Note [Simplification of BooleanFormulas] +~~~~~~~~~~~~~~~~~~~~~~ +The smart constructors (`mkAnd` and `mkOr`) do some attempt to simplify expressions. In particular, + 1. Collapsing nested ands and ors, so + `(mkAnd [x, And [y,z]]` + is represented as + `And [x,y,z]` + Implemented by `fromAnd`/`fromOr` + 2. Collapsing trivial ands and ors, so + `mkAnd [x]` becomes just `x`. + Implemented by mkAnd' / mkOr' + 3. Conjunction with false, disjunction with true is simplified, i.e. + `mkAnd [mkFalse,x]` becomes `mkFalse`. + 4. Common subexpression elimination: + `mkAnd [x,x,y]` is reduced to just `mkAnd [x,y]`. + +This simplification is not exhaustive, in the sense that it will not produce +the smallest possible equivalent expression. For example, +`Or [And [x,y], And [x]]` could be simplified to `And [x]`, but it currently +is not. A general simplifier would need to use something like BDDs. + +The reason behind the (crude) simplifier is to make for more user friendly +error messages. E.g. for the code + > class Foo a where + > {-# MINIMAL bar, (foo, baq | foo, quux) #-} + > instance Foo Int where + > bar = ... + > baz = ... + > quux = ... +We don't show a ridiculous error message like + Implement () and (either (`foo' and ()) or (`foo' and ())) +-} + +---------------------------------------------------------------------- +-- Evaluation and simplification +---------------------------------------------------------------------- + +isFalse :: BooleanFormula a -> Bool +isFalse (Or []) = True +isFalse _ = False + +isTrue :: BooleanFormula a -> Bool +isTrue (And []) = True +isTrue _ = False + +eval :: (a -> Bool) -> BooleanFormula a -> Bool +eval f (Var x) = f x +eval f (And xs) = all (eval f . unLoc) xs +eval f (Or xs) = any (eval f . unLoc) xs +eval f (Parens x) = eval f (unLoc x) + +-- Simplify a boolean formula. +-- The argument function should give the truth of the atoms, or Nothing if undecided. +simplify :: Eq a => (a -> Maybe Bool) -> BooleanFormula a -> BooleanFormula a +simplify f (Var a) = case f a of + Nothing -> Var a + Just b -> mkBool b +simplify f (And xs) = mkAnd (map (\(L l x) -> L l (simplify f x)) xs) +simplify f (Or xs) = mkOr (map (\(L l x) -> L l (simplify f x)) xs) +simplify f (Parens x) = simplify f (unLoc x) + +-- Test if a boolean formula is satisfied when the given values are assigned to the atoms +-- if it is, returns Nothing +-- if it is not, return (Just remainder) +isUnsatisfied :: Eq a => (a -> Bool) -> BooleanFormula a -> Maybe (BooleanFormula a) +isUnsatisfied f bf + | isTrue bf' = Nothing + | otherwise = Just bf' + where + f' x = if f x then Just True else Nothing + bf' = simplify f' bf + +-- prop_simplify: +-- eval f x == True <==> isTrue (simplify (Just . f) x) +-- eval f x == False <==> isFalse (simplify (Just . f) x) + +-- If the boolean formula holds, does that mean that the given atom is always true? +impliesAtom :: Eq a => BooleanFormula a -> a -> Bool +Var x `impliesAtom` y = x == y +And xs `impliesAtom` y = any (\x -> (unLoc x) `impliesAtom` y) xs + -- we have all of xs, so one of them implying y is enough +Or xs `impliesAtom` y = all (\x -> (unLoc x) `impliesAtom` y) xs +Parens x `impliesAtom` y = (unLoc x) `impliesAtom` y + +implies :: Uniquable a => BooleanFormula a -> BooleanFormula a -> Bool +implies e1 e2 = go (Clause emptyUniqSet [e1]) (Clause emptyUniqSet [e2]) + where + go :: Uniquable a => Clause a -> Clause a -> Bool + go l@Clause{ clauseExprs = hyp:hyps } r = + case hyp of + Var x | memberClauseAtoms x r -> True + | otherwise -> go (extendClauseAtoms l x) { clauseExprs = hyps } r + Parens hyp' -> go l { clauseExprs = unLoc hyp':hyps } r + And hyps' -> go l { clauseExprs = map unLoc hyps' ++ hyps } r + Or hyps' -> all (\hyp' -> go l { clauseExprs = unLoc hyp':hyps } r) hyps' + go l r@Clause{ clauseExprs = con:cons } = + case con of + Var x | memberClauseAtoms x l -> True + | otherwise -> go l (extendClauseAtoms r x) { clauseExprs = cons } + Parens con' -> go l r { clauseExprs = unLoc con':cons } + And cons' -> all (\con' -> go l r { clauseExprs = unLoc con':cons }) cons' + Or cons' -> go l r { clauseExprs = map unLoc cons' ++ cons } + go _ _ = False + +-- A small sequent calculus proof engine. +data Clause a = Clause { + clauseAtoms :: UniqSet a, + clauseExprs :: [BooleanFormula a] + } +extendClauseAtoms :: Uniquable a => Clause a -> a -> Clause a +extendClauseAtoms c x = c { clauseAtoms = addOneToUniqSet (clauseAtoms c) x } + +memberClauseAtoms :: Uniquable a => a -> Clause a -> Bool +memberClauseAtoms x c = x `elementOfUniqSet` clauseAtoms c + +---------------------------------------------------------------------- +-- Pretty printing +---------------------------------------------------------------------- + +-- Pretty print a BooleanFormula, +-- using the arguments as pretty printers for Var, And and Or respectively +pprBooleanFormula' :: (Rational -> a -> SDoc) + -> (Rational -> [SDoc] -> SDoc) + -> (Rational -> [SDoc] -> SDoc) + -> Rational -> BooleanFormula a -> SDoc +pprBooleanFormula' pprVar pprAnd pprOr = go + where + go p (Var x) = pprVar p x + go p (And []) = cparen (p > 0) $ empty + go p (And xs) = pprAnd p (map (go 3 . unLoc) xs) + go _ (Or []) = keyword $ text "FALSE" + go p (Or xs) = pprOr p (map (go 2 . unLoc) xs) + go p (Parens x) = go p (unLoc x) + +-- Pretty print in source syntax, "a | b | c,d,e" +pprBooleanFormula :: (Rational -> a -> SDoc) -> Rational -> BooleanFormula a -> SDoc +pprBooleanFormula pprVar = pprBooleanFormula' pprVar pprAnd pprOr + where + pprAnd p = cparen (p > 3) . fsep . punctuate comma + pprOr p = cparen (p > 2) . fsep . intersperse vbar + +-- Pretty print human in readable format, "either `a' or `b' or (`c', `d' and `e')"? +pprBooleanFormulaNice :: Outputable a => BooleanFormula a -> SDoc +pprBooleanFormulaNice = pprBooleanFormula' pprVar pprAnd pprOr 0 + where + pprVar _ = quotes . ppr + pprAnd p = cparen (p > 1) . pprAnd' + pprAnd' [] = empty + pprAnd' [x,y] = x <+> text "and" <+> y + pprAnd' xs@(_:_) = fsep (punctuate comma (init xs)) <> text ", and" <+> last xs + pprOr p xs = cparen (p > 1) $ text "either" <+> sep (intersperse (text "or") xs) + +instance (OutputableBndr a) => Outputable (BooleanFormula a) where + ppr = pprBooleanFormulaNormal + +pprBooleanFormulaNormal :: (OutputableBndr a) + => BooleanFormula a -> SDoc +pprBooleanFormulaNormal = go + where + go (Var x) = pprPrefixOcc x + go (And xs) = fsep $ punctuate comma (map (go . unLoc) xs) + go (Or []) = keyword $ text "FALSE" + go (Or xs) = fsep $ intersperse vbar (map (go . unLoc) xs) + go (Parens x) = parens (go $ unLoc x) + + +---------------------------------------------------------------------- +-- Binary +---------------------------------------------------------------------- + +instance Binary a => Binary (BooleanFormula a) where + put_ bh (Var x) = putByte bh 0 >> put_ bh x + put_ bh (And xs) = putByte bh 1 >> put_ bh xs + put_ bh (Or xs) = putByte bh 2 >> put_ bh xs + put_ bh (Parens x) = putByte bh 3 >> put_ bh x + + get bh = do + h <- getByte bh + case h of + 0 -> Var <$> get bh + 1 -> And <$> get bh + 2 -> Or <$> get bh + _ -> Parens <$> get bh diff --git a/compiler/utils/BufWrite.hs b/compiler/utils/BufWrite.hs new file mode 100644 --- /dev/null +++ b/compiler/utils/BufWrite.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE BangPatterns #-} + +----------------------------------------------------------------------------- +-- +-- Fast write-buffered Handles +-- +-- (c) The University of Glasgow 2005-2006 +-- +-- This is a simple abstraction over Handles that offers very fast write +-- buffering, but without the thread safety that Handles provide. It's used +-- to save time in Pretty.printDoc. +-- +----------------------------------------------------------------------------- + +module BufWrite ( + BufHandle(..), + newBufHandle, + bPutChar, + bPutStr, + bPutFS, + bPutFZS, + bPutPtrString, + bPutReplicate, + bFlush, + ) where + +import GhcPrelude + +import FastString +import FastMutInt + +import Control.Monad ( when ) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Unsafe as BS +import Data.Char ( ord ) +import Foreign +import Foreign.C.String +import System.IO + +-- ----------------------------------------------------------------------------- + +data BufHandle = BufHandle {-#UNPACK#-}!(Ptr Word8) + {-#UNPACK#-}!FastMutInt + Handle + +newBufHandle :: Handle -> IO BufHandle +newBufHandle hdl = do + ptr <- mallocBytes buf_size + r <- newFastMutInt + writeFastMutInt r 0 + return (BufHandle ptr r hdl) + +buf_size :: Int +buf_size = 8192 + +bPutChar :: BufHandle -> Char -> IO () +bPutChar b@(BufHandle buf r hdl) !c = do + i <- readFastMutInt r + if (i >= buf_size) + then do hPutBuf hdl buf buf_size + writeFastMutInt r 0 + bPutChar b c + else do pokeElemOff buf i (fromIntegral (ord c) :: Word8) + writeFastMutInt r (i+1) + +bPutStr :: BufHandle -> String -> IO () +bPutStr (BufHandle buf r hdl) !str = do + i <- readFastMutInt r + loop str i + where loop "" !i = do writeFastMutInt r i; return () + loop (c:cs) !i + | i >= buf_size = do + hPutBuf hdl buf buf_size + loop (c:cs) 0 + | otherwise = do + pokeElemOff buf i (fromIntegral (ord c)) + loop cs (i+1) + +bPutFS :: BufHandle -> FastString -> IO () +bPutFS b fs = bPutBS b $ bytesFS fs + +bPutFZS :: BufHandle -> FastZString -> IO () +bPutFZS b fs = bPutBS b $ fastZStringToByteString fs + +bPutBS :: BufHandle -> ByteString -> IO () +bPutBS b bs = BS.unsafeUseAsCStringLen bs $ bPutCStringLen b + +bPutCStringLen :: BufHandle -> CStringLen -> IO () +bPutCStringLen b@(BufHandle buf r hdl) cstr@(ptr, len) = do + i <- readFastMutInt r + if (i + len) >= buf_size + then do hPutBuf hdl buf i + writeFastMutInt r 0 + if (len >= buf_size) + then hPutBuf hdl ptr len + else bPutCStringLen b cstr + else do + copyBytes (buf `plusPtr` i) ptr len + writeFastMutInt r (i + len) + +bPutPtrString :: BufHandle -> PtrString -> IO () +bPutPtrString b@(BufHandle buf r hdl) l@(PtrString a len) = l `seq` do + i <- readFastMutInt r + if (i+len) >= buf_size + then do hPutBuf hdl buf i + writeFastMutInt r 0 + if (len >= buf_size) + then hPutBuf hdl a len + else bPutPtrString b l + else do + copyBytes (buf `plusPtr` i) a len + writeFastMutInt r (i+len) + +-- | Replicate an 8-bit character +bPutReplicate :: BufHandle -> Int -> Char -> IO () +bPutReplicate (BufHandle buf r hdl) len c = do + i <- readFastMutInt r + let oc = fromIntegral (ord c) + if (i+len) < buf_size + then do + fillBytes (buf `plusPtr` i) oc len + writeFastMutInt r (i+len) + else do + -- flush the current buffer + when (i /= 0) $ hPutBuf hdl buf i + if (len < buf_size) + then do + fillBytes buf oc len + writeFastMutInt r len + else do + -- fill a full buffer + fillBytes buf oc buf_size + -- flush it as many times as necessary + let go n | n >= buf_size = do + hPutBuf hdl buf buf_size + go (n-buf_size) + | otherwise = writeFastMutInt r n + go len + +bFlush :: BufHandle -> IO () +bFlush (BufHandle buf r hdl) = do + i <- readFastMutInt r + when (i > 0) $ hPutBuf hdl buf i + free buf + return () diff --git a/compiler/utils/Digraph.hs b/compiler/utils/Digraph.hs new file mode 100644 --- /dev/null +++ b/compiler/utils/Digraph.hs @@ -0,0 +1,524 @@ +-- (c) The University of Glasgow 2006 + +{-# LANGUAGE CPP, ScopedTypeVariables, ViewPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Digraph( + Graph, graphFromEdgedVerticesOrd, graphFromEdgedVerticesUniq, + + SCC(..), Node(..), flattenSCC, flattenSCCs, + stronglyConnCompG, + topologicalSortG, + verticesG, edgesG, hasVertexG, + reachableG, reachablesG, transposeG, + emptyG, + + findCycle, + + -- For backwards compatibility with the simpler version of Digraph + stronglyConnCompFromEdgedVerticesOrd, + stronglyConnCompFromEdgedVerticesOrdR, + stronglyConnCompFromEdgedVerticesUniq, + stronglyConnCompFromEdgedVerticesUniqR, + + -- Simple way to classify edges + EdgeType(..), classifyEdges + ) where + +#include "HsVersions.h" + +------------------------------------------------------------------------------ +-- A version of the graph algorithms described in: +-- +-- ``Lazy Depth-First Search and Linear IntGraph Algorithms in Haskell'' +-- by David King and John Launchbury +-- +-- Also included is some additional code for printing tree structures ... +-- +-- If you ever find yourself in need of algorithms for classifying edges, +-- or finding connected/biconnected components, consult the history; Sigbjorn +-- Finne contributed some implementations in 1997, although we've since +-- removed them since they were not used anywhere in GHC. +------------------------------------------------------------------------------ + + +import GhcPrelude + +import Util ( minWith, count ) +import Outputable +import Maybes ( expectJust ) + +-- std interfaces +import Data.Maybe +import Data.Array +import Data.List hiding (transpose) +import qualified Data.Map as Map +import qualified Data.Set as Set + +import qualified Data.Graph as G +import Data.Graph hiding (Graph, Edge, transposeG, reachable) +import Data.Tree +import Unique +import UniqFM + +{- +************************************************************************ +* * +* Graphs and Graph Construction +* * +************************************************************************ + +Note [Nodes, keys, vertices] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * A 'node' is a big blob of client-stuff + + * Each 'node' has a unique (client) 'key', but the latter + is in Ord and has fast comparison + + * Digraph then maps each 'key' to a Vertex (Int) which is + arranged densely in 0.n +-} + +data Graph node = Graph { + gr_int_graph :: IntGraph, + gr_vertex_to_node :: Vertex -> node, + gr_node_to_vertex :: node -> Maybe Vertex + } + +data Edge node = Edge node node + +{-| Representation for nodes of the Graph. + + * The @payload@ is user data, just carried around in this module + + * The @key@ is the node identifier. + Key has an Ord instance for performance reasons. + + * The @[key]@ are the dependencies of the node; + it's ok to have extra keys in the dependencies that + are not the key of any Node in the graph +-} +data Node key payload = DigraphNode { + node_payload :: payload, -- ^ User data + node_key :: key, -- ^ User defined node id + node_dependencies :: [key] -- ^ Dependencies/successors of the node + } + + +instance (Outputable a, Outputable b) => Outputable (Node a b) where + ppr (DigraphNode a b c) = ppr (a, b, c) + +emptyGraph :: Graph a +emptyGraph = Graph (array (1, 0) []) (error "emptyGraph") (const Nothing) + +-- See Note [Deterministic SCC] +graphFromEdgedVertices + :: ReduceFn key payload + -> [Node key payload] -- The graph; its ok for the + -- out-list to contain keys which aren't + -- a vertex key, they are ignored + -> Graph (Node key payload) +graphFromEdgedVertices _reduceFn [] = emptyGraph +graphFromEdgedVertices reduceFn edged_vertices = + Graph graph vertex_fn (key_vertex . key_extractor) + where key_extractor = node_key + (bounds, vertex_fn, key_vertex, numbered_nodes) = + reduceFn edged_vertices key_extractor + graph = array bounds [ (v, sort $ mapMaybe key_vertex ks) + | (v, (node_dependencies -> ks)) <- numbered_nodes] + -- We normalize outgoing edges by sorting on node order, so + -- that the result doesn't depend on the order of the edges + +-- See Note [Deterministic SCC] +-- See Note [reduceNodesIntoVertices implementations] +graphFromEdgedVerticesOrd + :: Ord key + => [Node key payload] -- The graph; its ok for the + -- out-list to contain keys which aren't + -- a vertex key, they are ignored + -> Graph (Node key payload) +graphFromEdgedVerticesOrd = graphFromEdgedVertices reduceNodesIntoVerticesOrd + +-- See Note [Deterministic SCC] +-- See Note [reduceNodesIntoVertices implementations] +graphFromEdgedVerticesUniq + :: Uniquable key + => [Node key payload] -- The graph; its ok for the + -- out-list to contain keys which aren't + -- a vertex key, they are ignored + -> Graph (Node key payload) +graphFromEdgedVerticesUniq = graphFromEdgedVertices reduceNodesIntoVerticesUniq + +type ReduceFn key payload = + [Node key payload] -> (Node key payload -> key) -> + (Bounds, Vertex -> Node key payload + , key -> Maybe Vertex, [(Vertex, Node key payload)]) + +{- +Note [reduceNodesIntoVertices implementations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +reduceNodesIntoVertices is parameterized by the container type. +This is to accomodate key types that don't have an Ord instance +and hence preclude the use of Data.Map. An example of such type +would be Unique, there's no way to implement Ord Unique +deterministically. + +For such types, there's a version with a Uniquable constraint. +This leaves us with two versions of every function that depends on +reduceNodesIntoVertices, one with Ord constraint and the other with +Uniquable constraint. +For example: graphFromEdgedVerticesOrd and graphFromEdgedVerticesUniq. + +The Uniq version should be a tiny bit more efficient since it uses +Data.IntMap internally. +-} +reduceNodesIntoVertices + :: ([(key, Vertex)] -> m) + -> (key -> m -> Maybe Vertex) + -> ReduceFn key payload +reduceNodesIntoVertices fromList lookup nodes key_extractor = + (bounds, (!) vertex_map, key_vertex, numbered_nodes) + where + max_v = length nodes - 1 + bounds = (0, max_v) :: (Vertex, Vertex) + + -- Keep the order intact to make the result depend on input order + -- instead of key order + numbered_nodes = zip [0..] nodes + vertex_map = array bounds numbered_nodes + + key_map = fromList + [ (key_extractor node, v) | (v, node) <- numbered_nodes ] + key_vertex k = lookup k key_map + +-- See Note [reduceNodesIntoVertices implementations] +reduceNodesIntoVerticesOrd :: Ord key => ReduceFn key payload +reduceNodesIntoVerticesOrd = reduceNodesIntoVertices Map.fromList Map.lookup + +-- See Note [reduceNodesIntoVertices implementations] +reduceNodesIntoVerticesUniq :: Uniquable key => ReduceFn key payload +reduceNodesIntoVerticesUniq = reduceNodesIntoVertices listToUFM (flip lookupUFM) + +{- +************************************************************************ +* * +* SCC +* * +************************************************************************ +-} + +type WorkItem key payload + = (Node key payload, -- Tip of the path + [payload]) -- Rest of the path; + -- [a,b,c] means c depends on b, b depends on a + +-- | Find a reasonably short cycle a->b->c->a, in a strongly +-- connected component. The input nodes are presumed to be +-- a SCC, so you can start anywhere. +findCycle :: forall payload key. Ord key + => [Node key payload] -- The nodes. The dependencies can + -- contain extra keys, which are ignored + -> Maybe [payload] -- A cycle, starting with node + -- so each depends on the next +findCycle graph + = go Set.empty (new_work root_deps []) [] + where + env :: Map.Map key (Node key payload) + env = Map.fromList [ (node_key node, node) | node <- graph ] + + -- Find the node with fewest dependencies among the SCC modules + -- This is just a heuristic to find some plausible root module + root :: Node key payload + root = fst (minWith snd [ (node, count (`Map.member` env) + (node_dependencies node)) + | node <- graph ]) + DigraphNode root_payload root_key root_deps = root + + + -- 'go' implements Dijkstra's algorithm, more or less + go :: Set.Set key -- Visited + -> [WorkItem key payload] -- Work list, items length n + -> [WorkItem key payload] -- Work list, items length n+1 + -> Maybe [payload] -- Returned cycle + -- Invariant: in a call (go visited ps qs), + -- visited = union (map tail (ps ++ qs)) + + go _ [] [] = Nothing -- No cycles + go visited [] qs = go visited qs [] + go visited (((DigraphNode payload key deps), path) : ps) qs + | key == root_key = Just (root_payload : reverse path) + | key `Set.member` visited = go visited ps qs + | key `Map.notMember` env = go visited ps qs + | otherwise = go (Set.insert key visited) + ps (new_qs ++ qs) + where + new_qs = new_work deps (payload : path) + + new_work :: [key] -> [payload] -> [WorkItem key payload] + new_work deps path = [ (n, path) | Just n <- map (`Map.lookup` env) deps ] + +{- +************************************************************************ +* * +* Strongly Connected Component wrappers for Graph +* * +************************************************************************ + +Note: the components are returned topologically sorted: later components +depend on earlier ones, but not vice versa i.e. later components only have +edges going from them to earlier ones. +-} + +{- +Note [Deterministic SCC] +~~~~~~~~~~~~~~~~~~~~~~~~ +stronglyConnCompFromEdgedVerticesUniq, +stronglyConnCompFromEdgedVerticesUniqR, +stronglyConnCompFromEdgedVerticesOrd and +stronglyConnCompFromEdgedVerticesOrdR +provide a following guarantee: +Given a deterministically ordered list of nodes it returns a deterministically +ordered list of strongly connected components, where the list of vertices +in an SCC is also deterministically ordered. +Note that the order of edges doesn't need to be deterministic for this to work. +We use the order of nodes to normalize the order of edges. +-} + +stronglyConnCompG :: Graph node -> [SCC node] +stronglyConnCompG graph = decodeSccs graph forest + where forest = {-# SCC "Digraph.scc" #-} scc (gr_int_graph graph) + +decodeSccs :: Graph node -> Forest Vertex -> [SCC node] +decodeSccs Graph { gr_int_graph = graph, gr_vertex_to_node = vertex_fn } forest + = map decode forest + where + decode (Node v []) | mentions_itself v = CyclicSCC [vertex_fn v] + | otherwise = AcyclicSCC (vertex_fn v) + decode other = CyclicSCC (dec other []) + where dec (Node v ts) vs = vertex_fn v : foldr dec vs ts + mentions_itself v = v `elem` (graph ! v) + + +-- The following two versions are provided for backwards compatibility: +-- See Note [Deterministic SCC] +-- See Note [reduceNodesIntoVertices implementations] +stronglyConnCompFromEdgedVerticesOrd + :: Ord key + => [Node key payload] + -> [SCC payload] +stronglyConnCompFromEdgedVerticesOrd + = map (fmap node_payload) . stronglyConnCompFromEdgedVerticesOrdR + +-- The following two versions are provided for backwards compatibility: +-- See Note [Deterministic SCC] +-- See Note [reduceNodesIntoVertices implementations] +stronglyConnCompFromEdgedVerticesUniq + :: Uniquable key + => [Node key payload] + -> [SCC payload] +stronglyConnCompFromEdgedVerticesUniq + = map (fmap node_payload) . stronglyConnCompFromEdgedVerticesUniqR + +-- The "R" interface is used when you expect to apply SCC to +-- (some of) the result of SCC, so you don't want to lose the dependency info +-- See Note [Deterministic SCC] +-- See Note [reduceNodesIntoVertices implementations] +stronglyConnCompFromEdgedVerticesOrdR + :: Ord key + => [Node key payload] + -> [SCC (Node key payload)] +stronglyConnCompFromEdgedVerticesOrdR = + stronglyConnCompG . graphFromEdgedVertices reduceNodesIntoVerticesOrd + +-- The "R" interface is used when you expect to apply SCC to +-- (some of) the result of SCC, so you don't want to lose the dependency info +-- See Note [Deterministic SCC] +-- See Note [reduceNodesIntoVertices implementations] +stronglyConnCompFromEdgedVerticesUniqR + :: Uniquable key + => [Node key payload] + -> [SCC (Node key payload)] +stronglyConnCompFromEdgedVerticesUniqR = + stronglyConnCompG . graphFromEdgedVertices reduceNodesIntoVerticesUniq + +{- +************************************************************************ +* * +* Misc wrappers for Graph +* * +************************************************************************ +-} + +topologicalSortG :: Graph node -> [node] +topologicalSortG graph = map (gr_vertex_to_node graph) result + where result = {-# SCC "Digraph.topSort" #-} topSort (gr_int_graph graph) + +reachableG :: Graph node -> node -> [node] +reachableG graph from = map (gr_vertex_to_node graph) result + where from_vertex = expectJust "reachableG" (gr_node_to_vertex graph from) + result = {-# SCC "Digraph.reachable" #-} reachable (gr_int_graph graph) [from_vertex] + +-- | Given a list of roots return all reachable nodes. +reachablesG :: Graph node -> [node] -> [node] +reachablesG graph froms = map (gr_vertex_to_node graph) result + where result = {-# SCC "Digraph.reachable" #-} + reachable (gr_int_graph graph) vs + vs = [ v | Just v <- map (gr_node_to_vertex graph) froms ] + +hasVertexG :: Graph node -> node -> Bool +hasVertexG graph node = isJust $ gr_node_to_vertex graph node + +verticesG :: Graph node -> [node] +verticesG graph = map (gr_vertex_to_node graph) $ vertices (gr_int_graph graph) + +edgesG :: Graph node -> [Edge node] +edgesG graph = map (\(v1, v2) -> Edge (v2n v1) (v2n v2)) $ edges (gr_int_graph graph) + where v2n = gr_vertex_to_node graph + +transposeG :: Graph node -> Graph node +transposeG graph = Graph (G.transposeG (gr_int_graph graph)) + (gr_vertex_to_node graph) + (gr_node_to_vertex graph) + +emptyG :: Graph node -> Bool +emptyG g = graphEmpty (gr_int_graph g) + +{- +************************************************************************ +* * +* Showing Graphs +* * +************************************************************************ +-} + +instance Outputable node => Outputable (Graph node) where + ppr graph = vcat [ + hang (text "Vertices:") 2 (vcat (map ppr $ verticesG graph)), + hang (text "Edges:") 2 (vcat (map ppr $ edgesG graph)) + ] + +instance Outputable node => Outputable (Edge node) where + ppr (Edge from to) = ppr from <+> text "->" <+> ppr to + +graphEmpty :: G.Graph -> Bool +graphEmpty g = lo > hi + where (lo, hi) = bounds g + +{- +************************************************************************ +* * +* IntGraphs +* * +************************************************************************ +-} + +type IntGraph = G.Graph + +{- +------------------------------------------------------------ +-- Depth first search numbering +------------------------------------------------------------ +-} + +-- Data.Tree has flatten for Tree, but nothing for Forest +preorderF :: Forest a -> [a] +preorderF ts = concat (map flatten ts) + +{- +------------------------------------------------------------ +-- Finding reachable vertices +------------------------------------------------------------ +-} + +-- This generalizes reachable which was found in Data.Graph +reachable :: IntGraph -> [Vertex] -> [Vertex] +reachable g vs = preorderF (dfs g vs) + +{- +************************************************************************ +* * +* Classify Edge Types +* * +************************************************************************ +-} + +-- Remark: While we could generalize this algorithm this comes at a runtime +-- cost and with no advantages. If you find yourself using this with graphs +-- not easily represented using Int nodes please consider rewriting this +-- using the more general Graph type. + +-- | Edge direction based on DFS Classification +data EdgeType + = Forward + | Cross + | Backward -- ^ Loop back towards the root node. + -- Eg backjumps in loops + | SelfLoop -- ^ v -> v + deriving (Eq,Ord) + +instance Outputable EdgeType where + ppr Forward = text "Forward" + ppr Cross = text "Cross" + ppr Backward = text "Backward" + ppr SelfLoop = text "SelfLoop" + +newtype Time = Time Int deriving (Eq,Ord,Num,Outputable) + +--Allow for specialzation +{-# INLINEABLE classifyEdges #-} + +-- | Given a start vertex, a way to get successors from a node +-- and a list of (directed) edges classify the types of edges. +classifyEdges :: forall key. Uniquable key => key -> (key -> [key]) + -> [(key,key)] -> [((key, key), EdgeType)] +classifyEdges root getSucc edges = + --let uqe (from,to) = (getUnique from, getUnique to) + --in pprTrace "Edges:" (ppr $ map uqe edges) $ + zip edges $ map classify edges + where + (_time, starts, ends) = addTimes (0,emptyUFM,emptyUFM) root + classify :: (key,key) -> EdgeType + classify (from,to) + | startFrom < startTo + , endFrom > endTo + = Forward + | startFrom > startTo + , endFrom < endTo + = Backward + | startFrom > startTo + , endFrom > endTo + = Cross + | getUnique from == getUnique to + = SelfLoop + | otherwise + = pprPanic "Failed to classify edge of Graph" + (ppr (getUnique from, getUnique to)) + + where + getTime event node + | Just time <- lookupUFM event node + = time + | otherwise + = pprPanic "Failed to classify edge of CFG - not not timed" + (text "edges" <> ppr (getUnique from, getUnique to) + <+> ppr starts <+> ppr ends ) + startFrom = getTime starts from + startTo = getTime starts to + endFrom = getTime ends from + endTo = getTime ends to + + addTimes :: (Time, UniqFM Time, UniqFM Time) -> key + -> (Time, UniqFM Time, UniqFM Time) + addTimes (time,starts,ends) n + --Dont reenter nodes + | elemUFM n starts + = (time,starts,ends) + | otherwise = + let + starts' = addToUFM starts n time + time' = time + 1 + succs = getSucc n :: [key] + (time'',starts'',ends') = foldl' addTimes (time',starts',ends) succs + ends'' = addToUFM ends' n time'' + in + (time'' + 1, starts'', ends'') diff --git a/compiler/utils/Encoding.hs b/compiler/utils/Encoding.hs new file mode 100644 --- /dev/null +++ b/compiler/utils/Encoding.hs @@ -0,0 +1,450 @@ +{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-} +{-# OPTIONS_GHC -O2 #-} +-- We always optimise this, otherwise performance of a non-optimised +-- compiler is severely affected + +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow, 1997-2006 +-- +-- Character encodings +-- +-- ----------------------------------------------------------------------------- + +module Encoding ( + -- * UTF-8 + utf8DecodeChar#, + utf8PrevChar, + utf8CharStart, + utf8DecodeChar, + utf8DecodeByteString, + utf8DecodeStringLazy, + utf8EncodeChar, + utf8EncodeString, + utf8EncodedLength, + countUTF8Chars, + + -- * Z-encoding + zEncodeString, + zDecodeString, + + -- * Base62-encoding + toBase62, + toBase62Padded + ) where + +import GhcPrelude + +import Foreign +import Foreign.ForeignPtr.Unsafe +import Data.Char +import qualified Data.Char as Char +import Numeric +import GHC.IO + +import Data.ByteString (ByteString) +import qualified Data.ByteString.Internal as BS + +import GHC.Exts + +-- ----------------------------------------------------------------------------- +-- UTF-8 + +-- We can't write the decoder as efficiently as we'd like without +-- resorting to unboxed extensions, unfortunately. I tried to write +-- an IO version of this function, but GHC can't eliminate boxed +-- results from an IO-returning function. +-- +-- We assume we can ignore overflow when parsing a multibyte character here. +-- To make this safe, we add extra sentinel bytes to unparsed UTF-8 sequences +-- before decoding them (see StringBuffer.hs). + +{-# INLINE utf8DecodeChar# #-} +utf8DecodeChar# :: Addr# -> (# Char#, Int# #) +utf8DecodeChar# a# = + let !ch0 = word2Int# (indexWord8OffAddr# a# 0#) in + case () of + _ | isTrue# (ch0 <=# 0x7F#) -> (# chr# ch0, 1# #) + + | isTrue# ((ch0 >=# 0xC0#) `andI#` (ch0 <=# 0xDF#)) -> + let !ch1 = word2Int# (indexWord8OffAddr# a# 1#) in + if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else + (# chr# (((ch0 -# 0xC0#) `uncheckedIShiftL#` 6#) +# + (ch1 -# 0x80#)), + 2# #) + + | isTrue# ((ch0 >=# 0xE0#) `andI#` (ch0 <=# 0xEF#)) -> + let !ch1 = word2Int# (indexWord8OffAddr# a# 1#) in + if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else + let !ch2 = word2Int# (indexWord8OffAddr# a# 2#) in + if isTrue# ((ch2 <# 0x80#) `orI#` (ch2 >=# 0xC0#)) then fail 2# else + (# chr# (((ch0 -# 0xE0#) `uncheckedIShiftL#` 12#) +# + ((ch1 -# 0x80#) `uncheckedIShiftL#` 6#) +# + (ch2 -# 0x80#)), + 3# #) + + | isTrue# ((ch0 >=# 0xF0#) `andI#` (ch0 <=# 0xF8#)) -> + let !ch1 = word2Int# (indexWord8OffAddr# a# 1#) in + if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else + let !ch2 = word2Int# (indexWord8OffAddr# a# 2#) in + if isTrue# ((ch2 <# 0x80#) `orI#` (ch2 >=# 0xC0#)) then fail 2# else + let !ch3 = word2Int# (indexWord8OffAddr# a# 3#) in + if isTrue# ((ch3 <# 0x80#) `orI#` (ch3 >=# 0xC0#)) then fail 3# else + (# chr# (((ch0 -# 0xF0#) `uncheckedIShiftL#` 18#) +# + ((ch1 -# 0x80#) `uncheckedIShiftL#` 12#) +# + ((ch2 -# 0x80#) `uncheckedIShiftL#` 6#) +# + (ch3 -# 0x80#)), + 4# #) + + | otherwise -> fail 1# + where + -- all invalid sequences end up here: + fail :: Int# -> (# Char#, Int# #) + fail nBytes# = (# '\0'#, nBytes# #) + -- '\xFFFD' would be the usual replacement character, but + -- that's a valid symbol in Haskell, so will result in a + -- confusing parse error later on. Instead we use '\0' which + -- will signal a lexer error immediately. + +utf8DecodeChar :: Ptr Word8 -> (Char, Int) +utf8DecodeChar (Ptr a#) = + case utf8DecodeChar# a# of (# c#, nBytes# #) -> ( C# c#, I# nBytes# ) + +-- UTF-8 is cleverly designed so that we can always figure out where +-- the start of the current character is, given any position in a +-- stream. This function finds the start of the previous character, +-- assuming there *is* a previous character. +utf8PrevChar :: Ptr Word8 -> IO (Ptr Word8) +utf8PrevChar p = utf8CharStart (p `plusPtr` (-1)) + +utf8CharStart :: Ptr Word8 -> IO (Ptr Word8) +utf8CharStart p = go p + where go p = do w <- peek p + if w >= 0x80 && w < 0xC0 + then go (p `plusPtr` (-1)) + else return p + +utf8DecodeByteString :: ByteString -> [Char] +utf8DecodeByteString (BS.PS ptr offset len) + = utf8DecodeStringLazy ptr offset len + +utf8DecodeStringLazy :: ForeignPtr Word8 -> Int -> Int -> [Char] +utf8DecodeStringLazy fptr offset len + = unsafeDupablePerformIO $ unpack start + where + !start = unsafeForeignPtrToPtr fptr `plusPtr` offset + !end = start `plusPtr` len + + unpack p + | p >= end = touchForeignPtr fptr >> return [] + | otherwise = + case utf8DecodeChar# (unPtr p) of + (# c#, nBytes# #) -> do + rest <- unsafeDupableInterleaveIO $ unpack (p `plusPtr#` nBytes#) + return (C# c# : rest) + +countUTF8Chars :: Ptr Word8 -> Int -> IO Int +countUTF8Chars ptr len = go ptr 0 + where + !end = ptr `plusPtr` len + + go p !n + | p >= end = return n + | otherwise = do + case utf8DecodeChar# (unPtr p) of + (# _, nBytes# #) -> go (p `plusPtr#` nBytes#) (n+1) + +unPtr :: Ptr a -> Addr# +unPtr (Ptr a) = a + +plusPtr# :: Ptr a -> Int# -> Ptr a +plusPtr# ptr nBytes# = ptr `plusPtr` (I# nBytes#) + +utf8EncodeChar :: Char -> Ptr Word8 -> IO (Ptr Word8) +utf8EncodeChar c ptr = + let x = ord c in + case () of + _ | x > 0 && x <= 0x007f -> do + poke ptr (fromIntegral x) + return (ptr `plusPtr` 1) + -- NB. '\0' is encoded as '\xC0\x80', not '\0'. This is so that we + -- can have 0-terminated UTF-8 strings (see GHC.Base.unpackCStringUtf8). + | x <= 0x07ff -> do + poke ptr (fromIntegral (0xC0 .|. ((x `shiftR` 6) .&. 0x1F))) + pokeElemOff ptr 1 (fromIntegral (0x80 .|. (x .&. 0x3F))) + return (ptr `plusPtr` 2) + | x <= 0xffff -> do + poke ptr (fromIntegral (0xE0 .|. (x `shiftR` 12) .&. 0x0F)) + pokeElemOff ptr 1 (fromIntegral (0x80 .|. (x `shiftR` 6) .&. 0x3F)) + pokeElemOff ptr 2 (fromIntegral (0x80 .|. (x .&. 0x3F))) + return (ptr `plusPtr` 3) + | otherwise -> do + poke ptr (fromIntegral (0xF0 .|. (x `shiftR` 18))) + pokeElemOff ptr 1 (fromIntegral (0x80 .|. ((x `shiftR` 12) .&. 0x3F))) + pokeElemOff ptr 2 (fromIntegral (0x80 .|. ((x `shiftR` 6) .&. 0x3F))) + pokeElemOff ptr 3 (fromIntegral (0x80 .|. (x .&. 0x3F))) + return (ptr `plusPtr` 4) + +utf8EncodeString :: Ptr Word8 -> String -> IO () +utf8EncodeString ptr str = go ptr str + where go !_ [] = return () + go ptr (c:cs) = do + ptr' <- utf8EncodeChar c ptr + go ptr' cs + +utf8EncodedLength :: String -> Int +utf8EncodedLength str = go 0 str + where go !n [] = n + go n (c:cs) + | ord c > 0 && ord c <= 0x007f = go (n+1) cs + | ord c <= 0x07ff = go (n+2) cs + | ord c <= 0xffff = go (n+3) cs + | otherwise = go (n+4) cs + +-- ----------------------------------------------------------------------------- +-- The Z-encoding + +{- +This is the main name-encoding and decoding function. It encodes any +string into a string that is acceptable as a C name. This is done +right before we emit a symbol name into the compiled C or asm code. +Z-encoding of strings is cached in the FastString interface, so we +never encode the same string more than once. + +The basic encoding scheme is this. + +* Tuples (,,,) are coded as Z3T + +* Alphabetic characters (upper and lower) and digits + all translate to themselves; + except 'Z', which translates to 'ZZ' + and 'z', which translates to 'zz' + We need both so that we can preserve the variable/tycon distinction + +* Most other printable characters translate to 'zx' or 'Zx' for some + alphabetic character x + +* The others translate as 'znnnU' where 'nnn' is the decimal number + of the character + + Before After + -------------------------- + Trak Trak + foo_wib foozuwib + > zg + >1 zg1 + foo# foozh + foo## foozhzh + foo##1 foozhzh1 + fooZ fooZZ + :+ ZCzp + () Z0T 0-tuple + (,,,,) Z5T 5-tuple + (# #) Z1H unboxed 1-tuple (note the space) + (#,,,,#) Z5H unboxed 5-tuple + (NB: There is no Z1T nor Z0H.) +-} + +type UserString = String -- As the user typed it +type EncodedString = String -- Encoded form + + +zEncodeString :: UserString -> EncodedString +zEncodeString cs = case maybe_tuple cs of + Just n -> n -- Tuples go to Z2T etc + Nothing -> go cs + where + go [] = [] + go (c:cs) = encode_digit_ch c ++ go' cs + go' [] = [] + go' (c:cs) = encode_ch c ++ go' cs + +unencodedChar :: Char -> Bool -- True for chars that don't need encoding +unencodedChar 'Z' = False +unencodedChar 'z' = False +unencodedChar c = c >= 'a' && c <= 'z' + || c >= 'A' && c <= 'Z' + || c >= '0' && c <= '9' + +-- If a digit is at the start of a symbol then we need to encode it. +-- Otherwise package names like 9pH-0.1 give linker errors. +encode_digit_ch :: Char -> EncodedString +encode_digit_ch c | c >= '0' && c <= '9' = encode_as_unicode_char c +encode_digit_ch c | otherwise = encode_ch c + +encode_ch :: Char -> EncodedString +encode_ch c | unencodedChar c = [c] -- Common case first + +-- Constructors +encode_ch '(' = "ZL" -- Needed for things like (,), and (->) +encode_ch ')' = "ZR" -- For symmetry with ( +encode_ch '[' = "ZM" +encode_ch ']' = "ZN" +encode_ch ':' = "ZC" +encode_ch 'Z' = "ZZ" + +-- Variables +encode_ch 'z' = "zz" +encode_ch '&' = "za" +encode_ch '|' = "zb" +encode_ch '^' = "zc" +encode_ch '$' = "zd" +encode_ch '=' = "ze" +encode_ch '>' = "zg" +encode_ch '#' = "zh" +encode_ch '.' = "zi" +encode_ch '<' = "zl" +encode_ch '-' = "zm" +encode_ch '!' = "zn" +encode_ch '+' = "zp" +encode_ch '\'' = "zq" +encode_ch '\\' = "zr" +encode_ch '/' = "zs" +encode_ch '*' = "zt" +encode_ch '_' = "zu" +encode_ch '%' = "zv" +encode_ch c = encode_as_unicode_char c + +encode_as_unicode_char :: Char -> EncodedString +encode_as_unicode_char c = 'z' : if isDigit (head hex_str) then hex_str + else '0':hex_str + where hex_str = showHex (ord c) "U" + -- ToDo: we could improve the encoding here in various ways. + -- eg. strings of unicode characters come out as 'z1234Uz5678U', we + -- could remove the 'U' in the middle (the 'z' works as a separator). + +zDecodeString :: EncodedString -> UserString +zDecodeString [] = [] +zDecodeString ('Z' : d : rest) + | isDigit d = decode_tuple d rest + | otherwise = decode_upper d : zDecodeString rest +zDecodeString ('z' : d : rest) + | isDigit d = decode_num_esc d rest + | otherwise = decode_lower d : zDecodeString rest +zDecodeString (c : rest) = c : zDecodeString rest + +decode_upper, decode_lower :: Char -> Char + +decode_upper 'L' = '(' +decode_upper 'R' = ')' +decode_upper 'M' = '[' +decode_upper 'N' = ']' +decode_upper 'C' = ':' +decode_upper 'Z' = 'Z' +decode_upper ch = {-pprTrace "decode_upper" (char ch)-} ch + +decode_lower 'z' = 'z' +decode_lower 'a' = '&' +decode_lower 'b' = '|' +decode_lower 'c' = '^' +decode_lower 'd' = '$' +decode_lower 'e' = '=' +decode_lower 'g' = '>' +decode_lower 'h' = '#' +decode_lower 'i' = '.' +decode_lower 'l' = '<' +decode_lower 'm' = '-' +decode_lower 'n' = '!' +decode_lower 'p' = '+' +decode_lower 'q' = '\'' +decode_lower 'r' = '\\' +decode_lower 's' = '/' +decode_lower 't' = '*' +decode_lower 'u' = '_' +decode_lower 'v' = '%' +decode_lower ch = {-pprTrace "decode_lower" (char ch)-} ch + +-- Characters not having a specific code are coded as z224U (in hex) +decode_num_esc :: Char -> EncodedString -> UserString +decode_num_esc d rest + = go (digitToInt d) rest + where + go n (c : rest) | isHexDigit c = go (16*n + digitToInt c) rest + go n ('U' : rest) = chr n : zDecodeString rest + go n other = error ("decode_num_esc: " ++ show n ++ ' ':other) + +decode_tuple :: Char -> EncodedString -> UserString +decode_tuple d rest + = go (digitToInt d) rest + where + -- NB. recurse back to zDecodeString after decoding the tuple, because + -- the tuple might be embedded in a longer name. + go n (c : rest) | isDigit c = go (10*n + digitToInt c) rest + go 0 ('T':rest) = "()" ++ zDecodeString rest + go n ('T':rest) = '(' : replicate (n-1) ',' ++ ")" ++ zDecodeString rest + go 1 ('H':rest) = "(# #)" ++ zDecodeString rest + go n ('H':rest) = '(' : '#' : replicate (n-1) ',' ++ "#)" ++ zDecodeString rest + go n other = error ("decode_tuple: " ++ show n ++ ' ':other) + +{- +Tuples are encoded as + Z3T or Z3H +for 3-tuples or unboxed 3-tuples respectively. No other encoding starts + Z + +* "(# #)" is the tycon for an unboxed 1-tuple (not 0-tuple) + There are no unboxed 0-tuples. + +* "()" is the tycon for a boxed 0-tuple. + There are no boxed 1-tuples. +-} + +maybe_tuple :: UserString -> Maybe EncodedString + +maybe_tuple "(# #)" = Just("Z1H") +maybe_tuple ('(' : '#' : cs) = case count_commas (0::Int) cs of + (n, '#' : ')' : _) -> Just ('Z' : shows (n+1) "H") + _ -> Nothing +maybe_tuple "()" = Just("Z0T") +maybe_tuple ('(' : cs) = case count_commas (0::Int) cs of + (n, ')' : _) -> Just ('Z' : shows (n+1) "T") + _ -> Nothing +maybe_tuple _ = Nothing + +count_commas :: Int -> String -> (Int, String) +count_commas n (',' : cs) = count_commas (n+1) cs +count_commas n cs = (n,cs) + + +{- +************************************************************************ +* * + Base 62 +* * +************************************************************************ + +Note [Base 62 encoding 128-bit integers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Instead of base-62 encoding a single 128-bit integer +(ceil(21.49) characters), we'll base-62 a pair of 64-bit integers +(2 * ceil(10.75) characters). Luckily for us, it's the same number of +characters! +-} + +-------------------------------------------------------------------------- +-- Base 62 + +-- The base-62 code is based off of 'locators' +-- ((c) Operational Dynamics Consulting, BSD3 licensed) + +-- | Size of a 64-bit word when written as a base-62 string +word64Base62Len :: Int +word64Base62Len = 11 + +-- | Converts a 64-bit word into a base-62 string +toBase62Padded :: Word64 -> String +toBase62Padded w = pad ++ str + where + pad = replicate len '0' + len = word64Base62Len - length str -- 11 == ceil(64 / lg 62) + str = toBase62 w + +toBase62 :: Word64 -> String +toBase62 w = showIntAtBase 62 represent w "" + where + represent :: Int -> Char + represent x + | x < 10 = Char.chr (48 + x) + | x < 36 = Char.chr (65 + x - 10) + | x < 62 = Char.chr (97 + x - 36) + | otherwise = error "represent (base 62): impossible!" diff --git a/compiler/utils/EnumSet.hs b/compiler/utils/EnumSet.hs new file mode 100644 --- /dev/null +++ b/compiler/utils/EnumSet.hs @@ -0,0 +1,35 @@ +-- | A tiny wrapper around 'IntSet.IntSet' for representing sets of 'Enum' +-- things. +module EnumSet + ( EnumSet + , member + , insert + , delete + , toList + , fromList + , empty + ) where + +import GhcPrelude + +import qualified Data.IntSet as IntSet + +newtype EnumSet a = EnumSet IntSet.IntSet + +member :: Enum a => a -> EnumSet a -> Bool +member x (EnumSet s) = IntSet.member (fromEnum x) s + +insert :: Enum a => a -> EnumSet a -> EnumSet a +insert x (EnumSet s) = EnumSet $ IntSet.insert (fromEnum x) s + +delete :: Enum a => a -> EnumSet a -> EnumSet a +delete x (EnumSet s) = EnumSet $ IntSet.delete (fromEnum x) s + +toList :: Enum a => EnumSet a -> [a] +toList (EnumSet s) = map toEnum $ IntSet.toList s + +fromList :: Enum a => [a] -> EnumSet a +fromList = EnumSet . IntSet.fromList . map fromEnum + +empty :: EnumSet a +empty = EnumSet IntSet.empty diff --git a/compiler/utils/Exception.hs b/compiler/utils/Exception.hs new file mode 100644 --- /dev/null +++ b/compiler/utils/Exception.hs @@ -0,0 +1,83 @@ +{-# OPTIONS_GHC -fno-warn-deprecations #-} +module Exception + ( + module Control.Exception, + module Exception + ) + where + +import GhcPrelude + +import Control.Exception +import Control.Monad.IO.Class + +catchIO :: IO a -> (IOException -> IO a) -> IO a +catchIO = Control.Exception.catch + +handleIO :: (IOException -> IO a) -> IO a -> IO a +handleIO = flip catchIO + +tryIO :: IO a -> IO (Either IOException a) +tryIO = try + +-- | A monad that can catch exceptions. A minimal definition +-- requires a definition of 'gcatch'. +-- +-- Implementations on top of 'IO' should implement 'gmask' to +-- eventually call the primitive 'Control.Exception.mask'. +-- These are used for +-- implementations that support asynchronous exceptions. The default +-- implementations of 'gbracket' and 'gfinally' use 'gmask' +-- thus rarely require overriding. +-- +class MonadIO m => ExceptionMonad m where + + -- | Generalised version of 'Control.Exception.catch', allowing an arbitrary + -- exception handling monad instead of just 'IO'. + gcatch :: Exception e => m a -> (e -> m a) -> m a + + -- | Generalised version of 'Control.Exception.mask_', allowing an arbitrary + -- exception handling monad instead of just 'IO'. + gmask :: ((m a -> m a) -> m b) -> m b + + -- | Generalised version of 'Control.Exception.bracket', allowing an arbitrary + -- exception handling monad instead of just 'IO'. + gbracket :: m a -> (a -> m b) -> (a -> m c) -> m c + + -- | Generalised version of 'Control.Exception.finally', allowing an arbitrary + -- exception handling monad instead of just 'IO'. + gfinally :: m a -> m b -> m a + + gbracket before after thing = + gmask $ \restore -> do + a <- before + r <- restore (thing a) `gonException` after a + _ <- after a + return r + + a `gfinally` sequel = + gmask $ \restore -> do + r <- restore a `gonException` sequel + _ <- sequel + return r + +instance ExceptionMonad IO where + gcatch = Control.Exception.catch + gmask f = mask (\x -> f x) + +gtry :: (ExceptionMonad m, Exception e) => m a -> m (Either e a) +gtry act = gcatch (act >>= \a -> return (Right a)) + (\e -> return (Left e)) + +-- | Generalised version of 'Control.Exception.handle', allowing an arbitrary +-- exception handling monad instead of just 'IO'. +ghandle :: (ExceptionMonad m, Exception e) => (e -> m a) -> m a -> m a +ghandle = flip gcatch + +-- | Always executes the first argument. If this throws an exception the +-- second argument is executed and the exception is raised again. +gonException :: (ExceptionMonad m) => m a -> m b -> m a +gonException ioA cleanup = ioA `gcatch` \e -> + do _ <- cleanup + liftIO $ throwIO (e :: SomeException) + diff --git a/compiler/utils/FV.hs b/compiler/utils/FV.hs new file mode 100644 --- /dev/null +++ b/compiler/utils/FV.hs @@ -0,0 +1,201 @@ +{- +(c) Bartosz Nitka, Facebook 2015 + +Utilities for efficiently and deterministically computing free variables. + +-} + +{-# LANGUAGE BangPatterns #-} + +module FV ( + -- * Deterministic free vars computations + FV, InterestingVarFun, + + -- * Running the computations + fvVarListVarSet, fvVarList, fvVarSet, fvDVarSet, + + -- ** Manipulating those computations + unitFV, + emptyFV, + mkFVs, + unionFV, + unionsFV, + delFV, + delFVs, + filterFV, + mapUnionFV, + ) where + +import GhcPrelude + +import Var +import VarSet + +-- | Predicate on possible free variables: returns @True@ iff the variable is +-- interesting +type InterestingVarFun = Var -> Bool + +-- Note [Deterministic FV] +-- ~~~~~~~~~~~~~~~~~~~~~~~ +-- When computing free variables, the order in which you get them affects +-- the results of floating and specialization. If you use UniqFM to collect +-- them and then turn that into a list, you get them in nondeterministic +-- order as described in Note [Deterministic UniqFM] in UniqDFM. + +-- A naive algorithm for free variables relies on merging sets of variables. +-- Merging costs O(n+m) for UniqFM and for UniqDFM there's an additional log +-- factor. It's cheaper to incrementally add to a list and use a set to check +-- for duplicates. +type FV = InterestingVarFun + -- Used for filtering sets as we build them + -> VarSet + -- Locally bound variables + -> ([Var], VarSet) + -- List to preserve ordering and set to check for membership, + -- so that the list doesn't have duplicates + -- For explanation of why using `VarSet` is not deterministic see + -- Note [Deterministic UniqFM] in UniqDFM. + -> ([Var], VarSet) + +-- Note [FV naming conventions] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- To get the performance and determinism that FV provides, FV computations +-- need to built up from smaller FV computations and then evaluated with +-- one of `fvVarList`, `fvDVarSet`, `fvVarListVarSet`. That means the functions +-- returning FV need to be exported. +-- +-- The conventions are: +-- +-- a) non-deterministic functions: +-- * a function that returns VarSet +-- e.g. `tyVarsOfType` +-- b) deterministic functions: +-- * a worker that returns FV +-- e.g. `tyFVsOfType` +-- * a function that returns [Var] +-- e.g. `tyVarsOfTypeList` +-- * a function that returns DVarSet +-- e.g. `tyVarsOfTypeDSet` +-- +-- Where tyVarsOfType, tyVarsOfTypeList, tyVarsOfTypeDSet are implemented +-- in terms of the worker evaluated with fvVarSet, fvVarList, fvDVarSet +-- respectively. + +-- | Run a free variable computation, returning a list of distinct free +-- variables in deterministic order and a non-deterministic set containing +-- those variables. +fvVarListVarSet :: FV -> ([Var], VarSet) +fvVarListVarSet fv = fv (const True) emptyVarSet ([], emptyVarSet) + +-- | Run a free variable computation, returning a list of distinct free +-- variables in deterministic order. +fvVarList :: FV -> [Var] +fvVarList = fst . fvVarListVarSet + +-- | Run a free variable computation, returning a deterministic set of free +-- variables. Note that this is just a wrapper around the version that +-- returns a deterministic list. If you need a list you should use +-- `fvVarList`. +fvDVarSet :: FV -> DVarSet +fvDVarSet = mkDVarSet . fst . fvVarListVarSet + +-- | Run a free variable computation, returning a non-deterministic set of +-- free variables. Don't use if the set will be later converted to a list +-- and the order of that list will impact the generated code. +fvVarSet :: FV -> VarSet +fvVarSet = snd . fvVarListVarSet + +-- Note [FV eta expansion] +-- ~~~~~~~~~~~~~~~~~~~~~~~ +-- Let's consider an eta-reduced implementation of freeVarsOf using FV: +-- +-- freeVarsOf (App a b) = freeVarsOf a `unionFV` freeVarsOf b +-- +-- If GHC doesn't eta-expand it, after inlining unionFV we end up with +-- +-- freeVarsOf = \x -> +-- case x of +-- App a b -> \fv_cand in_scope acc -> +-- freeVarsOf a fv_cand in_scope $! freeVarsOf b fv_cand in_scope $! acc +-- +-- which has to create a thunk, resulting in more allocations. +-- +-- On the other hand if it is eta-expanded: +-- +-- freeVarsOf (App a b) fv_cand in_scope acc = +-- (freeVarsOf a `unionFV` freeVarsOf b) fv_cand in_scope acc +-- +-- after inlining unionFV we have: +-- +-- freeVarsOf = \x fv_cand in_scope acc -> +-- case x of +-- App a b -> +-- freeVarsOf a fv_cand in_scope $! freeVarsOf b fv_cand in_scope $! acc +-- +-- which saves allocations. +-- +-- GHC when presented with knowledge about all the call sites, correctly +-- eta-expands in this case. Unfortunately due to the fact that freeVarsOf gets +-- exported to be composed with other functions, GHC doesn't have that +-- information and has to be more conservative here. +-- +-- Hence functions that get exported and return FV need to be manually +-- eta-expanded. See also #11146. + +-- | Add a variable - when free, to the returned free variables. +-- Ignores duplicates and respects the filtering function. +unitFV :: Id -> FV +unitFV var fv_cand in_scope acc@(have, haveSet) + | var `elemVarSet` in_scope = acc + | var `elemVarSet` haveSet = acc + | fv_cand var = (var:have, extendVarSet haveSet var) + | otherwise = acc +{-# INLINE unitFV #-} + +-- | Return no free variables. +emptyFV :: FV +emptyFV _ _ acc = acc +{-# INLINE emptyFV #-} + +-- | Union two free variable computations. +unionFV :: FV -> FV -> FV +unionFV fv1 fv2 fv_cand in_scope acc = + fv1 fv_cand in_scope $! fv2 fv_cand in_scope $! acc +{-# INLINE unionFV #-} + +-- | Mark the variable as not free by putting it in scope. +delFV :: Var -> FV -> FV +delFV var fv fv_cand !in_scope acc = + fv fv_cand (extendVarSet in_scope var) acc +{-# INLINE delFV #-} + +-- | Mark many free variables as not free. +delFVs :: VarSet -> FV -> FV +delFVs vars fv fv_cand !in_scope acc = + fv fv_cand (in_scope `unionVarSet` vars) acc +{-# INLINE delFVs #-} + +-- | Filter a free variable computation. +filterFV :: InterestingVarFun -> FV -> FV +filterFV fv_cand2 fv fv_cand1 in_scope acc = + fv (\v -> fv_cand1 v && fv_cand2 v) in_scope acc +{-# INLINE filterFV #-} + +-- | Map a free variable computation over a list and union the results. +mapUnionFV :: (a -> FV) -> [a] -> FV +mapUnionFV _f [] _fv_cand _in_scope acc = acc +mapUnionFV f (a:as) fv_cand in_scope acc = + mapUnionFV f as fv_cand in_scope $! f a fv_cand in_scope $! acc +{-# INLINABLE mapUnionFV #-} + +-- | Union many free variable computations. +unionsFV :: [FV] -> FV +unionsFV fvs fv_cand in_scope acc = mapUnionFV id fvs fv_cand in_scope acc +{-# INLINE unionsFV #-} + +-- | Add multiple variables - when free, to the returned free variables. +-- Ignores duplicates and respects the filtering function. +mkFVs :: [Var] -> FV +mkFVs vars fv_cand in_scope acc = + mapUnionFV unitFV vars fv_cand in_scope acc +{-# INLINE mkFVs #-} diff --git a/compiler/utils/FastFunctions.hs b/compiler/utils/FastFunctions.hs new file mode 100644 --- /dev/null +++ b/compiler/utils/FastFunctions.hs @@ -0,0 +1,21 @@ +{- +(c) The University of Glasgow, 2000-2006 +-} + +{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-} + +module FastFunctions ( + inlinePerformIO, + ) where + +#include "HsVersions.h" + +import GhcPrelude () + +import GHC.Exts +import GHC.IO (IO(..)) + +-- Just like unsafeDupablePerformIO, but we inline it. +{-# INLINE inlinePerformIO #-} +inlinePerformIO :: IO a -> a +inlinePerformIO (IO m) = case m realWorld# of (# _, r #) -> r diff --git a/compiler/utils/FastMutInt.hs b/compiler/utils/FastMutInt.hs new file mode 100644 --- /dev/null +++ b/compiler/utils/FastMutInt.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-} +{-# OPTIONS_GHC -O2 #-} +-- We always optimise this, otherwise performance of a non-optimised +-- compiler is severely affected +-- +-- (c) The University of Glasgow 2002-2006 +-- +-- Unboxed mutable Ints + +module FastMutInt( + FastMutInt, newFastMutInt, + readFastMutInt, writeFastMutInt, + + FastMutPtr, newFastMutPtr, + readFastMutPtr, writeFastMutPtr + ) where + +import GhcPrelude + +import Data.Bits +import GHC.Base +import GHC.Ptr + +newFastMutInt :: IO FastMutInt +readFastMutInt :: FastMutInt -> IO Int +writeFastMutInt :: FastMutInt -> Int -> IO () + +newFastMutPtr :: IO FastMutPtr +readFastMutPtr :: FastMutPtr -> IO (Ptr a) +writeFastMutPtr :: FastMutPtr -> Ptr a -> IO () + +data FastMutInt = FastMutInt (MutableByteArray# RealWorld) + +newFastMutInt = IO $ \s -> + case newByteArray# size s of { (# s, arr #) -> + (# s, FastMutInt arr #) } + where !(I# size) = finiteBitSize (0 :: Int) + +readFastMutInt (FastMutInt arr) = IO $ \s -> + case readIntArray# arr 0# s of { (# s, i #) -> + (# s, I# i #) } + +writeFastMutInt (FastMutInt arr) (I# i) = IO $ \s -> + case writeIntArray# arr 0# i s of { s -> + (# s, () #) } + +data FastMutPtr = FastMutPtr (MutableByteArray# RealWorld) + +newFastMutPtr = IO $ \s -> + case newByteArray# size s of { (# s, arr #) -> + (# s, FastMutPtr arr #) } + -- GHC assumes 'sizeof (Int) == sizeof (Ptr a)' + where !(I# size) = finiteBitSize (0 :: Int) + +readFastMutPtr (FastMutPtr arr) = IO $ \s -> + case readAddrArray# arr 0# s of { (# s, i #) -> + (# s, Ptr i #) } + +writeFastMutPtr (FastMutPtr arr) (Ptr i) = IO $ \s -> + case writeAddrArray# arr 0# i s of { s -> + (# s, () #) } diff --git a/compiler/utils/FastString.hs b/compiler/utils/FastString.hs new file mode 100644 --- /dev/null +++ b/compiler/utils/FastString.hs @@ -0,0 +1,686 @@ +-- (c) The University of Glasgow, 1997-2006 + +{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples, + GeneralizedNewtypeDeriving #-} +{-# OPTIONS_GHC -O2 -funbox-strict-fields #-} +-- We always optimise this, otherwise performance of a non-optimised +-- compiler is severely affected + +-- | +-- There are two principal string types used internally by GHC: +-- +-- ['FastString'] +-- +-- * A compact, hash-consed, representation of character strings. +-- * Comparison is O(1), and you can get a 'Unique.Unique' from them. +-- * Generated by 'fsLit'. +-- * Turn into 'Outputable.SDoc' with 'Outputable.ftext'. +-- +-- ['PtrString'] +-- +-- * Pointer and size of a Latin-1 encoded string. +-- * Practically no operations. +-- * Outputing them is fast. +-- * Generated by 'sLit'. +-- * Turn into 'Outputable.SDoc' with 'Outputable.ptext' +-- * Requires manual memory management. +-- Improper use may lead to memory leaks or dangling pointers. +-- * It assumes Latin-1 as the encoding, therefore it cannot represent +-- arbitrary Unicode strings. +-- +-- Use 'PtrString' unless you want the facilities of 'FastString'. +module FastString + ( + -- * ByteString + bytesFS, -- :: FastString -> ByteString + fastStringToByteString, -- = bytesFS (kept for haddock) + mkFastStringByteString, + fastZStringToByteString, + unsafeMkByteString, + + -- * FastZString + FastZString, + hPutFZS, + zString, + lengthFZS, + + -- * FastStrings + FastString(..), -- not abstract, for now. + + -- ** Construction + fsLit, + mkFastString, + mkFastStringBytes, + mkFastStringByteList, + mkFastStringForeignPtr, + mkFastString#, + + -- ** Deconstruction + unpackFS, -- :: FastString -> String + + -- ** Encoding + zEncodeFS, + + -- ** Operations + uniqueOfFS, + lengthFS, + nullFS, + appendFS, + headFS, + tailFS, + concatFS, + consFS, + nilFS, + isUnderscoreFS, + + -- ** Outputing + hPutFS, + + -- ** Internal + getFastStringTable, + hasZEncoding, + + -- * PtrStrings + PtrString (..), + + -- ** Construction + sLit, + mkPtrString#, + mkPtrString, + + -- ** Deconstruction + unpackPtrString, + + -- ** Operations + lengthPS + ) where + +#include "HsVersions.h" + +import GhcPrelude as Prelude + +import Encoding +import FastFunctions +import Panic +import Util + +import Control.Concurrent.MVar +import Control.DeepSeq +import Control.Monad +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Internal as BS +import qualified Data.ByteString.Unsafe as BS +import Foreign.C +import GHC.Exts +import System.IO +import Data.Data +import Data.IORef +import Data.Maybe ( isJust ) +import Data.Char +import Data.Semigroup as Semi + +import GHC.IO + +import Foreign + +#if STAGE >= 2 +import GHC.Conc.Sync (sharedCAF) +#endif + +import GHC.Base ( unpackCString#, unpackNBytes# ) + + +-- | Gives the UTF-8 encoded bytes corresponding to a 'FastString' +bytesFS :: FastString -> ByteString +bytesFS f = fs_bs f + +{-# DEPRECATED fastStringToByteString "Use `bytesFS` instead" #-} +fastStringToByteString :: FastString -> ByteString +fastStringToByteString = bytesFS + +fastZStringToByteString :: FastZString -> ByteString +fastZStringToByteString (FastZString bs) = bs + +-- This will drop information if any character > '\xFF' +unsafeMkByteString :: String -> ByteString +unsafeMkByteString = BSC.pack + +hashFastString :: FastString -> Int +hashFastString (FastString _ _ bs _) + = inlinePerformIO $ BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> + return $ hashStr (castPtr ptr) len + +-- ----------------------------------------------------------------------------- + +newtype FastZString = FastZString ByteString + deriving NFData + +hPutFZS :: Handle -> FastZString -> IO () +hPutFZS handle (FastZString bs) = BS.hPut handle bs + +zString :: FastZString -> String +zString (FastZString bs) = + inlinePerformIO $ BS.unsafeUseAsCStringLen bs peekCAStringLen + +lengthFZS :: FastZString -> Int +lengthFZS (FastZString bs) = BS.length bs + +mkFastZStringString :: String -> FastZString +mkFastZStringString str = FastZString (BSC.pack str) + +-- ----------------------------------------------------------------------------- + +{-| +A 'FastString' is an array of bytes, hashed to support fast O(1) +comparison. It is also associated with a character encoding, so that +we know how to convert a 'FastString' to the local encoding, or to the +Z-encoding used by the compiler internally. + +'FastString's support a memoized conversion to the Z-encoding via zEncodeFS. +-} + +data FastString = FastString { + uniq :: {-# UNPACK #-} !Int, -- unique id + n_chars :: {-# UNPACK #-} !Int, -- number of chars + fs_bs :: {-# UNPACK #-} !ByteString, + fs_ref :: {-# UNPACK #-} !(IORef (Maybe FastZString)) + } + +instance Eq FastString where + f1 == f2 = uniq f1 == uniq f2 + +instance Ord FastString where + -- Compares lexicographically, not by unique + a <= b = case cmpFS a b of { LT -> True; EQ -> True; GT -> False } + a < b = case cmpFS a b of { LT -> True; EQ -> False; GT -> False } + a >= b = case cmpFS a b of { LT -> False; EQ -> True; GT -> True } + a > b = case cmpFS a b of { LT -> False; EQ -> False; GT -> True } + max x y | x >= y = x + | otherwise = y + min x y | x <= y = x + | otherwise = y + compare a b = cmpFS a b + +instance IsString FastString where + fromString = fsLit + +instance Semi.Semigroup FastString where + (<>) = appendFS + +instance Monoid FastString where + mempty = nilFS + mappend = (Semi.<>) + mconcat = concatFS + +instance Show FastString where + show fs = show (unpackFS fs) + +instance Data FastString where + -- don't traverse? + toConstr _ = abstractConstr "FastString" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "FastString" + +cmpFS :: FastString -> FastString -> Ordering +cmpFS f1@(FastString u1 _ _ _) f2@(FastString u2 _ _ _) = + if u1 == u2 then EQ else + compare (bytesFS f1) (bytesFS f2) + +foreign import ccall unsafe "memcmp" + memcmp :: Ptr a -> Ptr b -> Int -> IO Int + +-- ----------------------------------------------------------------------------- +-- Construction + +{- +Internally, the compiler will maintain a fast string symbol table, providing +sharing and fast comparison. Creation of new @FastString@s then covertly does a +lookup, re-using the @FastString@ if there was a hit. + +The design of the FastString hash table allows for lockless concurrent reads +and updates to multiple buckets with low synchronization overhead. + +See Note [Updating the FastString table] on how it's updated. +-} +data FastStringTable = FastStringTable + {-# UNPACK #-} !(IORef Int) -- the unique ID counter shared with all buckets + (Array# (IORef FastStringTableSegment)) -- concurrent segments + +data FastStringTableSegment = FastStringTableSegment + {-# UNPACK #-} !(MVar ()) -- the lock for write in each segment + {-# UNPACK #-} !(IORef Int) -- the number of elements + (MutableArray# RealWorld [FastString]) -- buckets in this segment + +{- +Following parameters are determined based on: + +* Benchmark based on testsuite/tests/utils/should_run/T14854.hs +* Stats of @echo :browse | ghc --interactive -dfaststring-stats >/dev/null@: + on 2018-10-24, we have 13920 entries. +-} +segmentBits, numSegments, segmentMask, initialNumBuckets :: Int +segmentBits = 8 +numSegments = 256 -- bit segmentBits +segmentMask = 0xff -- bit segmentBits - 1 +initialNumBuckets = 64 + +hashToSegment# :: Int# -> Int# +hashToSegment# hash# = hash# `andI#` segmentMask# + where + !(I# segmentMask#) = segmentMask + +hashToIndex# :: MutableArray# RealWorld [FastString] -> Int# -> Int# +hashToIndex# buckets# hash# = + (hash# `uncheckedIShiftRL#` segmentBits#) `remInt#` size# + where + !(I# segmentBits#) = segmentBits + size# = sizeofMutableArray# buckets# + +maybeResizeSegment :: IORef FastStringTableSegment -> IO FastStringTableSegment +maybeResizeSegment segmentRef = do + segment@(FastStringTableSegment lock counter old#) <- readIORef segmentRef + let oldSize# = sizeofMutableArray# old# + newSize# = oldSize# *# 2# + (I# n#) <- readIORef counter + if isTrue# (n# <# newSize#) -- maximum load of 1 + then return segment + else do + resizedSegment@(FastStringTableSegment _ _ new#) <- IO $ \s1# -> + case newArray# newSize# [] s1# of + (# s2#, arr# #) -> (# s2#, FastStringTableSegment lock counter arr# #) + forM_ [0 .. (I# oldSize#) - 1] $ \(I# i#) -> do + fsList <- IO $ readArray# old# i# + forM_ fsList $ \fs -> do + let -- Shall we store in hash value in FastString instead? + !(I# hash#) = hashFastString fs + idx# = hashToIndex# new# hash# + IO $ \s1# -> + case readArray# new# idx# s1# of + (# s2#, bucket #) -> case writeArray# new# idx# (fs: bucket) s2# of + s3# -> (# s3#, () #) + writeIORef segmentRef resizedSegment + return resizedSegment + +{-# NOINLINE stringTable #-} +stringTable :: FastStringTable +stringTable = unsafePerformIO $ do + let !(I# numSegments#) = numSegments + !(I# initialNumBuckets#) = initialNumBuckets + loop a# i# s1# + | isTrue# (i# ==# numSegments#) = s1# + | otherwise = case newMVar () `unIO` s1# of + (# s2#, lock #) -> case newIORef 0 `unIO` s2# of + (# s3#, counter #) -> case newArray# initialNumBuckets# [] s3# of + (# s4#, buckets# #) -> case newIORef + (FastStringTableSegment lock counter buckets#) `unIO` s4# of + (# s5#, segment #) -> case writeArray# a# i# segment s5# of + s6# -> loop a# (i# +# 1#) s6# + uid <- newIORef 603979776 -- ord '$' * 0x01000000 + tab <- IO $ \s1# -> + case newArray# numSegments# (panic "string_table") s1# of + (# s2#, arr# #) -> case loop arr# 0# s2# of + s3# -> case unsafeFreezeArray# arr# s3# of + (# s4#, segments# #) -> (# s4#, FastStringTable uid segments# #) + + -- use the support wired into the RTS to share this CAF among all images of + -- libHSghc +#if STAGE < 2 + return tab +#else + sharedCAF tab getOrSetLibHSghcFastStringTable + +-- from the RTS; thus we cannot use this mechanism when STAGE<2; the previous +-- RTS might not have this symbol +foreign import ccall unsafe "getOrSetLibHSghcFastStringTable" + getOrSetLibHSghcFastStringTable :: Ptr a -> IO (Ptr a) +#endif + +{- + +We include the FastString table in the `sharedCAF` mechanism because we'd like +FastStrings created by a Core plugin to have the same uniques as corresponding +strings created by the host compiler itself. For example, this allows plugins +to lookup known names (eg `mkTcOcc "MySpecialType"`) in the GlobalRdrEnv or +even re-invoke the parser. + +In particular, the following little sanity test was failing in a plugin +prototyping safe newtype-coercions: GHC.NT.Type.NT was imported, but could not +be looked up /by the plugin/. + + let rdrName = mkModuleName "GHC.NT.Type" `mkRdrQual` mkTcOcc "NT" + putMsgS $ showSDoc dflags $ ppr $ lookupGRE_RdrName rdrName $ mg_rdr_env guts + +`mkTcOcc` involves the lookup (or creation) of a FastString. Since the +plugin's FastString.string_table is empty, constructing the RdrName also +allocates new uniques for the FastStrings "GHC.NT.Type" and "NT". These +uniques are almost certainly unequal to the ones that the host compiler +originally assigned to those FastStrings. Thus the lookup fails since the +domain of the GlobalRdrEnv is affected by the RdrName's OccName's FastString's +unique. + +Maintaining synchronization of the two instances of this global is rather +difficult because of the uses of `unsafePerformIO` in this module. Not +synchronizing them risks breaking the rather major invariant that two +FastStrings with the same unique have the same string. Thus we use the +lower-level `sharedCAF` mechanism that relies on Globals.c. + +-} + +mkFastString# :: Addr# -> FastString +mkFastString# a# = mkFastStringBytes ptr (ptrStrLength ptr) + where ptr = Ptr a# + +{- Note [Updating the FastString table] + +We use a concurrent hashtable which contains multiple segments, each hash value +always maps to the same segment. Read is lock-free, write to the a segment +should acquire a lock for that segment to avoid race condition, writes to +different segments are independent. + +The procedure goes like this: + +1. Find out which segment to operate on based on the hash value +2. Read the relevant bucket and perform a look up of the string. +3. If it exists, return it. +4. Otherwise grab a unique ID, create a new FastString and atomically attempt + to update the relevant segment with this FastString: + + * Resize the segment by doubling the number of buckets when the number of + FastStrings in this segment grows beyond the threshold. + * Double check that the string is not in the bucket. Another thread may have + inserted it while we were creating our string. + * Return the existing FastString if it exists. The one we preemptively + created will get GCed. + * Otherwise, insert and return the string we created. +-} + +mkFastStringWith :: (Int -> IO FastString) -> Ptr Word8 -> Int -> IO FastString +mkFastStringWith mk_fs !ptr !len = do + FastStringTableSegment lock _ buckets# <- readIORef segmentRef + let idx# = hashToIndex# buckets# hash# + bucket <- IO $ readArray# buckets# idx# + res <- bucket_match bucket len ptr + case res of + Just found -> return found + Nothing -> do + -- The withMVar below is not dupable. It can lead to deadlock if it is + -- only run partially and putMVar is not called after takeMVar. + noDuplicate + n <- get_uid + new_fs <- mk_fs n + withMVar lock $ \_ -> insert new_fs + where + !(FastStringTable uid segments#) = stringTable + get_uid = atomicModifyIORef' uid $ \n -> (n+1,n) + + !(I# hash#) = hashStr ptr len + (# segmentRef #) = indexArray# segments# (hashToSegment# hash#) + insert fs = do + FastStringTableSegment _ counter buckets# <- maybeResizeSegment segmentRef + let idx# = hashToIndex# buckets# hash# + bucket <- IO $ readArray# buckets# idx# + res <- bucket_match bucket len ptr + case res of + -- The FastString was added by another thread after previous read and + -- before we acquired the write lock. + Just found -> return found + Nothing -> do + IO $ \s1# -> + case writeArray# buckets# idx# (fs: bucket) s1# of + s2# -> (# s2#, () #) + modifyIORef' counter succ + return fs + +bucket_match :: [FastString] -> Int -> Ptr Word8 -> IO (Maybe FastString) +bucket_match [] _ _ = return Nothing +bucket_match (v@(FastString _ _ bs _):ls) len ptr + | len == BS.length bs = do + b <- BS.unsafeUseAsCString bs $ \buf -> + cmpStringPrefix ptr (castPtr buf) len + if b then return (Just v) + else bucket_match ls len ptr + | otherwise = + bucket_match ls len ptr + +mkFastStringBytes :: Ptr Word8 -> Int -> FastString +mkFastStringBytes !ptr !len = + -- NB: Might as well use unsafeDupablePerformIO, since mkFastStringWith is + -- idempotent. + unsafeDupablePerformIO $ + mkFastStringWith (copyNewFastString ptr len) ptr len + +-- | Create a 'FastString' from an existing 'ForeignPtr'; the difference +-- between this and 'mkFastStringBytes' is that we don't have to copy +-- the bytes if the string is new to the table. +mkFastStringForeignPtr :: Ptr Word8 -> ForeignPtr Word8 -> Int -> IO FastString +mkFastStringForeignPtr ptr !fp len + = mkFastStringWith (mkNewFastString fp ptr len) ptr len + +-- | Create a 'FastString' from an existing 'ForeignPtr'; the difference +-- between this and 'mkFastStringBytes' is that we don't have to copy +-- the bytes if the string is new to the table. +mkFastStringByteString :: ByteString -> FastString +mkFastStringByteString bs = + inlinePerformIO $ + BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> do + let ptr' = castPtr ptr + mkFastStringWith (mkNewFastStringByteString bs ptr' len) ptr' len + +-- | Creates a UTF-8 encoded 'FastString' from a 'String' +mkFastString :: String -> FastString +mkFastString str = + inlinePerformIO $ do + let l = utf8EncodedLength str + buf <- mallocForeignPtrBytes l + withForeignPtr buf $ \ptr -> do + utf8EncodeString ptr str + mkFastStringForeignPtr ptr buf l + +-- | Creates a 'FastString' from a UTF-8 encoded @[Word8]@ +mkFastStringByteList :: [Word8] -> FastString +mkFastStringByteList str = mkFastStringByteString (BS.pack str) + +-- | Creates a Z-encoded 'FastString' from a 'String' +mkZFastString :: String -> FastZString +mkZFastString = mkFastZStringString + +mkNewFastString :: ForeignPtr Word8 -> Ptr Word8 -> Int -> Int + -> IO FastString +mkNewFastString fp ptr len uid = do + ref <- newIORef Nothing + n_chars <- countUTF8Chars ptr len + return (FastString uid n_chars (BS.fromForeignPtr fp 0 len) ref) + +mkNewFastStringByteString :: ByteString -> Ptr Word8 -> Int -> Int + -> IO FastString +mkNewFastStringByteString bs ptr len uid = do + ref <- newIORef Nothing + n_chars <- countUTF8Chars ptr len + return (FastString uid n_chars bs ref) + +copyNewFastString :: Ptr Word8 -> Int -> Int -> IO FastString +copyNewFastString ptr len uid = do + fp <- copyBytesToForeignPtr ptr len + ref <- newIORef Nothing + n_chars <- countUTF8Chars ptr len + return (FastString uid n_chars (BS.fromForeignPtr fp 0 len) ref) + +copyBytesToForeignPtr :: Ptr Word8 -> Int -> IO (ForeignPtr Word8) +copyBytesToForeignPtr ptr len = do + fp <- mallocForeignPtrBytes len + withForeignPtr fp $ \ptr' -> copyBytes ptr' ptr len + return fp + +cmpStringPrefix :: Ptr Word8 -> Ptr Word8 -> Int -> IO Bool +cmpStringPrefix ptr1 ptr2 len = + do r <- memcmp ptr1 ptr2 len + return (r == 0) + + +hashStr :: Ptr Word8 -> Int -> Int + -- use the Addr to produce a hash value between 0 & m (inclusive) +hashStr (Ptr a#) (I# len#) = loop 0# 0# + where + loop h n | isTrue# (n ==# len#) = I# h + | otherwise = loop h2 (n +# 1#) + where + !c = ord# (indexCharOffAddr# a# n) + !h2 = (h *# 16777619#) `xorI#` c + +-- ----------------------------------------------------------------------------- +-- Operations + +-- | Returns the length of the 'FastString' in characters +lengthFS :: FastString -> Int +lengthFS f = n_chars f + +-- | Returns @True@ if this 'FastString' is not Z-encoded but already has +-- a Z-encoding cached (used in producing stats). +hasZEncoding :: FastString -> Bool +hasZEncoding (FastString _ _ _ ref) = + inlinePerformIO $ do + m <- readIORef ref + return (isJust m) + +-- | Returns @True@ if the 'FastString' is empty +nullFS :: FastString -> Bool +nullFS f = BS.null (fs_bs f) + +-- | Unpacks and decodes the FastString +unpackFS :: FastString -> String +unpackFS (FastString _ _ bs _) = utf8DecodeByteString bs + +-- | Returns a Z-encoded version of a 'FastString'. This might be the +-- original, if it was already Z-encoded. The first time this +-- function is applied to a particular 'FastString', the results are +-- memoized. +-- +zEncodeFS :: FastString -> FastZString +zEncodeFS fs@(FastString _ _ _ ref) = + inlinePerformIO $ do + m <- readIORef ref + case m of + Just zfs -> return zfs + Nothing -> do + atomicModifyIORef' ref $ \m' -> case m' of + Nothing -> let zfs = mkZFastString (zEncodeString (unpackFS fs)) + in (Just zfs, zfs) + Just zfs -> (m', zfs) + +appendFS :: FastString -> FastString -> FastString +appendFS fs1 fs2 = mkFastStringByteString + $ BS.append (bytesFS fs1) (bytesFS fs2) + +concatFS :: [FastString] -> FastString +concatFS = mkFastStringByteString . BS.concat . map fs_bs + +headFS :: FastString -> Char +headFS (FastString _ 0 _ _) = panic "headFS: Empty FastString" +headFS (FastString _ _ bs _) = + inlinePerformIO $ BS.unsafeUseAsCString bs $ \ptr -> + return (fst (utf8DecodeChar (castPtr ptr))) + +tailFS :: FastString -> FastString +tailFS (FastString _ 0 _ _) = panic "tailFS: Empty FastString" +tailFS (FastString _ _ bs _) = + inlinePerformIO $ BS.unsafeUseAsCString bs $ \ptr -> + do let (_, n) = utf8DecodeChar (castPtr ptr) + return $! mkFastStringByteString (BS.drop n bs) + +consFS :: Char -> FastString -> FastString +consFS c fs = mkFastString (c : unpackFS fs) + +uniqueOfFS :: FastString -> Int +uniqueOfFS (FastString u _ _ _) = u + +nilFS :: FastString +nilFS = mkFastString "" + +isUnderscoreFS :: FastString -> Bool +isUnderscoreFS fs = fs == fsLit "_" + +-- ----------------------------------------------------------------------------- +-- Stats + +getFastStringTable :: IO [[[FastString]]] +getFastStringTable = + forM [0 .. numSegments - 1] $ \(I# i#) -> do + let (# segmentRef #) = indexArray# segments# i# + FastStringTableSegment _ _ buckets# <- readIORef segmentRef + let bucketSize = I# (sizeofMutableArray# buckets#) + forM [0 .. bucketSize - 1] $ \(I# j#) -> + IO $ readArray# buckets# j# + where + !(FastStringTable _ segments#) = stringTable + +-- ----------------------------------------------------------------------------- +-- Outputting 'FastString's + +-- |Outputs a 'FastString' with /no decoding at all/, that is, you +-- get the actual bytes in the 'FastString' written to the 'Handle'. +hPutFS :: Handle -> FastString -> IO () +hPutFS handle fs = BS.hPut handle $ bytesFS fs + +-- ToDo: we'll probably want an hPutFSLocal, or something, to output +-- in the current locale's encoding (for error messages and suchlike). + +-- ----------------------------------------------------------------------------- +-- PtrStrings, here for convenience only. + +-- | A 'PtrString' is a pointer to some array of Latin-1 encoded chars. +data PtrString = PtrString !(Ptr Word8) !Int + +-- | Wrap an unboxed address into a 'PtrString'. +mkPtrString# :: Addr# -> PtrString +mkPtrString# a# = PtrString (Ptr a#) (ptrStrLength (Ptr a#)) + +-- | Encode a 'String' into a newly allocated 'PtrString' using Latin-1 +-- encoding. The original string must not contain non-Latin-1 characters +-- (above codepoint @0xff@). +{-# INLINE mkPtrString #-} +mkPtrString :: String -> PtrString +mkPtrString s = + -- we don't use `unsafeDupablePerformIO` here to avoid potential memory leaks + -- and because someone might be using `eqAddr#` to check for string equality. + unsafePerformIO (do + let len = length s + p <- mallocBytes len + let + loop :: Int -> String -> IO () + loop !_ [] = return () + loop n (c:cs) = do + pokeByteOff p n (fromIntegral (ord c) :: Word8) + loop (1+n) cs + loop 0 s + return (PtrString p len) + ) + +-- | Decode a 'PtrString' back into a 'String' using Latin-1 encoding. +-- This does not free the memory associated with 'PtrString'. +unpackPtrString :: PtrString -> String +unpackPtrString (PtrString (Ptr p#) (I# n#)) = unpackNBytes# p# n# + +-- | Return the length of a 'PtrString' +lengthPS :: PtrString -> Int +lengthPS (PtrString _ n) = n + +-- ----------------------------------------------------------------------------- +-- under the carpet + +foreign import ccall unsafe "strlen" + ptrStrLength :: Ptr Word8 -> Int + +{-# NOINLINE sLit #-} +sLit :: String -> PtrString +sLit x = mkPtrString x + +{-# NOINLINE fsLit #-} +fsLit :: String -> FastString +fsLit x = mkFastString x + +{-# RULES "slit" + forall x . sLit (unpackCString# x) = mkPtrString# x #-} +{-# RULES "fslit" + forall x . fsLit (unpackCString# x) = mkFastString# x #-} diff --git a/compiler/utils/FastStringEnv.hs b/compiler/utils/FastStringEnv.hs new file mode 100644 --- /dev/null +++ b/compiler/utils/FastStringEnv.hs @@ -0,0 +1,100 @@ +{- +% +% (c) The University of Glasgow 2006 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +\section[FastStringEnv]{@FastStringEnv@: FastString environments} +-} + +module FastStringEnv ( + -- * FastString environments (maps) + FastStringEnv, + + -- ** Manipulating these environments + mkFsEnv, + emptyFsEnv, unitFsEnv, + extendFsEnv_C, extendFsEnv_Acc, extendFsEnv, + extendFsEnvList, extendFsEnvList_C, + filterFsEnv, + plusFsEnv, plusFsEnv_C, alterFsEnv, + lookupFsEnv, lookupFsEnv_NF, delFromFsEnv, delListFromFsEnv, + elemFsEnv, mapFsEnv, + + -- * Deterministic FastString environments (maps) + DFastStringEnv, + + -- ** Manipulating these environments + mkDFsEnv, emptyDFsEnv, dFsEnvElts, lookupDFsEnv + ) where + +import GhcPrelude + +import UniqFM +import UniqDFM +import Maybes +import FastString + + +-- | A non-deterministic set of FastStrings. +-- See Note [Deterministic UniqFM] in UniqDFM for explanation why it's not +-- deterministic and why it matters. Use DFastStringEnv if the set eventually +-- gets converted into a list or folded over in a way where the order +-- changes the generated code. +type FastStringEnv a = UniqFM a -- Domain is FastString + +emptyFsEnv :: FastStringEnv a +mkFsEnv :: [(FastString,a)] -> FastStringEnv a +alterFsEnv :: (Maybe a-> Maybe a) -> FastStringEnv a -> FastString -> FastStringEnv a +extendFsEnv_C :: (a->a->a) -> FastStringEnv a -> FastString -> a -> FastStringEnv a +extendFsEnv_Acc :: (a->b->b) -> (a->b) -> FastStringEnv b -> FastString -> a -> FastStringEnv b +extendFsEnv :: FastStringEnv a -> FastString -> a -> FastStringEnv a +plusFsEnv :: FastStringEnv a -> FastStringEnv a -> FastStringEnv a +plusFsEnv_C :: (a->a->a) -> FastStringEnv a -> FastStringEnv a -> FastStringEnv a +extendFsEnvList :: FastStringEnv a -> [(FastString,a)] -> FastStringEnv a +extendFsEnvList_C :: (a->a->a) -> FastStringEnv a -> [(FastString,a)] -> FastStringEnv a +delFromFsEnv :: FastStringEnv a -> FastString -> FastStringEnv a +delListFromFsEnv :: FastStringEnv a -> [FastString] -> FastStringEnv a +elemFsEnv :: FastString -> FastStringEnv a -> Bool +unitFsEnv :: FastString -> a -> FastStringEnv a +lookupFsEnv :: FastStringEnv a -> FastString -> Maybe a +lookupFsEnv_NF :: FastStringEnv a -> FastString -> a +filterFsEnv :: (elt -> Bool) -> FastStringEnv elt -> FastStringEnv elt +mapFsEnv :: (elt1 -> elt2) -> FastStringEnv elt1 -> FastStringEnv elt2 + +emptyFsEnv = emptyUFM +unitFsEnv x y = unitUFM x y +extendFsEnv x y z = addToUFM x y z +extendFsEnvList x l = addListToUFM x l +lookupFsEnv x y = lookupUFM x y +alterFsEnv = alterUFM +mkFsEnv l = listToUFM l +elemFsEnv x y = elemUFM x y +plusFsEnv x y = plusUFM x y +plusFsEnv_C f x y = plusUFM_C f x y +extendFsEnv_C f x y z = addToUFM_C f x y z +mapFsEnv f x = mapUFM f x +extendFsEnv_Acc x y z a b = addToUFM_Acc x y z a b +extendFsEnvList_C x y z = addListToUFM_C x y z +delFromFsEnv x y = delFromUFM x y +delListFromFsEnv x y = delListFromUFM x y +filterFsEnv x y = filterUFM x y + +lookupFsEnv_NF env n = expectJust "lookupFsEnv_NF" (lookupFsEnv env n) + +-- Deterministic FastStringEnv +-- See Note [Deterministic UniqFM] in UniqDFM for explanation why we need +-- DFastStringEnv. + +type DFastStringEnv a = UniqDFM a -- Domain is FastString + +emptyDFsEnv :: DFastStringEnv a +emptyDFsEnv = emptyUDFM + +dFsEnvElts :: DFastStringEnv a -> [a] +dFsEnvElts = eltsUDFM + +mkDFsEnv :: [(FastString,a)] -> DFastStringEnv a +mkDFsEnv l = listToUDFM l + +lookupDFsEnv :: DFastStringEnv a -> FastString -> Maybe a +lookupDFsEnv = lookupUDFM diff --git a/compiler/utils/Fingerprint.hsc b/compiler/utils/Fingerprint.hsc new file mode 100644 --- /dev/null +++ b/compiler/utils/Fingerprint.hsc @@ -0,0 +1,47 @@ +{-# 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 "md5.h" +##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 diff --git a/compiler/utils/FiniteMap.hs b/compiler/utils/FiniteMap.hs new file mode 100644 --- /dev/null +++ b/compiler/utils/FiniteMap.hs @@ -0,0 +1,31 @@ +-- Some extra functions to extend Data.Map + +module FiniteMap ( + insertList, + insertListWith, + deleteList, + foldRight, foldRightWithKey + ) where + +import GhcPrelude + +import Data.Map (Map) +import qualified Data.Map as Map + +insertList :: Ord key => [(key,elt)] -> Map key elt -> Map key elt +insertList xs m = foldl' (\m (k, v) -> Map.insert k v m) m xs + +insertListWith :: Ord key + => (elt -> elt -> elt) + -> [(key,elt)] + -> Map key elt + -> Map key elt +insertListWith f xs m0 = foldl' (\m (k, v) -> Map.insertWith f k v m) m0 xs + +deleteList :: Ord key => [key] -> Map key elt -> Map key elt +deleteList ks m = foldl' (flip Map.delete) m ks + +foldRight :: (elt -> a -> a) -> a -> Map key elt -> a +foldRight = Map.foldr +foldRightWithKey :: (key -> elt -> a -> a) -> a -> Map key elt -> a +foldRightWithKey = Map.foldrWithKey diff --git a/compiler/utils/GhcPrelude.hs b/compiler/utils/GhcPrelude.hs new file mode 100644 --- /dev/null +++ b/compiler/utils/GhcPrelude.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE CPP #-} + +-- | Custom GHC "Prelude" +-- +-- This module serves as a replacement for the "Prelude" module +-- and abstracts over differences between the bootstrapping +-- GHC version, and may also provide a common default vocabulary. + +-- Every module in GHC +-- * Is compiled with -XNoImplicitPrelude +-- * Explicitly imports GhcPrelude + +module GhcPrelude (module X) where + +-- We export the 'Semigroup' class but w/o the (<>) operator to avoid +-- clashing with the (Outputable.<>) operator which is heavily used +-- through GHC's code-base. + +import Prelude as X hiding ((<>)) +import Data.Foldable as X (foldl') + +{- +Note [Why do we import Prelude here?] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The files ghc-boot-th.cabal, ghc-boot.cabal, ghci.cabal and +ghc-heap.cabal contain the directive default-extensions: +NoImplicitPrelude. There are two motivations for this: + - Consistency with the compiler directory, which enables + NoImplicitPrelude; + - Allows loading the above dependent packages with ghc-in-ghci, + giving a smoother development experience when adding new + extensions. +-} diff --git a/compiler/utils/IOEnv.hs b/compiler/utils/IOEnv.hs new file mode 100644 --- /dev/null +++ b/compiler/utils/IOEnv.hs @@ -0,0 +1,225 @@ +{-# LANGUAGE CPP #-} +-- +-- (c) The University of Glasgow 2002-2006 +-- +-- The IO Monad with an environment +-- +-- The environment is passed around as a Reader monad but +-- as its in the IO monad, mutable references can be used +-- for updating state. +-- + +module IOEnv ( + IOEnv, -- Instance of Monad + + -- Monad utilities + module MonadUtils, + + -- Errors + failM, failWithM, + IOEnvFailure(..), + + -- Getting at the environment + getEnv, setEnv, updEnv, + + runIOEnv, unsafeInterleaveM, uninterruptibleMaskM_, + tryM, tryAllM, tryMostM, fixM, + + -- I/O operations + IORef, newMutVar, readMutVar, writeMutVar, updMutVar, + atomicUpdMutVar, atomicUpdMutVar' + ) where + +import GhcPrelude + +import DynFlags +import Exception +import Module +import Panic + +import Data.IORef ( IORef, newIORef, readIORef, writeIORef, modifyIORef, + atomicModifyIORef, atomicModifyIORef' ) +import System.IO.Unsafe ( unsafeInterleaveIO ) +import System.IO ( fixIO ) +import Control.Monad +import qualified Control.Monad.Fail as MonadFail +import MonadUtils +import Control.Applicative (Alternative(..)) + +---------------------------------------------------------------------- +-- Defining the monad type +---------------------------------------------------------------------- + + +newtype IOEnv env a = IOEnv (env -> IO a) + +unIOEnv :: IOEnv env a -> (env -> IO a) +unIOEnv (IOEnv m) = m + +instance Monad (IOEnv m) where + (>>=) = thenM + (>>) = (*>) +#if !MIN_VERSION_base(4,13,0) + fail = MonadFail.fail +#endif + +instance MonadFail.MonadFail (IOEnv m) where + fail _ = failM -- Ignore the string + +instance Applicative (IOEnv m) where + pure = returnM + IOEnv f <*> IOEnv x = IOEnv (\ env -> f env <*> x env ) + (*>) = thenM_ + +instance Functor (IOEnv m) where + fmap f (IOEnv m) = IOEnv (\ env -> fmap f (m env)) + +returnM :: a -> IOEnv env a +returnM a = IOEnv (\ _ -> return a) + +thenM :: IOEnv env a -> (a -> IOEnv env b) -> IOEnv env b +thenM (IOEnv m) f = IOEnv (\ env -> do { r <- m env ; + unIOEnv (f r) env }) + +thenM_ :: IOEnv env a -> IOEnv env b -> IOEnv env b +thenM_ (IOEnv m) f = IOEnv (\ env -> do { _ <- m env ; unIOEnv f env }) + +failM :: IOEnv env a +failM = IOEnv (\ _ -> throwIO IOEnvFailure) + +failWithM :: String -> IOEnv env a +failWithM s = IOEnv (\ _ -> ioError (userError s)) + +data IOEnvFailure = IOEnvFailure + +instance Show IOEnvFailure where + show IOEnvFailure = "IOEnv failure" + +instance Exception IOEnvFailure + +instance ExceptionMonad (IOEnv a) where + gcatch act handle = + IOEnv $ \s -> unIOEnv act s `gcatch` \e -> unIOEnv (handle e) s + gmask f = + IOEnv $ \s -> gmask $ \io_restore -> + let + g_restore (IOEnv m) = IOEnv $ \s -> io_restore (m s) + in + unIOEnv (f g_restore) s + +instance ContainsDynFlags env => HasDynFlags (IOEnv env) where + getDynFlags = do env <- getEnv + return $! extractDynFlags env + +instance ContainsModule env => HasModule (IOEnv env) where + getModule = do env <- getEnv + return $ extractModule env + +---------------------------------------------------------------------- +-- Fundamental combinators specific to the monad +---------------------------------------------------------------------- + + +--------------------------- +runIOEnv :: env -> IOEnv env a -> IO a +runIOEnv env (IOEnv m) = m env + + +--------------------------- +{-# NOINLINE fixM #-} + -- Aargh! Not inlining fixM alleviates a space leak problem. + -- Normally fixM is used with a lazy tuple match: if the optimiser is + -- shown the definition of fixM, it occasionally transforms the code + -- in such a way that the code generator doesn't spot the selector + -- thunks. Sigh. + +fixM :: (a -> IOEnv env a) -> IOEnv env a +fixM f = IOEnv (\ env -> fixIO (\ r -> unIOEnv (f r) env)) + + +--------------------------- +tryM :: IOEnv env r -> IOEnv env (Either IOEnvFailure r) +-- Reflect UserError exceptions (only) into IOEnv monad +-- Other exceptions are not caught; they are simply propagated as exns +-- +-- The idea is that errors in the program being compiled will give rise +-- to UserErrors. But, say, pattern-match failures in GHC itself should +-- not be caught here, else they'll be reported as errors in the program +-- begin compiled! +tryM (IOEnv thing) = IOEnv (\ env -> tryIOEnvFailure (thing env)) + +tryIOEnvFailure :: IO a -> IO (Either IOEnvFailure a) +tryIOEnvFailure = try + +-- XXX We shouldn't be catching everything, e.g. timeouts +tryAllM :: IOEnv env r -> IOEnv env (Either SomeException r) +-- Catch *all* exceptions +-- This is used when running a Template-Haskell splice, when +-- even a pattern-match failure is a programmer error +tryAllM (IOEnv thing) = IOEnv (\ env -> try (thing env)) + +tryMostM :: IOEnv env r -> IOEnv env (Either SomeException r) +tryMostM (IOEnv thing) = IOEnv (\ env -> tryMost (thing env)) + +--------------------------- +unsafeInterleaveM :: IOEnv env a -> IOEnv env a +unsafeInterleaveM (IOEnv m) = IOEnv (\ env -> unsafeInterleaveIO (m env)) + +uninterruptibleMaskM_ :: IOEnv env a -> IOEnv env a +uninterruptibleMaskM_ (IOEnv m) = IOEnv (\ env -> uninterruptibleMask_ (m env)) + +---------------------------------------------------------------------- +-- Alternative/MonadPlus +---------------------------------------------------------------------- + +instance Alternative (IOEnv env) where + empty = IOEnv (const empty) + m <|> n = IOEnv (\env -> unIOEnv m env <|> unIOEnv n env) + +instance MonadPlus (IOEnv env) + +---------------------------------------------------------------------- +-- Accessing input/output +---------------------------------------------------------------------- + +instance MonadIO (IOEnv env) where + liftIO io = IOEnv (\ _ -> io) + +newMutVar :: a -> IOEnv env (IORef a) +newMutVar val = liftIO (newIORef val) + +writeMutVar :: IORef a -> a -> IOEnv env () +writeMutVar var val = liftIO (writeIORef var val) + +readMutVar :: IORef a -> IOEnv env a +readMutVar var = liftIO (readIORef var) + +updMutVar :: IORef a -> (a -> a) -> IOEnv env () +updMutVar var upd = liftIO (modifyIORef var upd) + +-- | Atomically update the reference. Does not force the evaluation of the +-- new variable contents. For strict update, use 'atomicUpdMutVar''. +atomicUpdMutVar :: IORef a -> (a -> (a, b)) -> IOEnv env b +atomicUpdMutVar var upd = liftIO (atomicModifyIORef var upd) + +-- | Strict variant of 'atomicUpdMutVar'. +atomicUpdMutVar' :: IORef a -> (a -> (a, b)) -> IOEnv env b +atomicUpdMutVar' var upd = liftIO (atomicModifyIORef' var upd) + +---------------------------------------------------------------------- +-- Accessing the environment +---------------------------------------------------------------------- + +getEnv :: IOEnv env env +{-# INLINE getEnv #-} +getEnv = IOEnv (\ env -> return env) + +-- | Perform a computation with a different environment +setEnv :: env' -> IOEnv env' a -> IOEnv env a +{-# INLINE setEnv #-} +setEnv new_env (IOEnv m) = IOEnv (\ _ -> m new_env) + +-- | Perform a computation with an altered environment +updEnv :: (env -> env') -> IOEnv env' a -> IOEnv env a +{-# INLINE updEnv #-} +updEnv upd (IOEnv m) = IOEnv (\ env -> m (upd env)) diff --git a/compiler/utils/Json.hs b/compiler/utils/Json.hs new file mode 100644 --- /dev/null +++ b/compiler/utils/Json.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE GADTs #-} +module Json where + +import GhcPrelude + +import Outputable +import Data.Char +import Numeric + +-- | Simple data type to represent JSON documents. +data JsonDoc where + JSNull :: JsonDoc + JSBool :: Bool -> JsonDoc + JSInt :: Int -> JsonDoc + JSString :: String -> JsonDoc + JSArray :: [JsonDoc] -> JsonDoc + JSObject :: [(String, JsonDoc)] -> JsonDoc + + +-- This is simple and slow as it is only used for error reporting +renderJSON :: JsonDoc -> SDoc +renderJSON d = + case d of + JSNull -> text "null" + JSBool b -> text $ if b then "true" else "false" + JSInt n -> ppr n + JSString s -> doubleQuotes $ text $ escapeJsonString s + JSArray as -> brackets $ pprList renderJSON as + JSObject fs -> braces $ pprList renderField fs + where + renderField :: (String, JsonDoc) -> SDoc + renderField (s, j) = doubleQuotes (text s) <> colon <+> renderJSON j + + pprList pp xs = hcat (punctuate comma (map pp xs)) + +escapeJsonString :: String -> String +escapeJsonString = concatMap escapeChar + where + escapeChar '\b' = "\\b" + escapeChar '\f' = "\\f" + escapeChar '\n' = "\\n" + escapeChar '\r' = "\\r" + escapeChar '\t' = "\\t" + escapeChar '"' = "\\\"" + escapeChar '\\' = "\\\\" + escapeChar c | isControl c || fromEnum c >= 0x7f = uni_esc c + escapeChar c = [c] + + uni_esc c = "\\u" ++ (pad 4 (showHex (fromEnum c) "")) + + pad n cs | len < n = replicate (n-len) '0' ++ cs + | otherwise = cs + where len = length cs + +class ToJson a where + json :: a -> JsonDoc diff --git a/compiler/utils/ListSetOps.hs b/compiler/utils/ListSetOps.hs new file mode 100644 --- /dev/null +++ b/compiler/utils/ListSetOps.hs @@ -0,0 +1,171 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 + +\section[ListSetOps]{Set-like operations on lists} +-} + +{-# LANGUAGE CPP #-} + +module ListSetOps ( + unionLists, minusList, deleteBys, + + -- Association lists + Assoc, assoc, assocMaybe, assocUsing, assocDefault, assocDefaultUsing, + + -- Duplicate handling + hasNoDups, removeDups, findDupsEq, + equivClasses, + + -- Indexing + getNth + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import Outputable +import Util + +import Data.List +import qualified Data.List.NonEmpty as NE +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.Set as S + +getNth :: Outputable a => [a] -> Int -> a +getNth xs n = ASSERT2( xs `lengthExceeds` n, ppr n $$ ppr xs ) + xs !! n + +deleteBys :: (a -> a -> Bool) -> [a] -> [a] -> [a] +-- (deleteBys eq xs ys) returns xs-ys, using the given equality function +-- Just like 'Data.List.delete' but with an equality function +deleteBys eq xs ys = foldl' (flip (deleteBy eq)) xs ys + +{- +************************************************************************ +* * + Treating lists as sets + Assumes the lists contain no duplicates, but are unordered +* * +************************************************************************ +-} + + +unionLists :: (Outputable a, Eq a) => [a] -> [a] -> [a] +-- Assumes that the arguments contain no duplicates +unionLists xs ys + = WARN(lengthExceeds xs 100 || lengthExceeds ys 100, ppr xs $$ ppr ys) + [x | x <- xs, isn'tIn "unionLists" x ys] ++ ys + +-- | Calculate the set difference of two lists. This is +-- /O((m + n) log n)/, where we subtract a list of /n/ elements +-- from a list of /m/ elements. +-- +-- Extremely short cases are handled specially: +-- When /m/ or /n/ is 0, this takes /O(1)/ time. When /m/ is 1, +-- it takes /O(n)/ time. +minusList :: Ord a => [a] -> [a] -> [a] +-- There's no point building a set to perform just one lookup, so we handle +-- extremely short lists specially. It might actually be better to use +-- an O(m*n) algorithm when m is a little longer (perhaps up to 4 or even 5). +-- The tipping point will be somewhere in the area of where /m/ and /log n/ +-- become comparable, but we probably don't want to work too hard on this. +minusList [] _ = [] +minusList xs@[x] ys + | x `elem` ys = [] + | otherwise = xs +-- Using an empty set or a singleton would also be silly, so let's not. +minusList xs [] = xs +minusList xs [y] = filter (/= y) xs +-- When each list has at least two elements, we build a set from the +-- second argument, allowing us to filter the first argument fairly +-- efficiently. +minusList xs ys = filter (`S.notMember` yss) xs + where + yss = S.fromList ys + +{- +************************************************************************ +* * +\subsection[Utils-assoc]{Association lists} +* * +************************************************************************ + +Inefficient finite maps based on association lists and equality. +-} + +-- A finite mapping based on equality and association lists +type Assoc a b = [(a,b)] + +assoc :: (Eq a) => String -> Assoc a b -> a -> b +assocDefault :: (Eq a) => b -> Assoc a b -> a -> b +assocUsing :: (a -> a -> Bool) -> String -> Assoc a b -> a -> b +assocMaybe :: (Eq a) => Assoc a b -> a -> Maybe b +assocDefaultUsing :: (a -> a -> Bool) -> b -> Assoc a b -> a -> b + +assocDefaultUsing _ deflt [] _ = deflt +assocDefaultUsing eq deflt ((k,v) : rest) key + | k `eq` key = v + | otherwise = assocDefaultUsing eq deflt rest key + +assoc crash_msg list key = assocDefaultUsing (==) (panic ("Failed in assoc: " ++ crash_msg)) list key +assocDefault deflt list key = assocDefaultUsing (==) deflt list key +assocUsing eq crash_msg list key = assocDefaultUsing eq (panic ("Failed in assoc: " ++ crash_msg)) list key + +assocMaybe alist key + = lookup alist + where + lookup [] = Nothing + lookup ((tv,ty):rest) = if key == tv then Just ty else lookup rest + +{- +************************************************************************ +* * +\subsection[Utils-dups]{Duplicate-handling} +* * +************************************************************************ +-} + +hasNoDups :: (Eq a) => [a] -> Bool + +hasNoDups xs = f [] xs + where + f _ [] = True + f seen_so_far (x:xs) = if x `is_elem` seen_so_far + then False + else f (x:seen_so_far) xs + + is_elem = isIn "hasNoDups" + +equivClasses :: (a -> a -> Ordering) -- Comparison + -> [a] + -> [NonEmpty a] + +equivClasses _ [] = [] +equivClasses _ [stuff] = [stuff :| []] +equivClasses cmp items = NE.groupBy eq (sortBy cmp items) + where + eq a b = case cmp a b of { EQ -> True; _ -> False } + +removeDups :: (a -> a -> Ordering) -- Comparison function + -> [a] + -> ([a], -- List with no duplicates + [NonEmpty a]) -- List of duplicate groups. One representative + -- from each group appears in the first result + +removeDups _ [] = ([], []) +removeDups _ [x] = ([x],[]) +removeDups cmp xs + = case (mapAccumR collect_dups [] (equivClasses cmp xs)) of { (dups, xs') -> + (xs', dups) } + where + collect_dups :: [NonEmpty a] -> NonEmpty a -> ([NonEmpty a], a) + collect_dups dups_so_far (x :| []) = (dups_so_far, x) + collect_dups dups_so_far dups@(x :| _) = (dups:dups_so_far, x) + +findDupsEq :: (a->a->Bool) -> [a] -> [NonEmpty a] +findDupsEq _ [] = [] +findDupsEq eq (x:xs) | null eq_xs = findDupsEq eq xs + | otherwise = (x :| eq_xs) : findDupsEq eq neq_xs + where (eq_xs, neq_xs) = partition (eq x) xs diff --git a/compiler/utils/Maybes.hs b/compiler/utils/Maybes.hs new file mode 100644 --- /dev/null +++ b/compiler/utils/Maybes.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE FlexibleContexts #-} + +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +module Maybes ( + module Data.Maybe, + + MaybeErr(..), -- Instance of Monad + failME, isSuccess, + + orElse, + firstJust, firstJusts, + whenIsJust, + expectJust, + rightToMaybe, + + -- * MaybeT + MaybeT(..), liftMaybeT, tryMaybeT + ) where + +import GhcPrelude + +import Control.Monad +import Control.Monad.Trans.Maybe +import Control.Exception (catch, SomeException(..)) +import Data.Maybe +import Util (HasCallStack) + +infixr 4 `orElse` + +{- +************************************************************************ +* * +\subsection[Maybe type]{The @Maybe@ type} +* * +************************************************************************ +-} + +firstJust :: Maybe a -> Maybe a -> Maybe a +firstJust a b = firstJusts [a, b] + +-- | Takes a list of @Maybes@ and returns the first @Just@ if there is one, or +-- @Nothing@ otherwise. +firstJusts :: [Maybe a] -> Maybe a +firstJusts = msum + +expectJust :: HasCallStack => String -> Maybe a -> a +{-# INLINE expectJust #-} +expectJust _ (Just x) = x +expectJust err Nothing = error ("expectJust " ++ err) + +whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m () +whenIsJust (Just x) f = f x +whenIsJust Nothing _ = return () + +-- | Flipped version of @fromMaybe@, useful for chaining. +orElse :: Maybe a -> a -> a +orElse = flip fromMaybe + +rightToMaybe :: Either a b -> Maybe b +rightToMaybe (Left _) = Nothing +rightToMaybe (Right x) = Just x + +{- +************************************************************************ +* * +\subsection[MaybeT type]{The @MaybeT@ monad transformer} +* * +************************************************************************ +-} + +-- We had our own MaybeT in the past. Now we reuse transformer's MaybeT + +liftMaybeT :: Monad m => m a -> MaybeT m a +liftMaybeT act = MaybeT $ Just `liftM` act + +-- | Try performing an 'IO' action, failing on error. +tryMaybeT :: IO a -> MaybeT IO a +tryMaybeT action = MaybeT $ catch (Just `fmap` action) handler + where + handler (SomeException _) = return Nothing + +{- +************************************************************************ +* * +\subsection[MaybeErr type]{The @MaybeErr@ type} +* * +************************************************************************ +-} + +data MaybeErr err val = Succeeded val | Failed err + +instance Functor (MaybeErr err) where + fmap = liftM + +instance Applicative (MaybeErr err) where + pure = Succeeded + (<*>) = ap + +instance Monad (MaybeErr err) where + Succeeded v >>= k = k v + Failed e >>= _ = Failed e + +isSuccess :: MaybeErr err val -> Bool +isSuccess (Succeeded {}) = True +isSuccess (Failed {}) = False + +failME :: err -> MaybeErr err val +failME e = Failed e diff --git a/compiler/utils/MonadUtils.hs b/compiler/utils/MonadUtils.hs new file mode 100644 --- /dev/null +++ b/compiler/utils/MonadUtils.hs @@ -0,0 +1,247 @@ +-- | Utilities related to Monad and Applicative classes +-- Mostly for backwards compatibility. + +module MonadUtils + ( Applicative(..) + , (<$>) + + , MonadFix(..) + , MonadIO(..) + + , liftIO1, liftIO2, liftIO3, liftIO4 + + , zipWith3M, zipWith3M_, zipWith4M, zipWithAndUnzipM + , mapAndUnzipM, mapAndUnzip3M, mapAndUnzip4M, mapAndUnzip5M + , mapAccumLM + , mapSndM + , concatMapM + , mapMaybeM + , fmapMaybeM, fmapEitherM + , anyM, allM, orM + , foldlM, foldlM_, foldrM + , maybeMapM + , whenM, unlessM + , filterOutM + ) where + +------------------------------------------------------------------------------- +-- Imports +------------------------------------------------------------------------------- + +import GhcPrelude + +import Control.Applicative +import Control.Monad +import Control.Monad.Fix +import Control.Monad.IO.Class +import Data.Foldable (sequenceA_) +import Data.List (unzip4, unzip5, zipWith4) + +------------------------------------------------------------------------------- +-- Lift combinators +-- These are used throughout the compiler +------------------------------------------------------------------------------- + +-- | Lift an 'IO' operation with 1 argument into another monad +liftIO1 :: MonadIO m => (a -> IO b) -> a -> m b +liftIO1 = (.) liftIO + +-- | Lift an 'IO' operation with 2 arguments into another monad +liftIO2 :: MonadIO m => (a -> b -> IO c) -> a -> b -> m c +liftIO2 = ((.).(.)) liftIO + +-- | Lift an 'IO' operation with 3 arguments into another monad +liftIO3 :: MonadIO m => (a -> b -> c -> IO d) -> a -> b -> c -> m d +liftIO3 = ((.).((.).(.))) liftIO + +-- | Lift an 'IO' operation with 4 arguments into another monad +liftIO4 :: MonadIO m => (a -> b -> c -> d -> IO e) -> a -> b -> c -> d -> m e +liftIO4 = (((.).(.)).((.).(.))) liftIO + +------------------------------------------------------------------------------- +-- Common functions +-- These are used throughout the compiler +------------------------------------------------------------------------------- + +{- + +Note [Inline @zipWithNM@ functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The inline principle for 'zipWith3M', 'zipWith4M' and 'zipWith3M_' is the same +as for 'zipWithM' and 'zipWithM_' in "Control.Monad", see +Note [Fusion for zipN/zipWithN] in GHC/List.hs for more details. + +The 'zipWithM'/'zipWithM_' functions are inlined so that the `zipWith` and +`sequenceA` functions with which they are defined have an opportunity to fuse. + +Furthermore, 'zipWith3M'/'zipWith4M' and 'zipWith3M_' have been explicitly +rewritten in a non-recursive way similarly to 'zipWithM'/'zipWithM_', and for +more than just uniformity: after [D5241](https://phabricator.haskell.org/D5241) +for issue #14037, all @zipN@/@zipWithN@ functions fuse, meaning +'zipWith3M'/'zipWIth4M' and 'zipWith3M_'@ now behave like 'zipWithM' and +'zipWithM_', respectively, with regards to fusion. + +As such, since there are not any differences between 2-ary 'zipWithM'/ +'zipWithM_' and their n-ary counterparts below aside from the number of +arguments, the `INLINE` pragma should be replicated in the @zipWithNM@ +functions below as well. + +-} + +zipWith3M :: Monad m => (a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m [d] +{-# INLINE zipWith3M #-} +-- Inline so that fusion with 'zipWith3' and 'sequenceA' has a chance to fire. +-- See Note [Inline @zipWithNM@ functions] above. +zipWith3M f xs ys zs = sequenceA (zipWith3 f xs ys zs) + +zipWith3M_ :: Monad m => (a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m () +{-# INLINE zipWith3M_ #-} +-- Inline so that fusion with 'zipWith4' and 'sequenceA' has a chance to fire. +-- See Note [Inline @zipWithNM@ functions] above. +zipWith3M_ f xs ys zs = sequenceA_ (zipWith3 f xs ys zs) + +zipWith4M :: Monad m => (a -> b -> c -> d -> m e) + -> [a] -> [b] -> [c] -> [d] -> m [e] +{-# INLINE zipWith4M #-} +-- Inline so that fusion with 'zipWith5' and 'sequenceA' has a chance to fire. +-- See Note [Inline @zipWithNM@ functions] above. +zipWith4M f xs ys ws zs = sequenceA (zipWith4 f xs ys ws zs) + +zipWithAndUnzipM :: Monad m + => (a -> b -> m (c, d)) -> [a] -> [b] -> m ([c], [d]) +{-# INLINABLE zipWithAndUnzipM #-} +-- See Note [flatten_many performance] in TcFlatten for why this +-- pragma is essential. +zipWithAndUnzipM f (x:xs) (y:ys) + = do { (c, d) <- f x y + ; (cs, ds) <- zipWithAndUnzipM f xs ys + ; return (c:cs, d:ds) } +zipWithAndUnzipM _ _ _ = return ([], []) + +{- + +Note [Inline @mapAndUnzipNM@ functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +The inline principle is the same as 'mapAndUnzipM' in "Control.Monad". +The 'mapAndUnzipM' function is inlined so that the `unzip` and `traverse` +functions with which it is defined have an opportunity to fuse, see +Note [Inline @unzipN@ functions] in Data/OldList.hs for more details. + +Furthermore, the @mapAndUnzipNM@ functions have been explicitly rewritten in a +non-recursive way similarly to 'mapAndUnzipM', and for more than just +uniformity: after [D5249](https://phabricator.haskell.org/D5249) for Trac +ticket #14037, all @unzipN@ functions fuse, meaning 'mapAndUnzip3M', +'mapAndUnzip4M' and 'mapAndUnzip5M' now behave like 'mapAndUnzipM' with regards +to fusion. + +As such, since there are not any differences between 2-ary 'mapAndUnzipM' and +its n-ary counterparts below aside from the number of arguments, the `INLINE` +pragma should be replicated in the @mapAndUnzipNM@ functions below as well. + +-} + +-- | mapAndUnzipM for triples +mapAndUnzip3M :: Monad m => (a -> m (b,c,d)) -> [a] -> m ([b],[c],[d]) +{-# INLINE mapAndUnzip3M #-} +-- Inline so that fusion with 'unzip3' and 'traverse' has a chance to fire. +-- See Note [Inline @mapAndUnzipNM@ functions] above. +mapAndUnzip3M f xs = unzip3 <$> traverse f xs + +mapAndUnzip4M :: Monad m => (a -> m (b,c,d,e)) -> [a] -> m ([b],[c],[d],[e]) +{-# INLINE mapAndUnzip4M #-} +-- Inline so that fusion with 'unzip4' and 'traverse' has a chance to fire. +-- See Note [Inline @mapAndUnzipNM@ functions] above. +mapAndUnzip4M f xs = unzip4 <$> traverse f xs + +mapAndUnzip5M :: Monad m => (a -> m (b,c,d,e,f)) -> [a] -> m ([b],[c],[d],[e],[f]) +{-# INLINE mapAndUnzip5M #-} +-- Inline so that fusion with 'unzip5' and 'traverse' has a chance to fire. +-- See Note [Inline @mapAndUnzipNM@ functions] above. +mapAndUnzip5M f xs = unzip5 <$> traverse f xs + +-- | Monadic version of mapAccumL +mapAccumLM :: Monad m + => (acc -> x -> m (acc, y)) -- ^ combining function + -> acc -- ^ initial state + -> [x] -- ^ inputs + -> m (acc, [y]) -- ^ final state, outputs +mapAccumLM _ s [] = return (s, []) +mapAccumLM f s (x:xs) = do + (s1, x') <- f s x + (s2, xs') <- mapAccumLM f s1 xs + return (s2, x' : xs') + +-- | Monadic version of mapSnd +mapSndM :: Monad m => (b -> m c) -> [(a,b)] -> m [(a,c)] +mapSndM _ [] = return [] +mapSndM f ((a,b):xs) = do { c <- f b; rs <- mapSndM f xs; return ((a,c):rs) } + +-- | Monadic version of concatMap +concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] +concatMapM f xs = liftM concat (mapM f xs) + +-- | Applicative version of mapMaybe +mapMaybeM :: Applicative m => (a -> m (Maybe b)) -> [a] -> m [b] +mapMaybeM f = foldr g (pure []) + where g a = liftA2 (maybe id (:)) (f a) + +-- | Monadic version of fmap +fmapMaybeM :: (Monad m) => (a -> m b) -> Maybe a -> m (Maybe b) +fmapMaybeM _ Nothing = return Nothing +fmapMaybeM f (Just x) = f x >>= (return . Just) + +-- | Monadic version of fmap +fmapEitherM :: Monad m => (a -> m b) -> (c -> m d) -> Either a c -> m (Either b d) +fmapEitherM fl _ (Left a) = fl a >>= (return . Left) +fmapEitherM _ fr (Right b) = fr b >>= (return . Right) + +-- | Monadic version of 'any', aborts the computation at the first @True@ value +anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool +anyM _ [] = return False +anyM f (x:xs) = do b <- f x + if b then return True + else anyM f xs + +-- | Monad version of 'all', aborts the computation at the first @False@ value +allM :: Monad m => (a -> m Bool) -> [a] -> m Bool +allM _ [] = return True +allM f (b:bs) = (f b) >>= (\bv -> if bv then allM f bs else return False) + +-- | Monadic version of or +orM :: Monad m => m Bool -> m Bool -> m Bool +orM m1 m2 = m1 >>= \x -> if x then return True else m2 + +-- | Monadic version of foldl +foldlM :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a +foldlM = foldM + +-- | Monadic version of foldl that discards its result +foldlM_ :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m () +foldlM_ = foldM_ + +-- | Monadic version of foldr +foldrM :: (Monad m) => (b -> a -> m a) -> a -> [b] -> m a +foldrM _ z [] = return z +foldrM k z (x:xs) = do { r <- foldrM k z xs; k x r } + +-- | Monadic version of fmap specialised for Maybe +maybeMapM :: Monad m => (a -> m b) -> (Maybe a -> m (Maybe b)) +maybeMapM _ Nothing = return Nothing +maybeMapM m (Just x) = liftM Just $ m x + +-- | Monadic version of @when@, taking the condition in the monad +whenM :: Monad m => m Bool -> m () -> m () +whenM mb thing = do { b <- mb + ; when b thing } + +-- | Monadic version of @unless@, taking the condition in the monad +unlessM :: Monad m => m Bool -> m () -> m () +unlessM condM acc = do { cond <- condM + ; unless cond acc } + +-- | Like 'filterM', only it reverses the sense of the test. +filterOutM :: (Applicative m) => (a -> m Bool) -> [a] -> m [a] +filterOutM p = + foldr (\ x -> liftA2 (\ flg -> if flg then id else (x:)) (p x)) (pure []) diff --git a/compiler/utils/OrdList.hs b/compiler/utils/OrdList.hs new file mode 100644 --- /dev/null +++ b/compiler/utils/OrdList.hs @@ -0,0 +1,154 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1993-1998 + + +This is useful, general stuff for the Native Code Generator. + +Provide trees (of instructions), so that lists of instructions +can be appended in linear time. +-} + +module OrdList ( + OrdList, + nilOL, isNilOL, unitOL, appOL, consOL, snocOL, concatOL, lastOL, + headOL, + mapOL, fromOL, toOL, foldrOL, foldlOL, reverseOL, fromOLReverse +) where + +import GhcPrelude + +import Outputable + +import qualified Data.Semigroup as Semigroup + +infixl 5 `appOL` +infixl 5 `snocOL` +infixr 5 `consOL` + +data OrdList a + = None + | One a + | Many [a] -- Invariant: non-empty + | Cons a (OrdList a) + | Snoc (OrdList a) a + | Two (OrdList a) -- Invariant: non-empty + (OrdList a) -- Invariant: non-empty + +instance Outputable a => Outputable (OrdList a) where + ppr ol = ppr (fromOL ol) -- Convert to list and print that + +instance Semigroup (OrdList a) where + (<>) = appOL + +instance Monoid (OrdList a) where + mempty = nilOL + mappend = (Semigroup.<>) + mconcat = concatOL + +instance Functor OrdList where + fmap = mapOL + +instance Foldable OrdList where + foldr = foldrOL + +instance Traversable OrdList where + traverse f xs = toOL <$> traverse f (fromOL xs) + +nilOL :: OrdList a +isNilOL :: OrdList a -> Bool + +unitOL :: a -> OrdList a +snocOL :: OrdList a -> a -> OrdList a +consOL :: a -> OrdList a -> OrdList a +appOL :: OrdList a -> OrdList a -> OrdList a +concatOL :: [OrdList a] -> OrdList a +headOL :: OrdList a -> a +lastOL :: OrdList a -> a + + +nilOL = None +unitOL as = One as +snocOL as b = Snoc as b +consOL a bs = Cons a bs +concatOL aas = foldr appOL None aas + +headOL None = panic "headOL" +headOL (One a) = a +headOL (Many as) = head as +headOL (Cons a _) = a +headOL (Snoc as _) = headOL as +headOL (Two as _) = headOL as + +lastOL None = panic "lastOL" +lastOL (One a) = a +lastOL (Many as) = last as +lastOL (Cons _ as) = lastOL as +lastOL (Snoc _ a) = a +lastOL (Two _ as) = lastOL as + +isNilOL None = True +isNilOL _ = False + +None `appOL` b = b +a `appOL` None = a +One a `appOL` b = Cons a b +a `appOL` One b = Snoc a b +a `appOL` b = Two a b + +fromOL :: OrdList a -> [a] +fromOL a = go a [] + where go None acc = acc + go (One a) acc = a : acc + go (Cons a b) acc = a : go b acc + go (Snoc a b) acc = go a (b:acc) + go (Two a b) acc = go a (go b acc) + go (Many xs) acc = xs ++ acc + +fromOLReverse :: OrdList a -> [a] +fromOLReverse a = go a [] + -- acc is already in reverse order + where go :: OrdList a -> [a] -> [a] + go None acc = acc + go (One a) acc = a : acc + go (Cons a b) acc = go b (a : acc) + go (Snoc a b) acc = b : go a acc + go (Two a b) acc = go b (go a acc) + go (Many xs) acc = reverse xs ++ acc + +mapOL :: (a -> b) -> OrdList a -> OrdList b +mapOL _ None = None +mapOL f (One x) = One (f x) +mapOL f (Cons x xs) = Cons (f x) (mapOL f xs) +mapOL f (Snoc xs x) = Snoc (mapOL f xs) (f x) +mapOL f (Two x y) = Two (mapOL f x) (mapOL f y) +mapOL f (Many xs) = Many (map f xs) + +foldrOL :: (a->b->b) -> b -> OrdList a -> b +foldrOL _ z None = z +foldrOL k z (One x) = k x z +foldrOL k z (Cons x xs) = k x (foldrOL k z xs) +foldrOL k z (Snoc xs x) = foldrOL k (k x z) xs +foldrOL k z (Two b1 b2) = foldrOL k (foldrOL k z b2) b1 +foldrOL k z (Many xs) = foldr k z xs + +foldlOL :: (b->a->b) -> b -> OrdList a -> b +foldlOL _ z None = z +foldlOL k z (One x) = k z x +foldlOL k z (Cons x xs) = foldlOL k (k z x) xs +foldlOL k z (Snoc xs x) = k (foldlOL k z xs) x +foldlOL k z (Two b1 b2) = foldlOL k (foldlOL k z b1) b2 +foldlOL k z (Many xs) = foldl k z xs + +toOL :: [a] -> OrdList a +toOL [] = None +toOL [x] = One x +toOL xs = Many xs + +reverseOL :: OrdList a -> OrdList a +reverseOL None = None +reverseOL (One x) = One x +reverseOL (Cons a b) = Snoc (reverseOL b) a +reverseOL (Snoc a b) = Cons b (reverseOL a) +reverseOL (Two a b) = Two (reverseOL b) (reverseOL a) +reverseOL (Many xs) = Many (reverse xs) diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs new file mode 100644 --- /dev/null +++ b/compiler/utils/Outputable.hs @@ -0,0 +1,1236 @@ +{- +(c) The University of Glasgow 2006-2012 +(c) The GRASP Project, Glasgow University, 1992-1998 +-} + +-- | This module defines classes and functions for pretty-printing. It also +-- exports a number of helpful debugging and other utilities such as 'trace' and 'panic'. +-- +-- The interface to this module is very similar to the standard Hughes-PJ pretty printing +-- module, except that it exports a number of additional functions that are rarely used, +-- and works over the 'SDoc' type. +module Outputable ( + -- * Type classes + Outputable(..), OutputableBndr(..), + + -- * Pretty printing combinators + SDoc, runSDoc, initSDocContext, + docToSDoc, + interppSP, interpp'SP, + pprQuotedList, pprWithCommas, quotedListWithOr, quotedListWithNor, + pprWithBars, + empty, isEmpty, nest, + char, + text, ftext, ptext, ztext, + int, intWithCommas, integer, word, float, double, rational, doublePrec, + parens, cparen, brackets, braces, quotes, quote, + doubleQuotes, angleBrackets, + semi, comma, colon, dcolon, space, equals, dot, vbar, + arrow, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt, + lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore, + blankLine, forAllLit, kindType, bullet, + (<>), (<+>), hcat, hsep, + ($$), ($+$), vcat, + sep, cat, + fsep, fcat, + hang, hangNotEmpty, punctuate, ppWhen, ppUnless, + speakNth, speakN, speakNOf, plural, isOrAre, doOrDoes, + unicodeSyntax, + + coloured, keyword, + + -- * Converting 'SDoc' into strings and outputing it + printSDoc, printSDocLn, printForUser, printForUserPartWay, + printForC, bufLeftRenderSDoc, + pprCode, mkCodeStyle, + showSDoc, showSDocUnsafe, showSDocOneLine, + showSDocForUser, showSDocDebug, showSDocDump, showSDocDumpOneLine, + showSDocUnqual, showPpr, + renderWithStyle, + + pprInfixVar, pprPrefixVar, + pprHsChar, pprHsString, pprHsBytes, + + primFloatSuffix, primCharSuffix, primWordSuffix, primDoubleSuffix, + primInt64Suffix, primWord64Suffix, primIntSuffix, + + pprPrimChar, pprPrimInt, pprPrimWord, pprPrimInt64, pprPrimWord64, + + pprFastFilePath, pprFilePathString, + + -- * Controlling the style in which output is printed + BindingSite(..), + + PprStyle, CodeStyle(..), PrintUnqualified(..), + QueryQualifyName, QueryQualifyModule, QueryQualifyPackage, + reallyAlwaysQualify, reallyAlwaysQualifyNames, + alwaysQualify, alwaysQualifyNames, alwaysQualifyModules, + neverQualify, neverQualifyNames, neverQualifyModules, + alwaysQualifyPackages, neverQualifyPackages, + QualifyName(..), queryQual, + sdocWithDynFlags, sdocWithPlatform, + updSDocDynFlags, + getPprStyle, withPprStyle, withPprStyleDoc, setStyleColoured, + pprDeeper, pprDeeperList, pprSetDepth, + codeStyle, userStyle, debugStyle, dumpStyle, asmStyle, + qualName, qualModule, qualPackage, + mkErrStyle, defaultErrStyle, defaultDumpStyle, mkDumpStyle, defaultUserStyle, + mkUserStyle, cmdlineParserStyle, Depth(..), + + ifPprDebug, whenPprDebug, getPprDebug, + + -- * Error handling and debugging utilities + pprPanic, pprSorry, assertPprPanic, pprPgmError, + pprTrace, pprTraceDebug, pprTraceIt, warnPprTrace, pprSTrace, + pprTraceException, pprTraceM, + trace, pgmError, panic, sorry, assertPanic, + pprDebugAndThen, callStackDoc, + ) where + +import GhcPrelude + +import {-# SOURCE #-} DynFlags( DynFlags, hasPprDebug, hasNoDebugOutput, + targetPlatform, pprUserLength, pprCols, + useUnicode, useUnicodeSyntax, useStarIsType, + shouldUseColor, unsafeGlobalDynFlags, + shouldUseHexWordLiterals ) +import {-# SOURCE #-} Module( UnitId, Module, ModuleName, moduleName ) +import {-# SOURCE #-} OccName( OccName ) + +import BufWrite (BufHandle) +import FastString +import qualified Pretty +import Util +import Platform +import qualified PprColour as Col +import Pretty ( Doc, Mode(..) ) +import Panic +import GHC.Serialized +import GHC.LanguageExtensions (Extension) + +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.Char +import qualified Data.Map as M +import Data.Int +import qualified Data.IntMap as IM +import Data.Set (Set) +import qualified Data.Set as Set +import Data.String +import Data.Word +import System.IO ( Handle ) +import System.FilePath +import Text.Printf +import Numeric (showFFloat) +import Data.Graph (SCC(..)) +import Data.List (intersperse) + +import GHC.Fingerprint +import GHC.Show ( showMultiLineString ) +import GHC.Stack ( callStack, prettyCallStack ) +import Control.Monad.IO.Class +import Exception + +{- +************************************************************************ +* * +\subsection{The @PprStyle@ data type} +* * +************************************************************************ +-} + +data PprStyle + = PprUser PrintUnqualified Depth Coloured + -- Pretty-print in a way that will make sense to the + -- ordinary user; must be very close to Haskell + -- syntax, etc. + -- Assumes printing tidied code: non-system names are + -- printed without uniques. + + | PprDump PrintUnqualified + -- For -ddump-foo; less verbose than PprDebug, but more than PprUser + -- Does not assume tidied code: non-external names + -- are printed with uniques. + + | PprDebug -- Full debugging output + + | PprCode CodeStyle + -- Print code; either C or assembler + +data CodeStyle = CStyle -- The format of labels differs for C and assembler + | AsmStyle + +data Depth = AllTheWay + | PartWay Int -- 0 => stop + +data Coloured + = Uncoloured + | Coloured + +-- ----------------------------------------------------------------------------- +-- Printing original names + +-- | When printing code that contains original names, we need to map the +-- original names back to something the user understands. This is the +-- purpose of the triple of functions that gets passed around +-- when rendering 'SDoc'. +data PrintUnqualified = QueryQualify { + queryQualifyName :: QueryQualifyName, + queryQualifyModule :: QueryQualifyModule, + queryQualifyPackage :: QueryQualifyPackage +} + +-- | Given a `Name`'s `Module` and `OccName`, decide whether and how to qualify +-- it. +type QueryQualifyName = Module -> OccName -> QualifyName + +-- | For a given module, we need to know whether to print it with +-- a package name to disambiguate it. +type QueryQualifyModule = Module -> Bool + +-- | For a given package, we need to know whether to print it with +-- the component id to disambiguate it. +type QueryQualifyPackage = UnitId -> Bool + +-- See Note [Printing original names] in HscTypes +data QualifyName -- Given P:M.T + = NameUnqual -- It's in scope unqualified as "T" + -- OR nothing called "T" is in scope + + | NameQual ModuleName -- It's in scope qualified as "X.T" + + | NameNotInScope1 -- It's not in scope at all, but M.T is not bound + -- in the current scope, so we can refer to it as "M.T" + + | NameNotInScope2 -- It's not in scope at all, and M.T is already bound in + -- the current scope, so we must refer to it as "P:M.T" + +instance Outputable QualifyName where + ppr NameUnqual = text "NameUnqual" + ppr (NameQual _mod) = text "NameQual" -- can't print the mod without module loops :( + ppr NameNotInScope1 = text "NameNotInScope1" + ppr NameNotInScope2 = text "NameNotInScope2" + +reallyAlwaysQualifyNames :: QueryQualifyName +reallyAlwaysQualifyNames _ _ = NameNotInScope2 + +-- | NB: This won't ever show package IDs +alwaysQualifyNames :: QueryQualifyName +alwaysQualifyNames m _ = NameQual (moduleName m) + +neverQualifyNames :: QueryQualifyName +neverQualifyNames _ _ = NameUnqual + +alwaysQualifyModules :: QueryQualifyModule +alwaysQualifyModules _ = True + +neverQualifyModules :: QueryQualifyModule +neverQualifyModules _ = False + +alwaysQualifyPackages :: QueryQualifyPackage +alwaysQualifyPackages _ = True + +neverQualifyPackages :: QueryQualifyPackage +neverQualifyPackages _ = False + +reallyAlwaysQualify, alwaysQualify, neverQualify :: PrintUnqualified +reallyAlwaysQualify + = QueryQualify reallyAlwaysQualifyNames + alwaysQualifyModules + alwaysQualifyPackages +alwaysQualify = QueryQualify alwaysQualifyNames + alwaysQualifyModules + alwaysQualifyPackages +neverQualify = QueryQualify neverQualifyNames + neverQualifyModules + neverQualifyPackages + +defaultUserStyle :: DynFlags -> PprStyle +defaultUserStyle dflags = mkUserStyle dflags neverQualify AllTheWay + +defaultDumpStyle :: DynFlags -> PprStyle + -- Print without qualifiers to reduce verbosity, unless -dppr-debug +defaultDumpStyle dflags + | hasPprDebug dflags = PprDebug + | otherwise = PprDump neverQualify + +mkDumpStyle :: DynFlags -> PrintUnqualified -> PprStyle +mkDumpStyle dflags print_unqual + | hasPprDebug dflags = PprDebug + | otherwise = PprDump print_unqual + +defaultErrStyle :: DynFlags -> PprStyle +-- Default style for error messages, when we don't know PrintUnqualified +-- It's a bit of a hack because it doesn't take into account what's in scope +-- Only used for desugarer warnings, and typechecker errors in interface sigs +-- NB that -dppr-debug will still get into PprDebug style +defaultErrStyle dflags = mkErrStyle dflags neverQualify + +-- | Style for printing error messages +mkErrStyle :: DynFlags -> PrintUnqualified -> PprStyle +mkErrStyle dflags qual = + mkUserStyle dflags qual (PartWay (pprUserLength dflags)) + +cmdlineParserStyle :: DynFlags -> PprStyle +cmdlineParserStyle dflags = mkUserStyle dflags alwaysQualify AllTheWay + +mkUserStyle :: DynFlags -> PrintUnqualified -> Depth -> PprStyle +mkUserStyle dflags unqual depth + | hasPprDebug dflags = PprDebug + | otherwise = PprUser unqual depth Uncoloured + +setStyleColoured :: Bool -> PprStyle -> PprStyle +setStyleColoured col style = + case style of + PprUser q d _ -> PprUser q d c + _ -> style + where + c | col = Coloured + | otherwise = Uncoloured + +instance Outputable PprStyle where + ppr (PprUser {}) = text "user-style" + ppr (PprCode {}) = text "code-style" + ppr (PprDump {}) = text "dump-style" + ppr (PprDebug {}) = text "debug-style" + +{- +Orthogonal to the above printing styles are (possibly) some +command-line flags that affect printing (often carried with the +style). The most likely ones are variations on how much type info is +shown. + +The following test decides whether or not we are actually generating +code (either C or assembly), or generating interface files. + +************************************************************************ +* * +\subsection{The @SDoc@ data type} +* * +************************************************************************ +-} + +-- | Represents a pretty-printable document. +-- +-- To display an 'SDoc', use 'printSDoc', 'printSDocLn', 'bufLeftRenderSDoc', +-- or 'renderWithStyle'. Avoid calling 'runSDoc' directly as it breaks the +-- abstraction layer. +newtype SDoc = SDoc { runSDoc :: SDocContext -> Doc } + +data SDocContext = SDC + { sdocStyle :: !PprStyle + , sdocLastColour :: !Col.PprColour + -- ^ The most recently used colour. This allows nesting colours. + , sdocDynFlags :: !DynFlags + } + +instance IsString SDoc where + fromString = text + +initSDocContext :: DynFlags -> PprStyle -> SDocContext +initSDocContext dflags sty = SDC + { sdocStyle = sty + , sdocLastColour = Col.colReset + , sdocDynFlags = dflags + } + +withPprStyle :: PprStyle -> SDoc -> SDoc +withPprStyle sty d = SDoc $ \ctxt -> runSDoc d ctxt{sdocStyle=sty} + +-- | This is not a recommended way to render 'SDoc', since it breaks the +-- abstraction layer of 'SDoc'. Prefer to use 'printSDoc', 'printSDocLn', +-- 'bufLeftRenderSDoc', or 'renderWithStyle' instead. +withPprStyleDoc :: DynFlags -> PprStyle -> SDoc -> Doc +withPprStyleDoc dflags sty d = runSDoc d (initSDocContext dflags sty) + +pprDeeper :: SDoc -> SDoc +pprDeeper d = SDoc $ \ctx -> case ctx of + SDC{sdocStyle=PprUser _ (PartWay 0) _} -> Pretty.text "..." + SDC{sdocStyle=PprUser q (PartWay n) c} -> + runSDoc d ctx{sdocStyle = PprUser q (PartWay (n-1)) c} + _ -> runSDoc d ctx + +-- | Truncate a list that is longer than the current depth. +pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc +pprDeeperList f ds + | null ds = f [] + | otherwise = SDoc work + where + work ctx@SDC{sdocStyle=PprUser q (PartWay n) c} + | n==0 = Pretty.text "..." + | otherwise = + runSDoc (f (go 0 ds)) ctx{sdocStyle = PprUser q (PartWay (n-1)) c} + where + go _ [] = [] + go i (d:ds) | i >= n = [text "...."] + | otherwise = d : go (i+1) ds + work other_ctx = runSDoc (f ds) other_ctx + +pprSetDepth :: Depth -> SDoc -> SDoc +pprSetDepth depth doc = SDoc $ \ctx -> + case ctx of + SDC{sdocStyle=PprUser q _ c} -> + runSDoc doc ctx{sdocStyle = PprUser q depth c} + _ -> + runSDoc doc ctx + +getPprStyle :: (PprStyle -> SDoc) -> SDoc +getPprStyle df = SDoc $ \ctx -> runSDoc (df (sdocStyle ctx)) ctx + +sdocWithDynFlags :: (DynFlags -> SDoc) -> SDoc +sdocWithDynFlags f = SDoc $ \ctx -> runSDoc (f (sdocDynFlags ctx)) ctx + +sdocWithPlatform :: (Platform -> SDoc) -> SDoc +sdocWithPlatform f = sdocWithDynFlags (f . targetPlatform) + +updSDocDynFlags :: (DynFlags -> DynFlags) -> SDoc -> SDoc +updSDocDynFlags upd doc + = SDoc $ \ctx -> runSDoc doc (ctx { sdocDynFlags = upd (sdocDynFlags ctx) }) + +qualName :: PprStyle -> QueryQualifyName +qualName (PprUser q _ _) mod occ = queryQualifyName q mod occ +qualName (PprDump q) mod occ = queryQualifyName q mod occ +qualName _other mod _ = NameQual (moduleName mod) + +qualModule :: PprStyle -> QueryQualifyModule +qualModule (PprUser q _ _) m = queryQualifyModule q m +qualModule (PprDump q) m = queryQualifyModule q m +qualModule _other _m = True + +qualPackage :: PprStyle -> QueryQualifyPackage +qualPackage (PprUser q _ _) m = queryQualifyPackage q m +qualPackage (PprDump q) m = queryQualifyPackage q m +qualPackage _other _m = True + +queryQual :: PprStyle -> PrintUnqualified +queryQual s = QueryQualify (qualName s) + (qualModule s) + (qualPackage s) + +codeStyle :: PprStyle -> Bool +codeStyle (PprCode _) = True +codeStyle _ = False + +asmStyle :: PprStyle -> Bool +asmStyle (PprCode AsmStyle) = True +asmStyle _other = False + +dumpStyle :: PprStyle -> Bool +dumpStyle (PprDump {}) = True +dumpStyle _other = False + +debugStyle :: PprStyle -> Bool +debugStyle PprDebug = True +debugStyle _other = False + +userStyle :: PprStyle -> Bool +userStyle (PprUser {}) = True +userStyle _other = False + +getPprDebug :: (Bool -> SDoc) -> SDoc +getPprDebug d = getPprStyle $ \ sty -> d (debugStyle sty) + +ifPprDebug :: SDoc -> SDoc -> SDoc +-- ^ Says what to do with and without -dppr-debug +ifPprDebug yes no = getPprDebug $ \ dbg -> if dbg then yes else no + +whenPprDebug :: SDoc -> SDoc -- Empty for non-debug style +-- ^ Says what to do with -dppr-debug; without, return empty +whenPprDebug d = ifPprDebug d empty + +-- | The analog of 'Pretty.printDoc_' for 'SDoc', which tries to make sure the +-- terminal doesn't get screwed up by the ANSI color codes if an exception +-- is thrown during pretty-printing. +printSDoc :: Mode -> DynFlags -> Handle -> PprStyle -> SDoc -> IO () +printSDoc mode dflags handle sty doc = + Pretty.printDoc_ mode cols handle (runSDoc doc ctx) + `finally` + Pretty.printDoc_ mode cols handle + (runSDoc (coloured Col.colReset empty) ctx) + where + cols = pprCols dflags + ctx = initSDocContext dflags sty + +-- | Like 'printSDoc' but appends an extra newline. +printSDocLn :: Mode -> DynFlags -> Handle -> PprStyle -> SDoc -> IO () +printSDocLn mode dflags handle sty doc = + printSDoc mode dflags handle sty (doc $$ text "") + +printForUser :: DynFlags -> Handle -> PrintUnqualified -> SDoc -> IO () +printForUser dflags handle unqual doc + = printSDocLn PageMode dflags handle + (mkUserStyle dflags unqual AllTheWay) doc + +printForUserPartWay :: DynFlags -> Handle -> Int -> PrintUnqualified -> SDoc + -> IO () +printForUserPartWay dflags handle d unqual doc + = printSDocLn PageMode dflags handle + (mkUserStyle dflags unqual (PartWay d)) doc + +-- | Like 'printSDocLn' but specialized with 'LeftMode' and +-- @'PprCode' 'CStyle'@. This is typically used to output C-- code. +printForC :: DynFlags -> Handle -> SDoc -> IO () +printForC dflags handle doc = + printSDocLn LeftMode dflags handle (PprCode CStyle) doc + +-- | An efficient variant of 'printSDoc' specialized for 'LeftMode' that +-- outputs to a 'BufHandle'. +bufLeftRenderSDoc :: DynFlags -> BufHandle -> PprStyle -> SDoc -> IO () +bufLeftRenderSDoc dflags bufHandle sty doc = + Pretty.bufLeftRender bufHandle (runSDoc doc (initSDocContext dflags sty)) + +pprCode :: CodeStyle -> SDoc -> SDoc +pprCode cs d = withPprStyle (PprCode cs) d + +mkCodeStyle :: CodeStyle -> PprStyle +mkCodeStyle = PprCode + +-- Can't make SDoc an instance of Show because SDoc is just a function type +-- However, Doc *is* an instance of Show +-- showSDoc just blasts it out as a string +showSDoc :: DynFlags -> SDoc -> String +showSDoc dflags sdoc = renderWithStyle dflags sdoc (defaultUserStyle dflags) + +-- showSDocUnsafe is unsafe, because `unsafeGlobalDynFlags` might not be +-- initialised yet. +showSDocUnsafe :: SDoc -> String +showSDocUnsafe sdoc = showSDoc unsafeGlobalDynFlags sdoc + +showPpr :: Outputable a => DynFlags -> a -> String +showPpr dflags thing = showSDoc dflags (ppr thing) + +showSDocUnqual :: DynFlags -> SDoc -> String +-- Only used by Haddock +showSDocUnqual dflags sdoc = showSDoc dflags sdoc + +showSDocForUser :: DynFlags -> PrintUnqualified -> SDoc -> String +-- Allows caller to specify the PrintUnqualified to use +showSDocForUser dflags unqual doc + = renderWithStyle dflags doc (mkUserStyle dflags unqual AllTheWay) + +showSDocDump :: DynFlags -> SDoc -> String +showSDocDump dflags d = renderWithStyle dflags d (defaultDumpStyle dflags) + +showSDocDebug :: DynFlags -> SDoc -> String +showSDocDebug dflags d = renderWithStyle dflags d PprDebug + +renderWithStyle :: DynFlags -> SDoc -> PprStyle -> String +renderWithStyle dflags sdoc sty + = let s = Pretty.style{ Pretty.mode = PageMode, + Pretty.lineLength = pprCols dflags } + in Pretty.renderStyle s $ runSDoc sdoc (initSDocContext dflags sty) + +-- This shows an SDoc, but on one line only. It's cheaper than a full +-- showSDoc, designed for when we're getting results like "Foo.bar" +-- and "foo{uniq strictness}" so we don't want fancy layout anyway. +showSDocOneLine :: DynFlags -> SDoc -> String +showSDocOneLine dflags d + = let s = Pretty.style{ Pretty.mode = OneLineMode, + Pretty.lineLength = pprCols dflags } in + Pretty.renderStyle s $ + runSDoc d (initSDocContext dflags (defaultUserStyle dflags)) + +showSDocDumpOneLine :: DynFlags -> SDoc -> String +showSDocDumpOneLine dflags d + = let s = Pretty.style{ Pretty.mode = OneLineMode, + Pretty.lineLength = irrelevantNCols } in + Pretty.renderStyle s $ + runSDoc d (initSDocContext dflags (defaultDumpStyle dflags)) + +irrelevantNCols :: Int +-- Used for OneLineMode and LeftMode when number of cols isn't used +irrelevantNCols = 1 + +isEmpty :: DynFlags -> SDoc -> Bool +isEmpty dflags sdoc = Pretty.isEmpty $ runSDoc sdoc dummySDocContext + where dummySDocContext = initSDocContext dflags PprDebug + +docToSDoc :: Doc -> SDoc +docToSDoc d = SDoc (\_ -> d) + +empty :: SDoc +char :: Char -> SDoc +text :: String -> SDoc +ftext :: FastString -> SDoc +ptext :: PtrString -> SDoc +ztext :: FastZString -> SDoc +int :: Int -> SDoc +integer :: Integer -> SDoc +word :: Integer -> SDoc +float :: Float -> SDoc +double :: Double -> SDoc +rational :: Rational -> SDoc + +empty = docToSDoc $ Pretty.empty +char c = docToSDoc $ Pretty.char c + +text s = docToSDoc $ Pretty.text s +{-# INLINE text #-} -- Inline so that the RULE Pretty.text will fire + +ftext s = docToSDoc $ Pretty.ftext s +ptext s = docToSDoc $ Pretty.ptext s +ztext s = docToSDoc $ Pretty.ztext s +int n = docToSDoc $ Pretty.int n +integer n = docToSDoc $ Pretty.integer n +float n = docToSDoc $ Pretty.float n +double n = docToSDoc $ Pretty.double n +rational n = docToSDoc $ Pretty.rational n +word n = sdocWithDynFlags $ \dflags -> + -- See Note [Print Hexadecimal Literals] in Pretty.hs + if shouldUseHexWordLiterals dflags + then docToSDoc $ Pretty.hex n + else docToSDoc $ Pretty.integer n + +-- | @doublePrec p n@ shows a floating point number @n@ with @p@ +-- digits of precision after the decimal point. +doublePrec :: Int -> Double -> SDoc +doublePrec p n = text (showFFloat (Just p) n "") + +parens, braces, brackets, quotes, quote, + doubleQuotes, angleBrackets :: SDoc -> SDoc + +parens d = SDoc $ Pretty.parens . runSDoc d +braces d = SDoc $ Pretty.braces . runSDoc d +brackets d = SDoc $ Pretty.brackets . runSDoc d +quote d = SDoc $ Pretty.quote . runSDoc d +doubleQuotes d = SDoc $ Pretty.doubleQuotes . runSDoc d +angleBrackets d = char '<' <> d <> char '>' + +cparen :: Bool -> SDoc -> SDoc +cparen b d = SDoc $ Pretty.maybeParens b . runSDoc d + +-- 'quotes' encloses something in single quotes... +-- but it omits them if the thing begins or ends in a single quote +-- so that we don't get `foo''. Instead we just have foo'. +quotes d = + sdocWithDynFlags $ \dflags -> + if useUnicode dflags + then char '‘' <> d <> char '’' + else SDoc $ \sty -> + let pp_d = runSDoc d sty + str = show pp_d + in case (str, lastMaybe str) of + (_, Just '\'') -> pp_d + ('\'' : _, _) -> pp_d + _other -> Pretty.quotes pp_d + +semi, comma, colon, equals, space, dcolon, underscore, dot, vbar :: SDoc +arrow, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt :: SDoc +lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc + +blankLine = docToSDoc $ Pretty.text "" +dcolon = unicodeSyntax (char '∷') (docToSDoc $ Pretty.text "::") +arrow = unicodeSyntax (char '→') (docToSDoc $ Pretty.text "->") +larrow = unicodeSyntax (char '←') (docToSDoc $ Pretty.text "<-") +darrow = unicodeSyntax (char '⇒') (docToSDoc $ Pretty.text "=>") +arrowt = unicodeSyntax (char '⤚') (docToSDoc $ Pretty.text ">-") +larrowt = unicodeSyntax (char '⤙') (docToSDoc $ Pretty.text "-<") +arrowtt = unicodeSyntax (char '⤜') (docToSDoc $ Pretty.text ">>-") +larrowtt = unicodeSyntax (char '⤛') (docToSDoc $ Pretty.text "-<<") +semi = docToSDoc $ Pretty.semi +comma = docToSDoc $ Pretty.comma +colon = docToSDoc $ Pretty.colon +equals = docToSDoc $ Pretty.equals +space = docToSDoc $ Pretty.space +underscore = char '_' +dot = char '.' +vbar = char '|' +lparen = docToSDoc $ Pretty.lparen +rparen = docToSDoc $ Pretty.rparen +lbrack = docToSDoc $ Pretty.lbrack +rbrack = docToSDoc $ Pretty.rbrack +lbrace = docToSDoc $ Pretty.lbrace +rbrace = docToSDoc $ Pretty.rbrace + +forAllLit :: SDoc +forAllLit = unicodeSyntax (char '∀') (text "forall") + +kindType :: SDoc +kindType = sdocWithDynFlags $ \dflags -> + if useStarIsType dflags + then unicodeSyntax (char '★') (char '*') + else text "Type" + +bullet :: SDoc +bullet = unicode (char '•') (char '*') + +unicodeSyntax :: SDoc -> SDoc -> SDoc +unicodeSyntax unicode plain = sdocWithDynFlags $ \dflags -> + if useUnicode dflags && useUnicodeSyntax dflags + then unicode + else plain + +unicode :: SDoc -> SDoc -> SDoc +unicode unicode plain = sdocWithDynFlags $ \dflags -> + if useUnicode dflags + then unicode + else plain + +nest :: Int -> SDoc -> SDoc +-- ^ Indent 'SDoc' some specified amount +(<>) :: SDoc -> SDoc -> SDoc +-- ^ Join two 'SDoc' together horizontally without a gap +(<+>) :: SDoc -> SDoc -> SDoc +-- ^ Join two 'SDoc' together horizontally with a gap between them +($$) :: SDoc -> SDoc -> SDoc +-- ^ Join two 'SDoc' together vertically; if there is +-- no vertical overlap it "dovetails" the two onto one line +($+$) :: SDoc -> SDoc -> SDoc +-- ^ Join two 'SDoc' together vertically + +nest n d = SDoc $ Pretty.nest n . runSDoc d +(<>) d1 d2 = SDoc $ \sty -> (Pretty.<>) (runSDoc d1 sty) (runSDoc d2 sty) +(<+>) d1 d2 = SDoc $ \sty -> (Pretty.<+>) (runSDoc d1 sty) (runSDoc d2 sty) +($$) d1 d2 = SDoc $ \sty -> (Pretty.$$) (runSDoc d1 sty) (runSDoc d2 sty) +($+$) d1 d2 = SDoc $ \sty -> (Pretty.$+$) (runSDoc d1 sty) (runSDoc d2 sty) + +hcat :: [SDoc] -> SDoc +-- ^ Concatenate 'SDoc' horizontally +hsep :: [SDoc] -> SDoc +-- ^ Concatenate 'SDoc' horizontally with a space between each one +vcat :: [SDoc] -> SDoc +-- ^ Concatenate 'SDoc' vertically with dovetailing +sep :: [SDoc] -> SDoc +-- ^ Separate: is either like 'hsep' or like 'vcat', depending on what fits +cat :: [SDoc] -> SDoc +-- ^ Catenate: is either like 'hcat' or like 'vcat', depending on what fits +fsep :: [SDoc] -> SDoc +-- ^ A paragraph-fill combinator. It's much like sep, only it +-- keeps fitting things on one line until it can't fit any more. +fcat :: [SDoc] -> SDoc +-- ^ This behaves like 'fsep', but it uses '<>' for horizontal conposition rather than '<+>' + + +hcat ds = SDoc $ \sty -> Pretty.hcat [runSDoc d sty | d <- ds] +hsep ds = SDoc $ \sty -> Pretty.hsep [runSDoc d sty | d <- ds] +vcat ds = SDoc $ \sty -> Pretty.vcat [runSDoc d sty | d <- ds] +sep ds = SDoc $ \sty -> Pretty.sep [runSDoc d sty | d <- ds] +cat ds = SDoc $ \sty -> Pretty.cat [runSDoc d sty | d <- ds] +fsep ds = SDoc $ \sty -> Pretty.fsep [runSDoc d sty | d <- ds] +fcat ds = SDoc $ \sty -> Pretty.fcat [runSDoc d sty | d <- ds] + +hang :: SDoc -- ^ The header + -> Int -- ^ Amount to indent the hung body + -> SDoc -- ^ The hung body, indented and placed below the header + -> SDoc +hang d1 n d2 = SDoc $ \sty -> Pretty.hang (runSDoc d1 sty) n (runSDoc d2 sty) + +-- | This behaves like 'hang', but does not indent the second document +-- when the header is empty. +hangNotEmpty :: SDoc -> Int -> SDoc -> SDoc +hangNotEmpty d1 n d2 = + SDoc $ \sty -> Pretty.hangNotEmpty (runSDoc d1 sty) n (runSDoc d2 sty) + +punctuate :: SDoc -- ^ The punctuation + -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements + -> [SDoc] -- ^ Punctuated list +punctuate _ [] = [] +punctuate p (d:ds) = go d ds + where + go d [] = [d] + go d (e:es) = (d <> p) : go e es + +ppWhen, ppUnless :: Bool -> SDoc -> SDoc +ppWhen True doc = doc +ppWhen False _ = empty + +ppUnless True _ = empty +ppUnless False doc = doc + +-- | Apply the given colour\/style for the argument. +-- +-- Only takes effect if colours are enabled. +coloured :: Col.PprColour -> SDoc -> SDoc +coloured col sdoc = + sdocWithDynFlags $ \dflags -> + if shouldUseColor dflags + then SDoc $ \ctx@SDC{ sdocLastColour = lastCol } -> + case ctx of + SDC{ sdocStyle = PprUser _ _ Coloured } -> + let ctx' = ctx{ sdocLastColour = lastCol `mappend` col } in + Pretty.zeroWidthText (Col.renderColour col) + Pretty.<> runSDoc sdoc ctx' + Pretty.<> Pretty.zeroWidthText (Col.renderColourAfresh lastCol) + _ -> runSDoc sdoc ctx + else sdoc + +keyword :: SDoc -> SDoc +keyword = coloured Col.colBold + +{- +************************************************************************ +* * +\subsection[Outputable-class]{The @Outputable@ class} +* * +************************************************************************ +-} + +-- | Class designating that some type has an 'SDoc' representation +class Outputable a where + ppr :: a -> SDoc + pprPrec :: Rational -> a -> SDoc + -- 0 binds least tightly + -- We use Rational because there is always a + -- Rational between any other two Rationals + + ppr = pprPrec 0 + pprPrec _ = ppr + +instance Outputable Char where + ppr c = text [c] + +instance Outputable Bool where + ppr True = text "True" + ppr False = text "False" + +instance Outputable Ordering where + ppr LT = text "LT" + ppr EQ = text "EQ" + ppr GT = text "GT" + +instance Outputable Int32 where + ppr n = integer $ fromIntegral n + +instance Outputable Int64 where + ppr n = integer $ fromIntegral n + +instance Outputable Int where + ppr n = int n + +instance Outputable Integer where + ppr n = integer n + +instance Outputable Word16 where + ppr n = integer $ fromIntegral n + +instance Outputable Word32 where + ppr n = integer $ fromIntegral n + +instance Outputable Word where + ppr n = integer $ fromIntegral n + +instance Outputable () where + ppr _ = text "()" + +instance (Outputable a) => Outputable [a] where + ppr xs = brackets (fsep (punctuate comma (map ppr xs))) + +instance (Outputable a) => Outputable (Set a) where + ppr s = braces (fsep (punctuate comma (map ppr (Set.toList s)))) + +instance (Outputable a, Outputable b) => Outputable (a, b) where + ppr (x,y) = parens (sep [ppr x <> comma, ppr y]) + +instance Outputable a => Outputable (Maybe a) where + ppr Nothing = text "Nothing" + ppr (Just x) = text "Just" <+> ppr x + +instance (Outputable a, Outputable b) => Outputable (Either a b) where + ppr (Left x) = text "Left" <+> ppr x + ppr (Right y) = text "Right" <+> ppr y + +-- ToDo: may not be used +instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where + ppr (x,y,z) = + parens (sep [ppr x <> comma, + ppr y <> comma, + ppr z ]) + +instance (Outputable a, Outputable b, Outputable c, Outputable d) => + Outputable (a, b, c, d) where + ppr (a,b,c,d) = + parens (sep [ppr a <> comma, + ppr b <> comma, + ppr c <> comma, + ppr d]) + +instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e) => + Outputable (a, b, c, d, e) where + ppr (a,b,c,d,e) = + parens (sep [ppr a <> comma, + ppr b <> comma, + ppr c <> comma, + ppr d <> comma, + ppr e]) + +instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e, Outputable f) => + Outputable (a, b, c, d, e, f) where + ppr (a,b,c,d,e,f) = + parens (sep [ppr a <> comma, + ppr b <> comma, + ppr c <> comma, + ppr d <> comma, + ppr e <> comma, + ppr f]) + +instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e, Outputable f, Outputable g) => + Outputable (a, b, c, d, e, f, g) where + ppr (a,b,c,d,e,f,g) = + parens (sep [ppr a <> comma, + ppr b <> comma, + ppr c <> comma, + ppr d <> comma, + ppr e <> comma, + ppr f <> comma, + ppr g]) + +instance Outputable FastString where + ppr fs = ftext fs -- Prints an unadorned string, + -- no double quotes or anything + +instance (Outputable key, Outputable elt) => Outputable (M.Map key elt) where + ppr m = ppr (M.toList m) +instance (Outputable elt) => Outputable (IM.IntMap elt) where + ppr m = ppr (IM.toList m) + +instance Outputable Fingerprint where + ppr (Fingerprint w1 w2) = text (printf "%016x%016x" w1 w2) + +instance Outputable a => Outputable (SCC a) where + ppr (AcyclicSCC v) = text "NONREC" $$ (nest 3 (ppr v)) + ppr (CyclicSCC vs) = text "REC" $$ (nest 3 (vcat (map ppr vs))) + +instance Outputable Serialized where + ppr (Serialized the_type bytes) = int (length bytes) <+> text "of type" <+> text (show the_type) + +instance Outputable Extension where + ppr = text . show + +{- +************************************************************************ +* * +\subsection{The @OutputableBndr@ class} +* * +************************************************************************ +-} + +-- | 'BindingSite' is used to tell the thing that prints binder what +-- language construct is binding the identifier. This can be used +-- to decide how much info to print. +-- Also see Note [Binding-site specific printing] in PprCore +data BindingSite + = LambdaBind -- ^ The x in (\x. e) + | CaseBind -- ^ The x in case scrut of x { (y,z) -> ... } + | CasePatBind -- ^ The y,z in case scrut of x { (y,z) -> ... } + | LetBind -- ^ The x in (let x = rhs in e) + +-- | When we print a binder, we often want to print its type too. +-- The @OutputableBndr@ class encapsulates this idea. +class Outputable a => OutputableBndr a where + pprBndr :: BindingSite -> a -> SDoc + pprBndr _b x = ppr x + + pprPrefixOcc, pprInfixOcc :: a -> SDoc + -- Print an occurrence of the name, suitable either in the + -- prefix position of an application, thus (f a b) or ((+) x) + -- or infix position, thus (a `f` b) or (x + y) + + bndrIsJoin_maybe :: a -> Maybe Int + bndrIsJoin_maybe _ = Nothing + -- When pretty-printing we sometimes want to find + -- whether the binder is a join point. You might think + -- we could have a function of type (a->Var), but Var + -- isn't available yet, alas + +{- +************************************************************************ +* * +\subsection{Random printing helpers} +* * +************************************************************************ +-} + +-- We have 31-bit Chars and will simply use Show instances of Char and String. + +-- | Special combinator for showing character literals. +pprHsChar :: Char -> SDoc +pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32)) + | otherwise = text (show c) + +-- | Special combinator for showing string literals. +pprHsString :: FastString -> SDoc +pprHsString fs = vcat (map text (showMultiLineString (unpackFS fs))) + +-- | Special combinator for showing bytestring literals. +pprHsBytes :: ByteString -> SDoc +pprHsBytes bs = let escaped = concatMap escape $ BS.unpack bs + in vcat (map text (showMultiLineString escaped)) <> char '#' + where escape :: Word8 -> String + escape w = let c = chr (fromIntegral w) + in if isAscii c + then [c] + else '\\' : show w + +-- Postfix modifiers for unboxed literals. +-- See Note [Printing of literals in Core] in `basicTypes/Literal.hs`. +primCharSuffix, primFloatSuffix, primIntSuffix :: SDoc +primDoubleSuffix, primWordSuffix, primInt64Suffix, primWord64Suffix :: SDoc +primCharSuffix = char '#' +primFloatSuffix = char '#' +primIntSuffix = char '#' +primDoubleSuffix = text "##" +primWordSuffix = text "##" +primInt64Suffix = text "L#" +primWord64Suffix = text "L##" + +-- | Special combinator for showing unboxed literals. +pprPrimChar :: Char -> SDoc +pprPrimInt, pprPrimWord, pprPrimInt64, pprPrimWord64 :: Integer -> SDoc +pprPrimChar c = pprHsChar c <> primCharSuffix +pprPrimInt i = integer i <> primIntSuffix +pprPrimWord w = word w <> primWordSuffix +pprPrimInt64 i = integer i <> primInt64Suffix +pprPrimWord64 w = word w <> primWord64Suffix + +--------------------- +-- Put a name in parens if it's an operator +pprPrefixVar :: Bool -> SDoc -> SDoc +pprPrefixVar is_operator pp_v + | is_operator = parens pp_v + | otherwise = pp_v + +-- Put a name in backquotes if it's not an operator +pprInfixVar :: Bool -> SDoc -> SDoc +pprInfixVar is_operator pp_v + | is_operator = pp_v + | otherwise = char '`' <> pp_v <> char '`' + +--------------------- +pprFastFilePath :: FastString -> SDoc +pprFastFilePath path = text $ normalise $ unpackFS path + +-- | Normalise, escape and render a string representing a path +-- +-- e.g. "c:\\whatever" +pprFilePathString :: FilePath -> SDoc +pprFilePathString path = doubleQuotes $ text (escape (normalise path)) + where + escape [] = [] + escape ('\\':xs) = '\\':'\\':escape xs + escape (x:xs) = x:escape xs + +{- +************************************************************************ +* * +\subsection{Other helper functions} +* * +************************************************************************ +-} + +pprWithCommas :: (a -> SDoc) -- ^ The pretty printing function to use + -> [a] -- ^ The things to be pretty printed + -> SDoc -- ^ 'SDoc' where the things have been pretty printed, + -- comma-separated and finally packed into a paragraph. +pprWithCommas pp xs = fsep (punctuate comma (map pp xs)) + +pprWithBars :: (a -> SDoc) -- ^ The pretty printing function to use + -> [a] -- ^ The things to be pretty printed + -> SDoc -- ^ 'SDoc' where the things have been pretty printed, + -- bar-separated and finally packed into a paragraph. +pprWithBars pp xs = fsep (intersperse vbar (map pp xs)) + +-- | Returns the separated concatenation of the pretty printed things. +interppSP :: Outputable a => [a] -> SDoc +interppSP xs = sep (map ppr xs) + +-- | Returns the comma-separated concatenation of the pretty printed things. +interpp'SP :: Outputable a => [a] -> SDoc +interpp'SP xs = sep (punctuate comma (map ppr xs)) + +-- | Returns the comma-separated concatenation of the quoted pretty printed things. +-- +-- > [x,y,z] ==> `x', `y', `z' +pprQuotedList :: Outputable a => [a] -> SDoc +pprQuotedList = quotedList . map ppr + +quotedList :: [SDoc] -> SDoc +quotedList xs = fsep (punctuate comma (map quotes xs)) + +quotedListWithOr :: [SDoc] -> SDoc +-- [x,y,z] ==> `x', `y' or `z' +quotedListWithOr xs@(_:_:_) = quotedList (init xs) <+> text "or" <+> quotes (last xs) +quotedListWithOr xs = quotedList xs + +quotedListWithNor :: [SDoc] -> SDoc +-- [x,y,z] ==> `x', `y' nor `z' +quotedListWithNor xs@(_:_:_) = quotedList (init xs) <+> text "nor" <+> quotes (last xs) +quotedListWithNor xs = quotedList xs + +{- +************************************************************************ +* * +\subsection{Printing numbers verbally} +* * +************************************************************************ +-} + +intWithCommas :: Integral a => a -> SDoc +-- Prints a big integer with commas, eg 345,821 +intWithCommas n + | n < 0 = char '-' <> intWithCommas (-n) + | q == 0 = int (fromIntegral r) + | otherwise = intWithCommas q <> comma <> zeroes <> int (fromIntegral r) + where + (q,r) = n `quotRem` 1000 + zeroes | r >= 100 = empty + | r >= 10 = char '0' + | otherwise = text "00" + +-- | Converts an integer to a verbal index: +-- +-- > speakNth 1 = text "first" +-- > speakNth 5 = text "fifth" +-- > speakNth 21 = text "21st" +speakNth :: Int -> SDoc +speakNth 1 = text "first" +speakNth 2 = text "second" +speakNth 3 = text "third" +speakNth 4 = text "fourth" +speakNth 5 = text "fifth" +speakNth 6 = text "sixth" +speakNth n = hcat [ int n, text suffix ] + where + suffix | n <= 20 = "th" -- 11,12,13 are non-std + | last_dig == 1 = "st" + | last_dig == 2 = "nd" + | last_dig == 3 = "rd" + | otherwise = "th" + + last_dig = n `rem` 10 + +-- | Converts an integer to a verbal multiplicity: +-- +-- > speakN 0 = text "none" +-- > speakN 5 = text "five" +-- > speakN 10 = text "10" +speakN :: Int -> SDoc +speakN 0 = text "none" -- E.g. "he has none" +speakN 1 = text "one" -- E.g. "he has one" +speakN 2 = text "two" +speakN 3 = text "three" +speakN 4 = text "four" +speakN 5 = text "five" +speakN 6 = text "six" +speakN n = int n + +-- | Converts an integer and object description to a statement about the +-- multiplicity of those objects: +-- +-- > speakNOf 0 (text "melon") = text "no melons" +-- > speakNOf 1 (text "melon") = text "one melon" +-- > speakNOf 3 (text "melon") = text "three melons" +speakNOf :: Int -> SDoc -> SDoc +speakNOf 0 d = text "no" <+> d <> char 's' +speakNOf 1 d = text "one" <+> d -- E.g. "one argument" +speakNOf n d = speakN n <+> d <> char 's' -- E.g. "three arguments" + +-- | Determines the pluralisation suffix appropriate for the length of a list: +-- +-- > plural [] = char 's' +-- > plural ["Hello"] = empty +-- > plural ["Hello", "World"] = char 's' +plural :: [a] -> SDoc +plural [_] = empty -- a bit frightening, but there you are +plural _ = char 's' + +-- | Determines the form of to be appropriate for the length of a list: +-- +-- > isOrAre [] = text "are" +-- > isOrAre ["Hello"] = text "is" +-- > isOrAre ["Hello", "World"] = text "are" +isOrAre :: [a] -> SDoc +isOrAre [_] = text "is" +isOrAre _ = text "are" + +-- | Determines the form of to do appropriate for the length of a list: +-- +-- > doOrDoes [] = text "do" +-- > doOrDoes ["Hello"] = text "does" +-- > doOrDoes ["Hello", "World"] = text "do" +doOrDoes :: [a] -> SDoc +doOrDoes [_] = text "does" +doOrDoes _ = text "do" + +{- +************************************************************************ +* * +\subsection{Error handling} +* * +************************************************************************ +-} + +callStackDoc :: HasCallStack => SDoc +callStackDoc = + hang (text "Call stack:") + 4 (vcat $ map text $ lines (prettyCallStack callStack)) + +pprPanic :: HasCallStack => String -> SDoc -> a +-- ^ Throw an exception saying "bug in GHC" +pprPanic s doc = panicDoc s (doc $$ callStackDoc) + +pprSorry :: String -> SDoc -> a +-- ^ Throw an exception saying "this isn't finished yet" +pprSorry = sorryDoc + + +pprPgmError :: String -> SDoc -> a +-- ^ Throw an exception saying "bug in pgm being compiled" (used for unusual program errors) +pprPgmError = pgmErrorDoc + +pprTraceDebug :: String -> SDoc -> a -> a +pprTraceDebug str doc x + | debugIsOn && hasPprDebug unsafeGlobalDynFlags = pprTrace str doc x + | otherwise = x + +pprTrace :: String -> SDoc -> a -> a +-- ^ If debug output is on, show some 'SDoc' on the screen +pprTrace str doc x + | hasNoDebugOutput unsafeGlobalDynFlags = x + | otherwise = + pprDebugAndThen unsafeGlobalDynFlags trace (text str) doc x + +pprTraceM :: Applicative f => String -> SDoc -> f () +pprTraceM str doc = pprTrace str doc (pure ()) + +-- | @pprTraceIt desc x@ is equivalent to @pprTrace desc (ppr x) x@ +pprTraceIt :: Outputable a => String -> a -> a +pprTraceIt desc x = pprTrace desc (ppr x) x + +-- | @pprTraceException desc x action@ runs action, printing a message +-- if it throws an exception. +pprTraceException :: ExceptionMonad m => String -> SDoc -> m a -> m a +pprTraceException heading doc = + handleGhcException $ \exc -> liftIO $ do + putStrLn $ showSDocDump unsafeGlobalDynFlags (sep [text heading, nest 2 doc]) + throwGhcExceptionIO exc + +-- | If debug output is on, show some 'SDoc' on the screen along +-- with a call stack when available. +pprSTrace :: HasCallStack => SDoc -> a -> a +pprSTrace doc = pprTrace "" (doc $$ callStackDoc) + +warnPprTrace :: HasCallStack => Bool -> String -> Int -> SDoc -> a -> a +-- ^ Just warn about an assertion failure, recording the given file and line number. +-- Should typically be accessed with the WARN macros +warnPprTrace _ _ _ _ x | not debugIsOn = x +warnPprTrace _ _file _line _msg x + | hasNoDebugOutput unsafeGlobalDynFlags = x +warnPprTrace False _file _line _msg x = x +warnPprTrace True file line msg x + = pprDebugAndThen unsafeGlobalDynFlags trace heading + (msg $$ callStackDoc ) + x + where + heading = hsep [text "WARNING: file", text file <> comma, text "line", int line] + +-- | Panic with an assertation failure, recording the given file and +-- line number. Should typically be accessed with the ASSERT family of macros +assertPprPanic :: HasCallStack => String -> Int -> SDoc -> a +assertPprPanic _file _line msg + = pprPanic "ASSERT failed!" msg + +pprDebugAndThen :: DynFlags -> (String -> a) -> SDoc -> SDoc -> a +pprDebugAndThen dflags cont heading pretty_msg + = cont (showSDocDump dflags doc) + where + doc = sep [heading, nest 2 pretty_msg] diff --git a/compiler/utils/Outputable.hs-boot b/compiler/utils/Outputable.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/utils/Outputable.hs-boot @@ -0,0 +1,12 @@ +module Outputable where + +import GhcPrelude +import GHC.Stack( HasCallStack ) + +data SDoc + +showSDocUnsafe :: SDoc -> String + +warnPprTrace :: HasCallStack => Bool -> String -> Int -> SDoc -> a -> a + +text :: String -> SDoc diff --git a/compiler/utils/Pair.hs b/compiler/utils/Pair.hs new file mode 100644 --- /dev/null +++ b/compiler/utils/Pair.hs @@ -0,0 +1,60 @@ +{- +A simple homogeneous pair type with useful Functor, Applicative, and +Traversable instances. +-} + +{-# LANGUAGE CPP #-} + +module Pair ( Pair(..), unPair, toPair, swap, pLiftFst, pLiftSnd ) where + +#include "HsVersions.h" + +import GhcPrelude + +import Outputable +import qualified Data.Semigroup as Semi + +data Pair a = Pair { pFst :: a, pSnd :: a } +-- Note that Pair is a *unary* type constructor +-- whereas (,) is binary + +-- The important thing about Pair is that it has a *homogeneous* +-- Functor instance, so you can easily apply the same function +-- to both components +instance Functor Pair where + fmap f (Pair x y) = Pair (f x) (f y) + +instance Applicative Pair where + pure x = Pair x x + (Pair f g) <*> (Pair x y) = Pair (f x) (g y) + +instance Foldable Pair where + foldMap f (Pair x y) = f x `mappend` f y + +instance Traversable Pair where + traverse f (Pair x y) = Pair <$> f x <*> f y + +instance Semi.Semigroup a => Semi.Semigroup (Pair a) where + Pair a1 b1 <> Pair a2 b2 = Pair (a1 Semi.<> a2) (b1 Semi.<> b2) + +instance (Semi.Semigroup a, Monoid a) => Monoid (Pair a) where + mempty = Pair mempty mempty + mappend = (Semi.<>) + +instance Outputable a => Outputable (Pair a) where + ppr (Pair a b) = ppr a <+> char '~' <+> ppr b + +unPair :: Pair a -> (a,a) +unPair (Pair x y) = (x,y) + +toPair :: (a,a) -> Pair a +toPair (x,y) = Pair x y + +swap :: Pair a -> Pair a +swap (Pair x y) = Pair y x + +pLiftFst :: (a -> a) -> Pair a -> Pair a +pLiftFst f (Pair a b) = Pair (f a) b + +pLiftSnd :: (a -> a) -> Pair a -> Pair a +pLiftSnd f (Pair a b) = Pair a (f b) diff --git a/compiler/utils/Panic.hs b/compiler/utils/Panic.hs new file mode 100644 --- /dev/null +++ b/compiler/utils/Panic.hs @@ -0,0 +1,313 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP Project, Glasgow University, 1992-2000 + +Defines basic functions for printing error messages. + +It's hard to put these functions anywhere else without causing +some unnecessary loops in the module dependency graph. +-} + +{-# LANGUAGE CPP, ScopedTypeVariables, LambdaCase #-} + +module Panic ( + GhcException(..), showGhcException, + throwGhcException, throwGhcExceptionIO, + handleGhcException, + progName, + pgmError, + + panic, sorry, assertPanic, trace, + panicDoc, sorryDoc, pgmErrorDoc, + + cmdLineError, cmdLineErrorIO, + + Exception.Exception(..), showException, safeShowException, + try, tryMost, throwTo, + + withSignalHandlers, +) where +#include "HsVersions.h" + +import GhcPrelude + +import {-# SOURCE #-} Outputable (SDoc, showSDocUnsafe) + +import Config +import Exception + +import Control.Monad.IO.Class +import Control.Concurrent +import Debug.Trace ( trace ) +import System.IO.Unsafe +import System.Environment + +#if !defined(mingw32_HOST_OS) +import System.Posix.Signals as S +#endif + +#if defined(mingw32_HOST_OS) +import GHC.ConsoleHandler as S +#endif + +import GHC.Stack +import System.Mem.Weak ( deRefWeak ) + +-- | GHC's own exception type +-- error messages all take the form: +-- +-- @ +-- : +-- @ +-- +-- If the location is on the command line, or in GHC itself, then +-- ="ghc". All of the error types below correspond to +-- a of "ghc", except for ProgramError (where the string is +-- assumed to contain a location already, so we don't print one). + +data GhcException + -- | Some other fatal signal (SIGHUP,SIGTERM) + = Signal Int + + -- | Prints the short usage msg after the error + | UsageError String + + -- | A problem with the command line arguments, but don't print usage. + | CmdLineError String + + -- | The 'impossible' happened. + | Panic String + | PprPanic String SDoc + + -- | The user tickled something that's known not to work yet, + -- but we're not counting it as a bug. + | Sorry String + | PprSorry String SDoc + + -- | An installation problem. + | InstallationError String + + -- | An error in the user's code, probably. + | ProgramError String + | PprProgramError String SDoc + +instance Exception GhcException + +instance Show GhcException where + showsPrec _ e@(ProgramError _) = showGhcException e + showsPrec _ e@(CmdLineError _) = showString ": " . showGhcException e + showsPrec _ e = showString progName . showString ": " . showGhcException e + + +-- | The name of this GHC. +progName :: String +progName = unsafePerformIO (getProgName) +{-# NOINLINE progName #-} + + +-- | Short usage information to display when we are given the wrong cmd line arguments. +short_usage :: String +short_usage = "Usage: For basic information, try the `--help' option." + + +-- | Show an exception as a string. +showException :: Exception e => e -> String +showException = show + +-- | Show an exception which can possibly throw other exceptions. +-- Used when displaying exception thrown within TH code. +safeShowException :: Exception e => e -> IO String +safeShowException e = do + -- ensure the whole error message is evaluated inside try + r <- try (return $! forceList (showException e)) + case r of + Right msg -> return msg + Left e' -> safeShowException (e' :: SomeException) + where + forceList [] = [] + forceList xs@(x : xt) = x `seq` forceList xt `seq` xs + +-- | Append a description of the given exception to this string. +-- +-- Note that this uses 'DynFlags.unsafeGlobalDynFlags', which may have some +-- uninitialized fields if invoked before 'GHC.initGhcMonad' has been called. +-- If the error message to be printed includes a pretty-printer document +-- which forces one of these fields this call may bottom. +showGhcException :: GhcException -> ShowS +showGhcException exception + = case exception of + UsageError str + -> showString str . showChar '\n' . showString short_usage + + CmdLineError str -> showString str + PprProgramError str sdoc -> + showString str . showString "\n\n" . + showString (showSDocUnsafe sdoc) + ProgramError str -> showString str + InstallationError str -> showString str + Signal n -> showString "signal: " . shows n + + PprPanic s sdoc -> + panicMsg $ showString s . showString "\n\n" + . showString (showSDocUnsafe sdoc) + Panic s -> panicMsg (showString s) + + PprSorry s sdoc -> + sorryMsg $ showString s . showString "\n\n" + . showString (showSDocUnsafe sdoc) + Sorry s -> sorryMsg (showString s) + where + sorryMsg :: ShowS -> ShowS + sorryMsg s = + showString "sorry! (unimplemented feature or known bug)\n" + . showString (" (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t") + . s . showString "\n" + + panicMsg :: ShowS -> ShowS + panicMsg s = + showString "panic! (the 'impossible' happened)\n" + . showString (" (GHC version " ++ cProjectVersion ++ " for " ++ TargetPlatform_NAME ++ "):\n\t") + . s . showString "\n\n" + . showString "Please report this as a GHC bug: https://www.haskell.org/ghc/reportabug\n" + + +throwGhcException :: GhcException -> a +throwGhcException = Exception.throw + +throwGhcExceptionIO :: GhcException -> IO a +throwGhcExceptionIO = Exception.throwIO + +handleGhcException :: ExceptionMonad m => (GhcException -> m a) -> m a -> m a +handleGhcException = ghandle + + +-- | Panics and asserts. +panic, sorry, pgmError :: String -> a +panic x = unsafeDupablePerformIO $ do + stack <- ccsToStrings =<< getCurrentCCS x + if null stack + then throwGhcException (Panic x) + else throwGhcException (Panic (x ++ '\n' : renderStack stack)) + +sorry x = throwGhcException (Sorry x) +pgmError x = throwGhcException (ProgramError x) + +panicDoc, sorryDoc, pgmErrorDoc :: String -> SDoc -> a +panicDoc x doc = throwGhcException (PprPanic x doc) +sorryDoc x doc = throwGhcException (PprSorry x doc) +pgmErrorDoc x doc = throwGhcException (PprProgramError x doc) + +cmdLineError :: String -> a +cmdLineError = unsafeDupablePerformIO . cmdLineErrorIO + +cmdLineErrorIO :: String -> IO a +cmdLineErrorIO x = do + stack <- ccsToStrings =<< getCurrentCCS x + if null stack + then throwGhcException (CmdLineError x) + else throwGhcException (CmdLineError (x ++ '\n' : renderStack stack)) + + + +-- | Throw a failed assertion exception for a given filename and line number. +assertPanic :: String -> Int -> a +assertPanic file line = + Exception.throw (Exception.AssertionFailed + ("ASSERT failed! file " ++ file ++ ", line " ++ show line)) + + +-- | Like try, but pass through UserInterrupt and Panic exceptions. +-- Used when we want soft failures when reading interface files, for example. +-- TODO: I'm not entirely sure if this is catching what we really want to catch +tryMost :: IO a -> IO (Either SomeException a) +tryMost action = do r <- try action + case r of + Left se -> + case fromException se of + -- Some GhcException's we rethrow, + Just (Signal _) -> throwIO se + Just (Panic _) -> throwIO se + -- others we return + Just _ -> return (Left se) + Nothing -> + case fromException se of + -- All IOExceptions are returned + Just (_ :: IOException) -> + return (Left se) + -- Anything else is rethrown + Nothing -> throwIO se + Right v -> return (Right v) + +-- | We use reference counting for signal handlers +{-# NOINLINE signalHandlersRefCount #-} +#if !defined(mingw32_HOST_OS) +signalHandlersRefCount :: MVar (Word, Maybe (S.Handler,S.Handler + ,S.Handler,S.Handler)) +#else +signalHandlersRefCount :: MVar (Word, Maybe S.Handler) +#endif +signalHandlersRefCount = unsafePerformIO $ newMVar (0,Nothing) + + +-- | Temporarily install standard signal handlers for catching ^C, which just +-- throw an exception in the current thread. +withSignalHandlers :: (ExceptionMonad m, MonadIO m) => m a -> m a +withSignalHandlers act = do + main_thread <- liftIO myThreadId + wtid <- liftIO (mkWeakThreadId main_thread) + + let + interrupt = do + r <- deRefWeak wtid + case r of + Nothing -> return () + Just t -> throwTo t UserInterrupt + +#if !defined(mingw32_HOST_OS) + let installHandlers = do + let installHandler' a b = installHandler a b Nothing + hdlQUIT <- installHandler' sigQUIT (Catch interrupt) + hdlINT <- installHandler' sigINT (Catch interrupt) + -- see #3656; in the future we should install these automatically for + -- all Haskell programs in the same way that we install a ^C handler. + let fatal_signal n = throwTo main_thread (Signal (fromIntegral n)) + hdlHUP <- installHandler' sigHUP (Catch (fatal_signal sigHUP)) + hdlTERM <- installHandler' sigTERM (Catch (fatal_signal sigTERM)) + return (hdlQUIT,hdlINT,hdlHUP,hdlTERM) + + let uninstallHandlers (hdlQUIT,hdlINT,hdlHUP,hdlTERM) = do + _ <- installHandler sigQUIT hdlQUIT Nothing + _ <- installHandler sigINT hdlINT Nothing + _ <- installHandler sigHUP hdlHUP Nothing + _ <- installHandler sigTERM hdlTERM Nothing + return () +#else + -- GHC 6.3+ has support for console events on Windows + -- NOTE: running GHCi under a bash shell for some reason requires + -- you to press Ctrl-Break rather than Ctrl-C to provoke + -- an interrupt. Ctrl-C is getting blocked somewhere, I don't know + -- why --SDM 17/12/2004 + let sig_handler ControlC = interrupt + sig_handler Break = interrupt + sig_handler _ = return () + + let installHandlers = installHandler (Catch sig_handler) + let uninstallHandlers = installHandler -- directly install the old handler +#endif + + -- install signal handlers if necessary + let mayInstallHandlers = liftIO $ modifyMVar_ signalHandlersRefCount $ \case + (0,Nothing) -> do + hdls <- installHandlers + return (1,Just hdls) + (c,oldHandlers) -> return (c+1,oldHandlers) + + -- uninstall handlers if necessary + let mayUninstallHandlers = liftIO $ modifyMVar_ signalHandlersRefCount $ \case + (1,Just hdls) -> do + _ <- uninstallHandlers hdls + return (0,Nothing) + (c,oldHandlers) -> return (c-1,oldHandlers) + + mayInstallHandlers + act `gfinally` mayUninstallHandlers diff --git a/compiler/utils/Platform.hs b/compiler/utils/Platform.hs new file mode 100644 --- /dev/null +++ b/compiler/utils/Platform.hs @@ -0,0 +1,162 @@ + +-- | A description of the platform we're compiling for. +-- +module Platform ( + Platform(..), + Arch(..), + OS(..), + ArmISA(..), + ArmISAExt(..), + ArmABI(..), + PPC_64ABI(..), + + target32Bit, + isARM, + osElfTarget, + osMachOTarget, + osSubsectionsViaSymbols, + platformUsesFrameworks, +) + +where + +import GhcPrelude + +-- | Contains enough information for the native code generator to emit +-- code for this platform. +data Platform + = Platform { + platformArch :: Arch, + platformOS :: OS, + -- Word size in bytes (i.e. normally 4 or 8, + -- for 32bit and 64bit platforms respectively) + platformWordSize :: {-# UNPACK #-} !Int, + platformUnregisterised :: Bool, + platformHasGnuNonexecStack :: Bool, + platformHasIdentDirective :: Bool, + platformHasSubsectionsViaSymbols :: Bool, + platformIsCrossCompiling :: Bool + } + deriving (Read, Show, Eq) + + +-- | Architectures that the native code generator knows about. +-- TODO: It might be nice to extend these constructors with information +-- about what instruction set extensions an architecture might support. +-- +data Arch + = ArchUnknown + | ArchX86 + | ArchX86_64 + | ArchPPC + | ArchPPC_64 + { ppc_64ABI :: PPC_64ABI + } + | ArchSPARC + | ArchSPARC64 + | ArchARM + { armISA :: ArmISA + , armISAExt :: [ArmISAExt] + , armABI :: ArmABI + } + | ArchARM64 + | ArchAlpha + | ArchMipseb + | ArchMipsel + | ArchJavaScript + deriving (Read, Show, Eq) + +isARM :: Arch -> Bool +isARM (ArchARM {}) = True +isARM ArchARM64 = True +isARM _ = False + +-- | Operating systems that the native code generator knows about. +-- Having OSUnknown should produce a sensible default, but no promises. +data OS + = OSUnknown + | OSLinux + | OSDarwin + | OSSolaris2 + | OSMinGW32 + | OSFreeBSD + | OSDragonFly + | OSOpenBSD + | OSNetBSD + | OSKFreeBSD + | OSHaiku + | OSQNXNTO + | OSAIX + | OSHurd + deriving (Read, Show, Eq) + +-- | ARM Instruction Set Architecture, Extensions and ABI +-- +data ArmISA + = ARMv5 + | ARMv6 + | ARMv7 + deriving (Read, Show, Eq) + +data ArmISAExt + = VFPv2 + | VFPv3 + | VFPv3D16 + | NEON + | IWMMX2 + deriving (Read, Show, Eq) + +data ArmABI + = SOFT + | SOFTFP + | HARD + deriving (Read, Show, Eq) + +-- | PowerPC 64-bit ABI +-- +data PPC_64ABI + = ELF_V1 + | ELF_V2 + deriving (Read, Show, Eq) + +-- | This predicate tells us whether the platform is 32-bit. +target32Bit :: Platform -> Bool +target32Bit p = platformWordSize p == 4 + +-- | This predicate tells us whether the OS supports ELF-like shared libraries. +osElfTarget :: OS -> Bool +osElfTarget OSLinux = True +osElfTarget OSFreeBSD = True +osElfTarget OSDragonFly = True +osElfTarget OSOpenBSD = True +osElfTarget OSNetBSD = True +osElfTarget OSSolaris2 = True +osElfTarget OSDarwin = False +osElfTarget OSMinGW32 = False +osElfTarget OSKFreeBSD = True +osElfTarget OSHaiku = True +osElfTarget OSQNXNTO = False +osElfTarget OSAIX = False +osElfTarget OSHurd = True +osElfTarget OSUnknown = False + -- Defaulting to False is safe; it means don't rely on any + -- ELF-specific functionality. It is important to have a default for + -- portability, otherwise we have to answer this question for every + -- new platform we compile on (even unreg). + +-- | This predicate tells us whether the OS support Mach-O shared libraries. +osMachOTarget :: OS -> Bool +osMachOTarget OSDarwin = True +osMachOTarget _ = False + +osUsesFrameworks :: OS -> Bool +osUsesFrameworks OSDarwin = True +osUsesFrameworks _ = False + +platformUsesFrameworks :: Platform -> Bool +platformUsesFrameworks = osUsesFrameworks . platformOS + +osSubsectionsViaSymbols :: OS -> Bool +osSubsectionsViaSymbols OSDarwin = True +osSubsectionsViaSymbols _ = False + diff --git a/compiler/utils/PprColour.hs b/compiler/utils/PprColour.hs new file mode 100644 --- /dev/null +++ b/compiler/utils/PprColour.hs @@ -0,0 +1,101 @@ +module PprColour where +import GhcPrelude + +import Data.Maybe (fromMaybe) +import Util (OverridingBool(..), split) +import Data.Semigroup as Semi + +-- | A colour\/style for use with 'coloured'. +newtype PprColour = PprColour { renderColour :: String } + +instance Semi.Semigroup PprColour where + PprColour s1 <> PprColour s2 = PprColour (s1 <> s2) + +-- | Allow colours to be combined (e.g. bold + red); +-- In case of conflict, right side takes precedence. +instance Monoid PprColour where + mempty = PprColour mempty + mappend = (<>) + +renderColourAfresh :: PprColour -> String +renderColourAfresh c = renderColour (colReset `mappend` c) + +colCustom :: String -> PprColour +colCustom "" = mempty +colCustom s = PprColour ("\27[" ++ s ++ "m") + +colReset :: PprColour +colReset = colCustom "0" + +colBold :: PprColour +colBold = colCustom ";1" + +colBlackFg :: PprColour +colBlackFg = colCustom "30" + +colRedFg :: PprColour +colRedFg = colCustom "31" + +colGreenFg :: PprColour +colGreenFg = colCustom "32" + +colYellowFg :: PprColour +colYellowFg = colCustom "33" + +colBlueFg :: PprColour +colBlueFg = colCustom "34" + +colMagentaFg :: PprColour +colMagentaFg = colCustom "35" + +colCyanFg :: PprColour +colCyanFg = colCustom "36" + +colWhiteFg :: PprColour +colWhiteFg = colCustom "37" + +data Scheme = + Scheme + { sHeader :: PprColour + , sMessage :: PprColour + , sWarning :: PprColour + , sError :: PprColour + , sFatal :: PprColour + , sMargin :: PprColour + } + +defaultScheme :: Scheme +defaultScheme = + Scheme + { sHeader = mempty + , sMessage = colBold + , sWarning = colBold `mappend` colMagentaFg + , sError = colBold `mappend` colRedFg + , sFatal = colBold `mappend` colRedFg + , sMargin = colBold `mappend` colBlueFg + } + +-- | Parse the colour scheme from a string (presumably from the @GHC_COLORS@ +-- environment variable). +parseScheme :: String -> (OverridingBool, Scheme) -> (OverridingBool, Scheme) +parseScheme "always" (_, cs) = (Always, cs) +parseScheme "auto" (_, cs) = (Auto, cs) +parseScheme "never" (_, cs) = (Never, cs) +parseScheme input (b, cs) = + ( b + , Scheme + { sHeader = fromMaybe (sHeader cs) (lookup "header" table) + , sMessage = fromMaybe (sMessage cs) (lookup "message" table) + , sWarning = fromMaybe (sWarning cs) (lookup "warning" table) + , sError = fromMaybe (sError cs) (lookup "error" table) + , sFatal = fromMaybe (sFatal cs) (lookup "fatal" table) + , sMargin = fromMaybe (sMargin cs) (lookup "margin" table) + } + ) + where + table = do + w <- split ':' input + let (k, v') = break (== '=') w + case v' of + '=' : v -> return (k, colCustom v) + _ -> [] diff --git a/compiler/utils/Pretty.hs b/compiler/utils/Pretty.hs new file mode 100644 --- /dev/null +++ b/compiler/utils/Pretty.hs @@ -0,0 +1,1108 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Pretty +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : David Terei +-- Stability : stable +-- Portability : portable +-- +-- John Hughes's and Simon Peyton Jones's Pretty Printer Combinators +-- +-- Based on /The Design of a Pretty-printing Library/ +-- in Advanced Functional Programming, +-- Johan Jeuring and Erik Meijer (eds), LNCS 925 +-- +-- +----------------------------------------------------------------------------- + +{- +Note [Differences between libraries/pretty and compiler/utils/Pretty.hs] + +For historical reasons, there are two different copies of `Pretty` in the GHC +source tree: + * `libraries/pretty` is a submodule containing + https://github.com/haskell/pretty. This is the `pretty` library as released + on hackage. It is used by several other libraries in the GHC source tree + (e.g. template-haskell and Cabal). + * `compiler/utils/Pretty.hs` (this module). It is used by GHC only. + +There is an ongoing effort in https://github.com/haskell/pretty/issues/1 and +https://gitlab.haskell.org/ghc/ghc/issues/10735 to try to get rid of GHC's copy +of Pretty. + +Currently, GHC's copy of Pretty resembles pretty-1.1.2.0, with the following +major differences: + * GHC's copy uses `Faststring` for performance reasons. + * GHC's copy has received a backported bugfix for #12227, which was + released as pretty-1.1.3.4 ("Remove harmful $! forcing in beside", + https://github.com/haskell/pretty/pull/35). + +Other differences are minor. Both copies define some extra functions and +instances not defined in the other copy. To see all differences, do this in a +ghc git tree: + + $ cd libraries/pretty + $ git checkout v1.1.2.0 + $ cd - + $ vimdiff compiler/utils/Pretty.hs \ + libraries/pretty/src/Text/PrettyPrint/HughesPJ.hs + +For parity with `pretty-1.1.2.1`, the following two `pretty` commits would +have to be backported: + * "Resolve foldr-strictness stack overflow bug" + (307b8173f41cd776eae8f547267df6d72bff2d68) + * "Special-case reduce for horiz/vert" + (c57c7a9dfc49617ba8d6e4fcdb019a3f29f1044c) +This has not been done sofar, because these commits seem to cause more +allocation in the compiler (see thomie's comments in +https://github.com/haskell/pretty/pull/9). +-} + +module Pretty ( + + -- * The document type + Doc, TextDetails(..), + + -- * Constructing documents + + -- ** Converting values into documents + char, text, ftext, ptext, ztext, sizedText, zeroWidthText, + int, integer, float, double, rational, hex, + + -- ** Simple derived documents + semi, comma, colon, space, equals, + lparen, rparen, lbrack, rbrack, lbrace, rbrace, + + -- ** Wrapping documents in delimiters + parens, brackets, braces, quotes, quote, doubleQuotes, + maybeParens, + + -- ** Combining documents + empty, + (<>), (<+>), hcat, hsep, + ($$), ($+$), vcat, + sep, cat, + fsep, fcat, + nest, + hang, hangNotEmpty, punctuate, + + -- * Predicates on documents + isEmpty, + + -- * Rendering documents + + -- ** Rendering with a particular style + Style(..), + style, + renderStyle, + Mode(..), + + -- ** General rendering + fullRender, txtPrinter, + + -- ** GHC-specific rendering + printDoc, printDoc_, + bufLeftRender -- performance hack + + ) where + +import GhcPrelude hiding (error) + +import BufWrite +import FastString +import Panic +import System.IO +import Numeric (showHex) + +--for a RULES +import GHC.Base ( unpackCString#, unpackNBytes#, Int(..) ) +import GHC.Ptr ( Ptr(..) ) + +-- Don't import Util( assertPanic ) because it makes a loop in the module structure + + +-- --------------------------------------------------------------------------- +-- The Doc calculus + +{- +Laws for $$ +~~~~~~~~~~~ + (x $$ y) $$ z = x $$ (y $$ z) + empty $$ x = x + x $$ empty = x + + ...ditto $+$... + +Laws for <> +~~~~~~~~~~~ + (x <> y) <> z = x <> (y <> z) + empty <> x = empty + x <> empty = x + + ...ditto <+>... + +Laws for text +~~~~~~~~~~~~~ + text s <> text t = text (s++t) + text "" <> x = x, if x non-empty + +** because of law n6, t2 only holds if x doesn't +** start with `nest'. + + +Laws for nest +~~~~~~~~~~~~~ + nest 0 x = x + nest k (nest k' x) = nest (k+k') x + nest k (x <> y) = nest k x <> nest k y + nest k (x $$ y) = nest k x $$ nest k y + nest k empty = empty + x <> nest k y = x <> y, if x non-empty + +** Note the side condition on ! It is this that +** makes it OK for empty to be a left unit for <>. + +Miscellaneous +~~~~~~~~~~~~~ + (text s <> x) $$ y = text s <> ((text "" <> x) $$ + nest (-length s) y) + + (x $$ y) <> z = x $$ (y <> z) + if y non-empty + + +Laws for list versions +~~~~~~~~~~~~~~~~~~~~~~ + sep (ps++[empty]++qs) = sep (ps ++ qs) + ...ditto hsep, hcat, vcat, fill... + + nest k (sep ps) = sep (map (nest k) ps) + ...ditto hsep, hcat, vcat, fill... + +Laws for oneLiner +~~~~~~~~~~~~~~~~~ + oneLiner (nest k p) = nest k (oneLiner p) + oneLiner (x <> y) = oneLiner x <> oneLiner y + +You might think that the following version of would +be neater: + +<3 NO> (text s <> x) $$ y = text s <> ((empty <> x)) $$ + nest (-length s) y) + +But it doesn't work, for if x=empty, we would have + + text s $$ y = text s <> (empty $$ nest (-length s) y) + = text s <> nest (-length s) y +-} + +-- --------------------------------------------------------------------------- +-- Operator fixity + +infixl 6 <> +infixl 6 <+> +infixl 5 $$, $+$ + + +-- --------------------------------------------------------------------------- +-- The Doc data type + +-- | The abstract type of documents. +-- A Doc represents a *set* of layouts. A Doc with +-- no occurrences of Union or NoDoc represents just one layout. +data Doc + = Empty -- empty + | NilAbove Doc -- text "" $$ x + | TextBeside !TextDetails {-# UNPACK #-} !Int Doc -- text s <> x + | Nest {-# UNPACK #-} !Int Doc -- nest k x + | Union Doc Doc -- ul `union` ur + | NoDoc -- The empty set of documents + | Beside Doc Bool Doc -- True <=> space between + | Above Doc Bool Doc -- True <=> never overlap + +{- +Here are the invariants: + +1) The argument of NilAbove is never Empty. Therefore + a NilAbove occupies at least two lines. + +2) The argument of @TextBeside@ is never @Nest@. + +3) The layouts of the two arguments of @Union@ both flatten to the same + string. + +4) The arguments of @Union@ are either @TextBeside@, or @NilAbove@. + +5) A @NoDoc@ may only appear on the first line of the left argument of an + union. Therefore, the right argument of an union can never be equivalent + to the empty set (@NoDoc@). + +6) An empty document is always represented by @Empty@. It can't be + hidden inside a @Nest@, or a @Union@ of two @Empty@s. + +7) The first line of every layout in the left argument of @Union@ is + longer than the first line of any layout in the right argument. + (1) ensures that the left argument has a first line. In view of + (3), this invariant means that the right argument must have at + least two lines. + +Notice the difference between + * NoDoc (no documents) + * Empty (one empty document; no height and no width) + * text "" (a document containing the empty string; + one line high, but has no width) +-} + + +-- | RDoc is a "reduced GDoc", guaranteed not to have a top-level Above or Beside. +type RDoc = Doc + +-- | The TextDetails data type +-- +-- A TextDetails represents a fragment of text that will be +-- output at some point. +data TextDetails = Chr {-# UNPACK #-} !Char -- ^ A single Char fragment + | Str String -- ^ A whole String fragment + | PStr FastString -- a hashed string + | ZStr FastZString -- a z-encoded string + | LStr {-# UNPACK #-} !PtrString + -- a '\0'-terminated array of bytes + | RStr {-# UNPACK #-} !Int {-# UNPACK #-} !Char + -- a repeated character (e.g., ' ') + +instance Show Doc where + showsPrec _ doc cont = fullRender (mode style) (lineLength style) + (ribbonsPerLine style) + txtPrinter cont doc + + +-- --------------------------------------------------------------------------- +-- Values and Predicates on GDocs and TextDetails + +-- | A document of height and width 1, containing a literal character. +char :: Char -> Doc +char c = textBeside_ (Chr c) 1 Empty + +-- | A document of height 1 containing a literal string. +-- 'text' satisfies the following laws: +-- +-- * @'text' s '<>' 'text' t = 'text' (s'++'t)@ +-- +-- * @'text' \"\" '<>' x = x@, if @x@ non-empty +-- +-- The side condition on the last law is necessary because @'text' \"\"@ +-- has height 1, while 'empty' has no height. +text :: String -> Doc +text s = textBeside_ (Str s) (length s) Empty +{-# NOINLINE [0] text #-} -- Give the RULE a chance to fire + -- It must wait till after phase 1 when + -- the unpackCString first is manifested + +-- RULE that turns (text "abc") into (ptext (A# "abc"#)) to avoid the +-- intermediate packing/unpacking of the string. +{-# RULES "text/str" + forall a. text (unpackCString# a) = ptext (mkPtrString# a) + #-} +{-# RULES "text/unpackNBytes#" + forall p n. text (unpackNBytes# p n) = ptext (PtrString (Ptr p) (I# n)) + #-} + +ftext :: FastString -> Doc +ftext s = textBeside_ (PStr s) (lengthFS s) Empty + +ptext :: PtrString -> Doc +ptext s = textBeside_ (LStr s) (lengthPS s) Empty + +ztext :: FastZString -> Doc +ztext s = textBeside_ (ZStr s) (lengthFZS s) Empty + +-- | Some text with any width. (@text s = sizedText (length s) s@) +sizedText :: Int -> String -> Doc +sizedText l s = textBeside_ (Str s) l Empty + +-- | Some text, but without any width. Use for non-printing text +-- such as a HTML or Latex tags +zeroWidthText :: String -> Doc +zeroWidthText = sizedText 0 + +-- | The empty document, with no height and no width. +-- 'empty' is the identity for '<>', '<+>', '$$' and '$+$', and anywhere +-- in the argument list for 'sep', 'hcat', 'hsep', 'vcat', 'fcat' etc. +empty :: Doc +empty = Empty + +-- | Returns 'True' if the document is empty +isEmpty :: Doc -> Bool +isEmpty Empty = True +isEmpty _ = False + +{- +Q: What is the reason for negative indentation (i.e. argument to indent + is < 0) ? + +A: +This indicates an error in the library client's code. +If we compose a <> b, and the first line of b is more indented than some +other lines of b, the law (<> eats nests) may cause the pretty +printer to produce an invalid layout: + +doc |0123345 +------------------ +d1 |a...| +d2 |...b| + |c...| + +d1<>d2 |ab..| + c|....| + +Consider a <> b, let `s' be the length of the last line of `a', `k' the +indentation of the first line of b, and `k0' the indentation of the +left-most line b_i of b. + +The produced layout will have negative indentation if `k - k0 > s', as +the first line of b will be put on the (s+1)th column, effectively +translating b horizontally by (k-s). Now if the i^th line of b has an +indentation k0 < (k-s), it is translated out-of-page, causing +`negative indentation'. +-} + + +semi :: Doc -- ^ A ';' character +comma :: Doc -- ^ A ',' character +colon :: Doc -- ^ A ':' character +space :: Doc -- ^ A space character +equals :: Doc -- ^ A '=' character +lparen :: Doc -- ^ A '(' character +rparen :: Doc -- ^ A ')' character +lbrack :: Doc -- ^ A '[' character +rbrack :: Doc -- ^ A ']' character +lbrace :: Doc -- ^ A '{' character +rbrace :: Doc -- ^ A '}' character +semi = char ';' +comma = char ',' +colon = char ':' +space = char ' ' +equals = char '=' +lparen = char '(' +rparen = char ')' +lbrack = char '[' +rbrack = char ']' +lbrace = char '{' +rbrace = char '}' + +spaceText, nlText :: TextDetails +spaceText = Chr ' ' +nlText = Chr '\n' + +int :: Int -> Doc -- ^ @int n = text (show n)@ +integer :: Integer -> Doc -- ^ @integer n = text (show n)@ +float :: Float -> Doc -- ^ @float n = text (show n)@ +double :: Double -> Doc -- ^ @double n = text (show n)@ +rational :: Rational -> Doc -- ^ @rational n = text (show n)@ +hex :: Integer -> Doc -- ^ See Note [Print Hexadecimal Literals] +int n = text (show n) +integer n = text (show n) +float n = text (show n) +double n = text (show n) +rational n = text (show n) +hex n = text ('0' : 'x' : padded) + where + str = showHex n "" + strLen = max 1 (length str) + len = 2 ^ (ceiling (logBase 2 (fromIntegral strLen :: Double)) :: Int) + padded = replicate (len - strLen) '0' ++ str + +parens :: Doc -> Doc -- ^ Wrap document in @(...)@ +brackets :: Doc -> Doc -- ^ Wrap document in @[...]@ +braces :: Doc -> Doc -- ^ Wrap document in @{...}@ +quotes :: Doc -> Doc -- ^ Wrap document in @\'...\'@ +quote :: Doc -> Doc +doubleQuotes :: Doc -> Doc -- ^ Wrap document in @\"...\"@ +quotes p = char '`' <> p <> char '\'' +quote p = char '\'' <> p +doubleQuotes p = char '"' <> p <> char '"' +parens p = char '(' <> p <> char ')' +brackets p = char '[' <> p <> char ']' +braces p = char '{' <> p <> char '}' + +{- +Note [Print Hexadecimal Literals] + +Relevant discussions: + * Phabricator: https://phabricator.haskell.org/D4465 + * GHC Trac: https://gitlab.haskell.org/ghc/ghc/issues/14872 + +There is a flag `-dword-hex-literals` that causes literals of +type `Word#` or `Word64#` to be displayed in hexadecimal instead +of decimal when dumping GHC core. It also affects the presentation +of these in GHC's error messages. Additionally, the hexadecimal +encoding of these numbers is zero-padded so that its length is +a power of two. As an example of what this does, +consider the following haskell file `Literals.hs`: + + module Literals where + + alpha :: Int + alpha = 100 + 200 + + beta :: Word -> Word + beta x = x + div maxBound 255 + div 0xFFFFFFFF 255 + 0x0202 + +We get the following dumped core when we compile on a 64-bit +machine with ghc -O2 -fforce-recomp -ddump-simpl -dsuppress-all +-dhex-word-literals literals.hs: + + ==================== Tidy Core ==================== + + ... omitted for brevity ... + + -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} + alpha + alpha = I# 300# + + -- RHS size: {terms: 12, types: 3, coercions: 0, joins: 0/0} + beta + beta + = \ x_aYE -> + case x_aYE of { W# x#_a1v0 -> + W# + (plusWord# + (plusWord# (plusWord# x#_a1v0 0x0101010101010101##) 0x01010101##) + 0x0202##) + } + +Notice that the word literals are in hexadecimals and that they have +been padded with zeroes so that their lengths are 16, 8, and 4, respectively. + +-} + +-- | Apply 'parens' to 'Doc' if boolean is true. +maybeParens :: Bool -> Doc -> Doc +maybeParens False = id +maybeParens True = parens + +-- --------------------------------------------------------------------------- +-- Structural operations on GDocs + +-- | Perform some simplification of a built up @GDoc@. +reduceDoc :: Doc -> RDoc +reduceDoc (Beside p g q) = p `seq` g `seq` (beside p g $! reduceDoc q) +reduceDoc (Above p g q) = p `seq` g `seq` (above p g $! reduceDoc q) +reduceDoc p = p + +-- | List version of '<>'. +hcat :: [Doc] -> Doc +hcat = reduceAB . foldr (beside_' False) empty + +-- | List version of '<+>'. +hsep :: [Doc] -> Doc +hsep = reduceAB . foldr (beside_' True) empty + +-- | List version of '$$'. +vcat :: [Doc] -> Doc +vcat = reduceAB . foldr (above_' False) empty + +-- | Nest (or indent) a document by a given number of positions +-- (which may also be negative). 'nest' satisfies the laws: +-- +-- * @'nest' 0 x = x@ +-- +-- * @'nest' k ('nest' k' x) = 'nest' (k+k') x@ +-- +-- * @'nest' k (x '<>' y) = 'nest' k z '<>' 'nest' k y@ +-- +-- * @'nest' k (x '$$' y) = 'nest' k x '$$' 'nest' k y@ +-- +-- * @'nest' k 'empty' = 'empty'@ +-- +-- * @x '<>' 'nest' k y = x '<>' y@, if @x@ non-empty +-- +-- The side condition on the last law is needed because +-- 'empty' is a left identity for '<>'. +nest :: Int -> Doc -> Doc +nest k p = mkNest k (reduceDoc p) + +-- | @hang d1 n d2 = sep [d1, nest n d2]@ +hang :: Doc -> Int -> Doc -> Doc +hang d1 n d2 = sep [d1, nest n d2] + +-- | Apply 'hang' to the arguments if the first 'Doc' is not empty. +hangNotEmpty :: Doc -> Int -> Doc -> Doc +hangNotEmpty d1 n d2 = if isEmpty d1 + then d2 + else hang d1 n d2 + +-- | @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@ +punctuate :: Doc -> [Doc] -> [Doc] +punctuate _ [] = [] +punctuate p (x:xs) = go x xs + where go y [] = [y] + go y (z:zs) = (y <> p) : go z zs + +-- mkNest checks for Nest's invariant that it doesn't have an Empty inside it +mkNest :: Int -> Doc -> Doc +mkNest k _ | k `seq` False = undefined +mkNest k (Nest k1 p) = mkNest (k + k1) p +mkNest _ NoDoc = NoDoc +mkNest _ Empty = Empty +mkNest 0 p = p +mkNest k p = nest_ k p + +-- mkUnion checks for an empty document +mkUnion :: Doc -> Doc -> Doc +mkUnion Empty _ = Empty +mkUnion p q = p `union_` q + +beside_' :: Bool -> Doc -> Doc -> Doc +beside_' _ p Empty = p +beside_' g p q = Beside p g q + +above_' :: Bool -> Doc -> Doc -> Doc +above_' _ p Empty = p +above_' g p q = Above p g q + +reduceAB :: Doc -> Doc +reduceAB (Above Empty _ q) = q +reduceAB (Beside Empty _ q) = q +reduceAB doc = doc + +nilAbove_ :: RDoc -> RDoc +nilAbove_ = NilAbove + +-- Arg of a TextBeside is always an RDoc +textBeside_ :: TextDetails -> Int -> RDoc -> RDoc +textBeside_ = TextBeside + +nest_ :: Int -> RDoc -> RDoc +nest_ = Nest + +union_ :: RDoc -> RDoc -> RDoc +union_ = Union + + +-- --------------------------------------------------------------------------- +-- Vertical composition @$$@ + +-- | Above, except that if the last line of the first argument stops +-- at least one position before the first line of the second begins, +-- these two lines are overlapped. For example: +-- +-- > text "hi" $$ nest 5 (text "there") +-- +-- lays out as +-- +-- > hi there +-- +-- rather than +-- +-- > hi +-- > there +-- +-- '$$' is associative, with identity 'empty', and also satisfies +-- +-- * @(x '$$' y) '<>' z = x '$$' (y '<>' z)@, if @y@ non-empty. +-- +($$) :: Doc -> Doc -> Doc +p $$ q = above_ p False q + +-- | Above, with no overlapping. +-- '$+$' is associative, with identity 'empty'. +($+$) :: Doc -> Doc -> Doc +p $+$ q = above_ p True q + +above_ :: Doc -> Bool -> Doc -> Doc +above_ p _ Empty = p +above_ Empty _ q = q +above_ p g q = Above p g q + +above :: Doc -> Bool -> RDoc -> RDoc +above (Above p g1 q1) g2 q2 = above p g1 (above q1 g2 q2) +above p@(Beside{}) g q = aboveNest (reduceDoc p) g 0 (reduceDoc q) +above p g q = aboveNest p g 0 (reduceDoc q) + +-- Specification: aboveNest p g k q = p $g$ (nest k q) +aboveNest :: RDoc -> Bool -> Int -> RDoc -> RDoc +aboveNest _ _ k _ | k `seq` False = undefined +aboveNest NoDoc _ _ _ = NoDoc +aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_` + aboveNest p2 g k q + +aboveNest Empty _ k q = mkNest k q +aboveNest (Nest k1 p) g k q = nest_ k1 (aboveNest p g (k - k1) q) + -- p can't be Empty, so no need for mkNest + +aboveNest (NilAbove p) g k q = nilAbove_ (aboveNest p g k q) +aboveNest (TextBeside s sl p) g k q = textBeside_ s sl rest + where + !k1 = k - sl + rest = case p of + Empty -> nilAboveNest g k1 q + _ -> aboveNest p g k1 q +aboveNest (Above {}) _ _ _ = error "aboveNest Above" +aboveNest (Beside {}) _ _ _ = error "aboveNest Beside" + +-- Specification: text s <> nilaboveNest g k q +-- = text s <> (text "" $g$ nest k q) +nilAboveNest :: Bool -> Int -> RDoc -> RDoc +nilAboveNest _ k _ | k `seq` False = undefined +nilAboveNest _ _ Empty = Empty + -- Here's why the "text s <>" is in the spec! +nilAboveNest g k (Nest k1 q) = nilAboveNest g (k + k1) q +nilAboveNest g k q | not g && k > 0 -- No newline if no overlap + = textBeside_ (RStr k ' ') k q + | otherwise -- Put them really above + = nilAbove_ (mkNest k q) + + +-- --------------------------------------------------------------------------- +-- Horizontal composition @<>@ + +-- We intentionally avoid Data.Monoid.(<>) here due to interactions of +-- Data.Monoid.(<>) and (<+>). See +-- http://www.haskell.org/pipermail/libraries/2011-November/017066.html + +-- | Beside. +-- '<>' is associative, with identity 'empty'. +(<>) :: Doc -> Doc -> Doc +p <> q = beside_ p False q + +-- | Beside, separated by space, unless one of the arguments is 'empty'. +-- '<+>' is associative, with identity 'empty'. +(<+>) :: Doc -> Doc -> Doc +p <+> q = beside_ p True q + +beside_ :: Doc -> Bool -> Doc -> Doc +beside_ p _ Empty = p +beside_ Empty _ q = q +beside_ p g q = Beside p g q + +-- Specification: beside g p q = p q +beside :: Doc -> Bool -> RDoc -> RDoc +beside NoDoc _ _ = NoDoc +beside (p1 `Union` p2) g q = beside p1 g q `union_` beside p2 g q +beside Empty _ q = q +beside (Nest k p) g q = nest_ k $! beside p g q +beside p@(Beside p1 g1 q1) g2 q2 + | g1 == g2 = beside p1 g1 $! beside q1 g2 q2 + | otherwise = beside (reduceDoc p) g2 q2 +beside p@(Above{}) g q = let !d = reduceDoc p in beside d g q +beside (NilAbove p) g q = nilAbove_ $! beside p g q +beside (TextBeside s sl p) g q = textBeside_ s sl rest + where + rest = case p of + Empty -> nilBeside g q + _ -> beside p g q + +-- Specification: text "" <> nilBeside g p +-- = text "" p +nilBeside :: Bool -> RDoc -> RDoc +nilBeside _ Empty = Empty -- Hence the text "" in the spec +nilBeside g (Nest _ p) = nilBeside g p +nilBeside g p | g = textBeside_ spaceText 1 p + | otherwise = p + + +-- --------------------------------------------------------------------------- +-- Separate, @sep@ + +-- Specification: sep ps = oneLiner (hsep ps) +-- `union` +-- vcat ps + +-- | Either 'hsep' or 'vcat'. +sep :: [Doc] -> Doc +sep = sepX True -- Separate with spaces + +-- | Either 'hcat' or 'vcat'. +cat :: [Doc] -> Doc +cat = sepX False -- Don't + +sepX :: Bool -> [Doc] -> Doc +sepX _ [] = empty +sepX x (p:ps) = sep1 x (reduceDoc p) 0 ps + + +-- Specification: sep1 g k ys = sep (x : map (nest k) ys) +-- = oneLiner (x nest k (hsep ys)) +-- `union` x $$ nest k (vcat ys) +sep1 :: Bool -> RDoc -> Int -> [Doc] -> RDoc +sep1 _ _ k _ | k `seq` False = undefined +sep1 _ NoDoc _ _ = NoDoc +sep1 g (p `Union` q) k ys = sep1 g p k ys `union_` + aboveNest q False k (reduceDoc (vcat ys)) + +sep1 g Empty k ys = mkNest k (sepX g ys) +sep1 g (Nest n p) k ys = nest_ n (sep1 g p (k - n) ys) + +sep1 _ (NilAbove p) k ys = nilAbove_ + (aboveNest p False k (reduceDoc (vcat ys))) +sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k - sl) ys) +sep1 _ (Above {}) _ _ = error "sep1 Above" +sep1 _ (Beside {}) _ _ = error "sep1 Beside" + +-- Specification: sepNB p k ys = sep1 (text "" <> p) k ys +-- Called when we have already found some text in the first item +-- We have to eat up nests +sepNB :: Bool -> Doc -> Int -> [Doc] -> Doc +sepNB g (Nest _ p) k ys + = sepNB g p k ys -- Never triggered, because of invariant (2) +sepNB g Empty k ys + = oneLiner (nilBeside g (reduceDoc rest)) `mkUnion` + -- XXX: TODO: PRETTY: Used to use True here (but GHC used False...) + nilAboveNest False k (reduceDoc (vcat ys)) + where + rest | g = hsep ys + | otherwise = hcat ys +sepNB g p k ys + = sep1 g p k ys + + +-- --------------------------------------------------------------------------- +-- @fill@ + +-- | \"Paragraph fill\" version of 'cat'. +fcat :: [Doc] -> Doc +fcat = fill False + +-- | \"Paragraph fill\" version of 'sep'. +fsep :: [Doc] -> Doc +fsep = fill True + +-- Specification: +-- +-- fill g docs = fillIndent 0 docs +-- +-- fillIndent k [] = [] +-- fillIndent k [p] = p +-- fillIndent k (p1:p2:ps) = +-- oneLiner p1 fillIndent (k + length p1 + g ? 1 : 0) +-- (remove_nests (oneLiner p2) : ps) +-- `Union` +-- (p1 $*$ nest (-k) (fillIndent 0 ps)) +-- +-- $*$ is defined for layouts (not Docs) as +-- layout1 $*$ layout2 | hasMoreThanOneLine layout1 = layout1 $$ layout2 +-- | otherwise = layout1 $+$ layout2 + +fill :: Bool -> [Doc] -> RDoc +fill _ [] = empty +fill g (p:ps) = fill1 g (reduceDoc p) 0 ps + +fill1 :: Bool -> RDoc -> Int -> [Doc] -> Doc +fill1 _ _ k _ | k `seq` False = undefined +fill1 _ NoDoc _ _ = NoDoc +fill1 g (p `Union` q) k ys = fill1 g p k ys `union_` + aboveNest q False k (fill g ys) +fill1 g Empty k ys = mkNest k (fill g ys) +fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k - n) ys) +fill1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (fill g ys)) +fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k - sl) ys) +fill1 _ (Above {}) _ _ = error "fill1 Above" +fill1 _ (Beside {}) _ _ = error "fill1 Beside" + +fillNB :: Bool -> Doc -> Int -> [Doc] -> Doc +fillNB _ _ k _ | k `seq` False = undefined +fillNB g (Nest _ p) k ys = fillNB g p k ys + -- Never triggered, because of invariant (2) +fillNB _ Empty _ [] = Empty +fillNB g Empty k (Empty:ys) = fillNB g Empty k ys +fillNB g Empty k (y:ys) = fillNBE g k y ys +fillNB g p k ys = fill1 g p k ys + + +fillNBE :: Bool -> Int -> Doc -> [Doc] -> Doc +fillNBE g k y ys + = nilBeside g (fill1 g ((elideNest . oneLiner . reduceDoc) y) k' ys) + -- XXX: TODO: PRETTY: Used to use True here (but GHC used False...) + `mkUnion` nilAboveNest False k (fill g (y:ys)) + where k' = if g then k - 1 else k + +elideNest :: Doc -> Doc +elideNest (Nest _ d) = d +elideNest d = d + +-- --------------------------------------------------------------------------- +-- Selecting the best layout + +best :: Int -- Line length + -> Int -- Ribbon length + -> RDoc + -> RDoc -- No unions in here! +best w0 r = get w0 + where + get :: Int -- (Remaining) width of line + -> Doc -> Doc + get w _ | w == 0 && False = undefined + get _ Empty = Empty + get _ NoDoc = NoDoc + get w (NilAbove p) = nilAbove_ (get w p) + get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p) + get w (Nest k p) = nest_ k (get (w - k) p) + get w (p `Union` q) = nicest w r (get w p) (get w q) + get _ (Above {}) = error "best get Above" + get _ (Beside {}) = error "best get Beside" + + get1 :: Int -- (Remaining) width of line + -> Int -- Amount of first line already eaten up + -> Doc -- This is an argument to TextBeside => eat Nests + -> Doc -- No unions in here! + + get1 w _ _ | w == 0 && False = undefined + get1 _ _ Empty = Empty + get1 _ _ NoDoc = NoDoc + get1 w sl (NilAbove p) = nilAbove_ (get (w - sl) p) + get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl + tl) p) + get1 w sl (Nest _ p) = get1 w sl p + get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p) + (get1 w sl q) + get1 _ _ (Above {}) = error "best get1 Above" + get1 _ _ (Beside {}) = error "best get1 Beside" + +nicest :: Int -> Int -> Doc -> Doc -> Doc +nicest !w !r = nicest1 w r 0 + +nicest1 :: Int -> Int -> Int -> Doc -> Doc -> Doc +nicest1 !w !r !sl p q | fits ((w `min` r) - sl) p = p + | otherwise = q + +fits :: Int -- Space available + -> Doc + -> Bool -- True if *first line* of Doc fits in space available +fits n _ | n < 0 = False +fits _ NoDoc = False +fits _ Empty = True +fits _ (NilAbove _) = True +fits n (TextBeside _ sl p) = fits (n - sl) p +fits _ (Above {}) = error "fits Above" +fits _ (Beside {}) = error "fits Beside" +fits _ (Union {}) = error "fits Union" +fits _ (Nest {}) = error "fits Nest" + +-- | @first@ returns its first argument if it is non-empty, otherwise its second. +first :: Doc -> Doc -> Doc +first p q | nonEmptySet p = p -- unused, because (get OneLineMode) is unused + | otherwise = q + +nonEmptySet :: Doc -> Bool +nonEmptySet NoDoc = False +nonEmptySet (_ `Union` _) = True +nonEmptySet Empty = True +nonEmptySet (NilAbove _) = True +nonEmptySet (TextBeside _ _ p) = nonEmptySet p +nonEmptySet (Nest _ p) = nonEmptySet p +nonEmptySet (Above {}) = error "nonEmptySet Above" +nonEmptySet (Beside {}) = error "nonEmptySet Beside" + +-- @oneLiner@ returns the one-line members of the given set of @GDoc@s. +oneLiner :: Doc -> Doc +oneLiner NoDoc = NoDoc +oneLiner Empty = Empty +oneLiner (NilAbove _) = NoDoc +oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p) +oneLiner (Nest k p) = nest_ k (oneLiner p) +oneLiner (p `Union` _) = oneLiner p +oneLiner (Above {}) = error "oneLiner Above" +oneLiner (Beside {}) = error "oneLiner Beside" + + +-- --------------------------------------------------------------------------- +-- Rendering + +-- | A rendering style. +data Style + = Style { mode :: Mode -- ^ The rendering mode + , lineLength :: Int -- ^ Length of line, in chars + , ribbonsPerLine :: Float -- ^ Ratio of line length to ribbon length + } + +-- | The default style (@mode=PageMode, lineLength=100, ribbonsPerLine=1.5@). +style :: Style +style = Style { lineLength = 100, ribbonsPerLine = 1.5, mode = PageMode } + +-- | Rendering mode. +data Mode = PageMode -- ^ Normal + | ZigZagMode -- ^ With zig-zag cuts + | LeftMode -- ^ No indentation, infinitely long lines + | OneLineMode -- ^ All on one line + +-- | Render the @Doc@ to a String using the given @Style@. +renderStyle :: Style -> Doc -> String +renderStyle s = fullRender (mode s) (lineLength s) (ribbonsPerLine s) + txtPrinter "" + +-- | Default TextDetails printer +txtPrinter :: TextDetails -> String -> String +txtPrinter (Chr c) s = c:s +txtPrinter (Str s1) s2 = s1 ++ s2 +txtPrinter (PStr s1) s2 = unpackFS s1 ++ s2 +txtPrinter (ZStr s1) s2 = zString s1 ++ s2 +txtPrinter (LStr s1) s2 = unpackPtrString s1 ++ s2 +txtPrinter (RStr n c) s2 = replicate n c ++ s2 + +-- | The general rendering interface. +fullRender :: Mode -- ^ Rendering mode + -> Int -- ^ Line length + -> Float -- ^ Ribbons per line + -> (TextDetails -> a -> a) -- ^ What to do with text + -> a -- ^ What to do at the end + -> Doc -- ^ The document + -> a -- ^ Result +fullRender OneLineMode _ _ txt end doc + = easyDisplay spaceText (\_ y -> y) txt end (reduceDoc doc) +fullRender LeftMode _ _ txt end doc + = easyDisplay nlText first txt end (reduceDoc doc) + +fullRender m lineLen ribbons txt rest doc + = display m lineLen ribbonLen txt rest doc' + where + doc' = best bestLineLen ribbonLen (reduceDoc doc) + + bestLineLen, ribbonLen :: Int + ribbonLen = round (fromIntegral lineLen / ribbons) + bestLineLen = case m of + ZigZagMode -> maxBound + _ -> lineLen + +easyDisplay :: TextDetails + -> (Doc -> Doc -> Doc) + -> (TextDetails -> a -> a) + -> a + -> Doc + -> a +easyDisplay nlSpaceText choose txt end + = lay + where + lay NoDoc = error "easyDisplay: NoDoc" + lay (Union p q) = lay (choose p q) + lay (Nest _ p) = lay p + lay Empty = end + lay (NilAbove p) = nlSpaceText `txt` lay p + lay (TextBeside s _ p) = s `txt` lay p + lay (Above {}) = error "easyDisplay Above" + lay (Beside {}) = error "easyDisplay Beside" + +display :: Mode -> Int -> Int -> (TextDetails -> a -> a) -> a -> Doc -> a +display m !page_width !ribbon_width txt end doc + = case page_width - ribbon_width of { gap_width -> + case gap_width `quot` 2 of { shift -> + let + lay k _ | k `seq` False = undefined + lay k (Nest k1 p) = lay (k + k1) p + lay _ Empty = end + lay k (NilAbove p) = nlText `txt` lay k p + lay k (TextBeside s sl p) + = case m of + ZigZagMode | k >= gap_width + -> nlText `txt` ( + Str (replicate shift '/') `txt` ( + nlText `txt` + lay1 (k - shift) s sl p )) + + | k < 0 + -> nlText `txt` ( + Str (replicate shift '\\') `txt` ( + nlText `txt` + lay1 (k + shift) s sl p )) + + _ -> lay1 k s sl p + lay _ (Above {}) = error "display lay Above" + lay _ (Beside {}) = error "display lay Beside" + lay _ NoDoc = error "display lay NoDoc" + lay _ (Union {}) = error "display lay Union" + + lay1 !k s !sl p = let !r = k + sl + in indent k (s `txt` lay2 r p) + + lay2 k _ | k `seq` False = undefined + lay2 k (NilAbove p) = nlText `txt` lay k p + lay2 k (TextBeside s sl p) = s `txt` lay2 (k + sl) p + lay2 k (Nest _ p) = lay2 k p + lay2 _ Empty = end + lay2 _ (Above {}) = error "display lay2 Above" + lay2 _ (Beside {}) = error "display lay2 Beside" + lay2 _ NoDoc = error "display lay2 NoDoc" + lay2 _ (Union {}) = error "display lay2 Union" + + indent !n r = RStr n ' ' `txt` r + in + lay 0 doc + }} + +printDoc :: Mode -> Int -> Handle -> Doc -> IO () +-- printDoc adds a newline to the end +printDoc mode cols hdl doc = printDoc_ mode cols hdl (doc $$ text "") + +printDoc_ :: Mode -> Int -> Handle -> Doc -> IO () +-- printDoc_ does not add a newline at the end, so that +-- successive calls can output stuff on the same line +-- Rather like putStr vs putStrLn +printDoc_ LeftMode _ hdl doc + = do { printLeftRender hdl doc; hFlush hdl } +printDoc_ mode pprCols hdl doc + = do { fullRender mode pprCols 1.5 put done doc ; + hFlush hdl } + where + put (Chr c) next = hPutChar hdl c >> next + put (Str s) next = hPutStr hdl s >> next + put (PStr s) next = hPutStr hdl (unpackFS s) >> next + -- NB. not hPutFS, we want this to go through + -- the I/O library's encoding layer. (#3398) + put (ZStr s) next = hPutFZS hdl s >> next + put (LStr s) next = hPutPtrString hdl s >> next + put (RStr n c) next = hPutStr hdl (replicate n c) >> next + + done = return () -- hPutChar hdl '\n' + + -- some versions of hPutBuf will barf if the length is zero +hPutPtrString :: Handle -> PtrString -> IO () +hPutPtrString _handle (PtrString _ 0) = return () +hPutPtrString handle (PtrString a l) = hPutBuf handle a l + +-- Printing output in LeftMode is performance critical: it's used when +-- dumping C and assembly output, so we allow ourselves a few dirty +-- hacks: +-- +-- (1) we specialise fullRender for LeftMode with IO output. +-- +-- (2) we add a layer of buffering on top of Handles. Handles +-- don't perform well with lots of hPutChars, which is mostly +-- what we're doing here, because Handles have to be thread-safe +-- and async exception-safe. We only have a single thread and don't +-- care about exceptions, so we add a layer of fast buffering +-- over the Handle interface. + +printLeftRender :: Handle -> Doc -> IO () +printLeftRender hdl doc = do + b <- newBufHandle hdl + bufLeftRender b doc + bFlush b + +bufLeftRender :: BufHandle -> Doc -> IO () +bufLeftRender b doc = layLeft b (reduceDoc doc) + +layLeft :: BufHandle -> Doc -> IO () +layLeft b _ | b `seq` False = undefined -- make it strict in b +layLeft _ NoDoc = error "layLeft: NoDoc" +layLeft b (Union p q) = layLeft b $! first p q +layLeft b (Nest _ p) = layLeft b $! p +layLeft b Empty = bPutChar b '\n' +layLeft b (NilAbove p) = p `seq` (bPutChar b '\n' >> layLeft b p) +layLeft b (TextBeside s _ p) = s `seq` (put b s >> layLeft b p) + where + put b _ | b `seq` False = undefined + put b (Chr c) = bPutChar b c + put b (Str s) = bPutStr b s + put b (PStr s) = bPutFS b s + put b (ZStr s) = bPutFZS b s + put b (LStr s) = bPutPtrString b s + put b (RStr n c) = bPutReplicate b n c +layLeft _ _ = panic "layLeft: Unhandled case" + +-- Define error=panic, for easier comparison with libraries/pretty. +error :: String -> a +error = panic diff --git a/compiler/utils/StringBuffer.hs b/compiler/utils/StringBuffer.hs new file mode 100644 --- /dev/null +++ b/compiler/utils/StringBuffer.hs @@ -0,0 +1,328 @@ +{- +(c) The University of Glasgow 2006 +(c) The University of Glasgow, 1997-2006 + + +Buffers for scanning string input stored in external arrays. +-} + +{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples #-} +{-# OPTIONS_GHC -O2 #-} +-- We always optimise this, otherwise performance of a non-optimised +-- compiler is severely affected + +module StringBuffer + ( + StringBuffer(..), + -- non-abstract for vs\/HaskellService + + -- * Creation\/destruction + hGetStringBuffer, + hGetStringBufferBlock, + appendStringBuffers, + stringToStringBuffer, + + -- * Inspection + nextChar, + currentChar, + prevChar, + atEnd, + + -- * Moving and comparison + stepOn, + offsetBytes, + byteDiff, + atLine, + + -- * Conversion + lexemeToString, + lexemeToFastString, + decodePrevNChars, + + -- * Parsing integers + parseUnsignedInteger, + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import Encoding +import FastString +import FastFunctions +import Outputable +import Util + +import Data.Maybe +import Control.Exception +import System.IO +import System.IO.Unsafe ( unsafePerformIO ) +import GHC.IO.Encoding.UTF8 ( mkUTF8 ) +import GHC.IO.Encoding.Failure ( CodingFailureMode(IgnoreCodingFailure) ) + +import GHC.Exts + +import Foreign + +-- ----------------------------------------------------------------------------- +-- The StringBuffer type + +-- |A StringBuffer is an internal pointer to a sized chunk of bytes. +-- The bytes are intended to be *immutable*. There are pure +-- operations to read the contents of a StringBuffer. +-- +-- A StringBuffer may have a finalizer, depending on how it was +-- obtained. +-- +data StringBuffer + = StringBuffer { + buf :: {-# UNPACK #-} !(ForeignPtr Word8), + len :: {-# UNPACK #-} !Int, -- length + cur :: {-# UNPACK #-} !Int -- current pos + } + -- The buffer is assumed to be UTF-8 encoded, and furthermore + -- we add three @\'\\0\'@ bytes to the end as sentinels so that the + -- decoder doesn't have to check for overflow at every single byte + -- of a multibyte sequence. + +instance Show StringBuffer where + showsPrec _ s = showString "" + +-- ----------------------------------------------------------------------------- +-- Creation / Destruction + +-- | Read a file into a 'StringBuffer'. The resulting buffer is automatically +-- managed by the garbage collector. +hGetStringBuffer :: FilePath -> IO StringBuffer +hGetStringBuffer fname = do + h <- openBinaryFile fname ReadMode + size_i <- hFileSize h + offset_i <- skipBOM h size_i 0 -- offset is 0 initially + let size = fromIntegral $ size_i - offset_i + buf <- mallocForeignPtrArray (size+3) + withForeignPtr buf $ \ptr -> do + r <- if size == 0 then return 0 else hGetBuf h ptr size + hClose h + if (r /= size) + then ioError (userError "short read of file") + else newUTF8StringBuffer buf ptr size + +hGetStringBufferBlock :: Handle -> Int -> IO StringBuffer +hGetStringBufferBlock handle wanted + = do size_i <- hFileSize handle + offset_i <- hTell handle >>= skipBOM handle size_i + let size = min wanted (fromIntegral $ size_i-offset_i) + buf <- mallocForeignPtrArray (size+3) + withForeignPtr buf $ \ptr -> + do r <- if size == 0 then return 0 else hGetBuf handle ptr size + if r /= size + then ioError (userError $ "short read of file: "++show(r,size,size_i,handle)) + else newUTF8StringBuffer buf ptr size + +-- | Skip the byte-order mark if there is one (see #1744 and #6016), +-- and return the new position of the handle in bytes. +-- +-- This is better than treating #FEFF as whitespace, +-- because that would mess up layout. We don't have a concept +-- of zero-width whitespace in Haskell: all whitespace codepoints +-- have a width of one column. +skipBOM :: Handle -> Integer -> Integer -> IO Integer +skipBOM h size offset = + -- Only skip BOM at the beginning of a file. + if size > 0 && offset == 0 + then do + -- Validate assumption that handle is in binary mode. + ASSERTM( hGetEncoding h >>= return . isNothing ) + -- Temporarily select utf8 encoding with error ignoring, + -- to make `hLookAhead` and `hGetChar` return full Unicode characters. + bracket_ (hSetEncoding h safeEncoding) (hSetBinaryMode h True) $ do + c <- hLookAhead h + if c == '\xfeff' + then hGetChar h >> hTell h + else return offset + else return offset + where + safeEncoding = mkUTF8 IgnoreCodingFailure + +newUTF8StringBuffer :: ForeignPtr Word8 -> Ptr Word8 -> Int -> IO StringBuffer +newUTF8StringBuffer buf ptr size = do + pokeArray (ptr `plusPtr` size :: Ptr Word8) [0,0,0] + -- sentinels for UTF-8 decoding + return $ StringBuffer buf size 0 + +appendStringBuffers :: StringBuffer -> StringBuffer -> IO StringBuffer +appendStringBuffers sb1 sb2 + = do newBuf <- mallocForeignPtrArray (size+3) + withForeignPtr newBuf $ \ptr -> + withForeignPtr (buf sb1) $ \sb1Ptr -> + withForeignPtr (buf sb2) $ \sb2Ptr -> + do copyArray ptr (sb1Ptr `advancePtr` cur sb1) sb1_len + copyArray (ptr `advancePtr` sb1_len) (sb2Ptr `advancePtr` cur sb2) sb2_len + pokeArray (ptr `advancePtr` size) [0,0,0] + return (StringBuffer newBuf size 0) + where sb1_len = calcLen sb1 + sb2_len = calcLen sb2 + calcLen sb = len sb - cur sb + size = sb1_len + sb2_len + +-- | Encode a 'String' into a 'StringBuffer' as UTF-8. The resulting buffer +-- is automatically managed by the garbage collector. +stringToStringBuffer :: String -> StringBuffer +stringToStringBuffer str = + unsafePerformIO $ do + let size = utf8EncodedLength str + buf <- mallocForeignPtrArray (size+3) + withForeignPtr buf $ \ptr -> do + utf8EncodeString ptr str + pokeArray (ptr `plusPtr` size :: Ptr Word8) [0,0,0] + -- sentinels for UTF-8 decoding + return (StringBuffer buf size 0) + +-- ----------------------------------------------------------------------------- +-- Grab a character + +-- | Return the first UTF-8 character of a nonempty 'StringBuffer' and as well +-- the remaining portion (analogous to 'Data.List.uncons'). __Warning:__ The +-- behavior is undefined if the 'StringBuffer' is empty. The result shares +-- the same buffer as the original. Similar to 'utf8DecodeChar', if the +-- character cannot be decoded as UTF-8, @\'\\0\'@ is returned. +{-# INLINE nextChar #-} +nextChar :: StringBuffer -> (Char,StringBuffer) +nextChar (StringBuffer buf len (I# cur#)) = + -- Getting our fingers dirty a little here, but this is performance-critical + inlinePerformIO $ do + withForeignPtr buf $ \(Ptr a#) -> do + case utf8DecodeChar# (a# `plusAddr#` cur#) of + (# c#, nBytes# #) -> + let cur' = I# (cur# +# nBytes#) in + return (C# c#, StringBuffer buf len cur') + +-- | Return the first UTF-8 character of a nonempty 'StringBuffer' (analogous +-- to 'Data.List.head'). __Warning:__ The behavior is undefined if the +-- 'StringBuffer' is empty. Similar to 'utf8DecodeChar', if the character +-- cannot be decoded as UTF-8, @\'\\0\'@ is returned. +currentChar :: StringBuffer -> Char +currentChar = fst . nextChar + +prevChar :: StringBuffer -> Char -> Char +prevChar (StringBuffer _ _ 0) deflt = deflt +prevChar (StringBuffer buf _ cur) _ = + inlinePerformIO $ do + withForeignPtr buf $ \p -> do + p' <- utf8PrevChar (p `plusPtr` cur) + return (fst (utf8DecodeChar p')) + +-- ----------------------------------------------------------------------------- +-- Moving + +-- | Return a 'StringBuffer' with the first UTF-8 character removed (analogous +-- to 'Data.List.tail'). __Warning:__ The behavior is undefined if the +-- 'StringBuffer' is empty. The result shares the same buffer as the +-- original. +stepOn :: StringBuffer -> StringBuffer +stepOn s = snd (nextChar s) + +-- | Return a 'StringBuffer' with the first @n@ bytes removed. __Warning:__ +-- If there aren't enough characters, the returned 'StringBuffer' will be +-- invalid and any use of it may lead to undefined behavior. The result +-- shares the same buffer as the original. +offsetBytes :: Int -- ^ @n@, the number of bytes + -> StringBuffer + -> StringBuffer +offsetBytes i s = s { cur = cur s + i } + +-- | Compute the difference in offset between two 'StringBuffer's that share +-- the same buffer. __Warning:__ The behavior is undefined if the +-- 'StringBuffer's use separate buffers. +byteDiff :: StringBuffer -> StringBuffer -> Int +byteDiff s1 s2 = cur s2 - cur s1 + +-- | Check whether a 'StringBuffer' is empty (analogous to 'Data.List.null'). +atEnd :: StringBuffer -> Bool +atEnd (StringBuffer _ l c) = l == c + +-- | Computes a 'StringBuffer' which points to the first character of the +-- wanted line. Lines begin at 1. +atLine :: Int -> StringBuffer -> Maybe StringBuffer +atLine line sb@(StringBuffer buf len _) = + inlinePerformIO $ + withForeignPtr buf $ \p -> do + p' <- skipToLine line len p + if p' == nullPtr + then return Nothing + else + let + delta = p' `minusPtr` p + in return $ Just (sb { cur = delta + , len = len - delta + }) + +skipToLine :: Int -> Int -> Ptr Word8 -> IO (Ptr Word8) +skipToLine !line !len !op0 = go 1 op0 + where + !opend = op0 `plusPtr` len + + go !i_line !op + | op >= opend = pure nullPtr + | i_line == line = pure op + | otherwise = do + w <- peek op :: IO Word8 + case w of + 10 -> go (i_line + 1) (plusPtr op 1) + 13 -> do + -- this is safe because a 'StringBuffer' is + -- guaranteed to have 3 bytes sentinel values. + w' <- peek (plusPtr op 1) :: IO Word8 + case w' of + 10 -> go (i_line + 1) (plusPtr op 2) + _ -> go (i_line + 1) (plusPtr op 1) + _ -> go i_line (plusPtr op 1) + +-- ----------------------------------------------------------------------------- +-- Conversion + +-- | Decode the first @n@ bytes of a 'StringBuffer' as UTF-8 into a 'String'. +-- Similar to 'utf8DecodeChar', if the character cannot be decoded as UTF-8, +-- they will be replaced with @\'\\0\'@. +lexemeToString :: StringBuffer + -> Int -- ^ @n@, the number of bytes + -> String +lexemeToString _ 0 = "" +lexemeToString (StringBuffer buf _ cur) bytes = + utf8DecodeStringLazy buf cur bytes + +lexemeToFastString :: StringBuffer + -> Int -- ^ @n@, the number of bytes + -> FastString +lexemeToFastString _ 0 = nilFS +lexemeToFastString (StringBuffer buf _ cur) len = + inlinePerformIO $ + withForeignPtr buf $ \ptr -> + return $! mkFastStringBytes (ptr `plusPtr` cur) len + +-- | Return the previous @n@ characters (or fewer if we are less than @n@ +-- characters into the buffer. +decodePrevNChars :: Int -> StringBuffer -> String +decodePrevNChars n (StringBuffer buf _ cur) = + inlinePerformIO $ withForeignPtr buf $ \p0 -> + go p0 n "" (p0 `plusPtr` (cur - 1)) + where + go :: Ptr Word8 -> Int -> String -> Ptr Word8 -> IO String + go buf0 n acc p | n == 0 || buf0 >= p = return acc + go buf0 n acc p = do + p' <- utf8PrevChar p + let (c,_) = utf8DecodeChar p' + go buf0 (n - 1) (c:acc) p' + +-- ----------------------------------------------------------------------------- +-- Parsing integer strings in various bases +parseUnsignedInteger :: StringBuffer -> Int -> Integer -> (Char->Int) -> Integer +parseUnsignedInteger (StringBuffer buf _ cur) len radix char_to_int + = inlinePerformIO $ withForeignPtr buf $ \ptr -> return $! let + go i x | i == len = x + | otherwise = case fst (utf8DecodeChar (ptr `plusPtr` (cur + i))) of + '_' -> go (i + 1) x -- skip "_" (#14473) + char -> go (i + 1) (x * radix + toInteger (char_to_int char)) + in go 0 0 diff --git a/compiler/utils/TrieMap.hs b/compiler/utils/TrieMap.hs new file mode 100644 --- /dev/null +++ b/compiler/utils/TrieMap.hs @@ -0,0 +1,405 @@ +{- +(c) The University of Glasgow 2006 +(c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +-} + +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +module TrieMap( + -- * Maps over 'Maybe' values + MaybeMap, + -- * Maps over 'List' values + ListMap, + -- * Maps over 'Literal's + LiteralMap, + -- * 'TrieMap' class + TrieMap(..), insertTM, deleteTM, + + -- * Things helpful for adding additional Instances. + (>.>), (|>), (|>>), XT, + foldMaybe, + -- * Map for leaf compression + GenMap, + lkG, xtG, mapG, fdG, + xtList, lkList + + ) where + +import GhcPrelude + +import Literal +import UniqDFM +import Unique( Unique ) + +import qualified Data.Map as Map +import qualified Data.IntMap as IntMap +import Outputable +import Control.Monad( (>=>) ) + +{- +This module implements TrieMaps, which are finite mappings +whose key is a structured value like a CoreExpr or Type. + +This file implements tries over general data structures. +Implementation for tries over Core Expressions/Types are +available in coreSyn/TrieMap. + +The regular pattern for handling TrieMaps on data structures was first +described (to my knowledge) in Connelly and Morris's 1995 paper "A +generalization of the Trie Data Structure"; there is also an accessible +description of the idea in Okasaki's book "Purely Functional Data +Structures", Section 10.3.2 + +************************************************************************ +* * + The TrieMap class +* * +************************************************************************ +-} + +type XT a = Maybe a -> Maybe a -- How to alter a non-existent elt (Nothing) + -- or an existing elt (Just) + +class TrieMap m where + type Key m :: * + emptyTM :: m a + lookupTM :: forall b. Key m -> m b -> Maybe b + alterTM :: forall b. Key m -> XT b -> m b -> m b + mapTM :: (a->b) -> m a -> m b + + foldTM :: (a -> b -> b) -> m a -> b -> b + -- The unusual argument order here makes + -- it easy to compose calls to foldTM; + -- see for example fdE below + +insertTM :: TrieMap m => Key m -> a -> m a -> m a +insertTM k v m = alterTM k (\_ -> Just v) m + +deleteTM :: TrieMap m => Key m -> m a -> m a +deleteTM k m = alterTM k (\_ -> Nothing) m + +---------------------- +-- Recall that +-- Control.Monad.(>=>) :: (a -> Maybe b) -> (b -> Maybe c) -> a -> Maybe c + +(>.>) :: (a -> b) -> (b -> c) -> a -> c +-- Reverse function composition (do f first, then g) +infixr 1 >.> +(f >.> g) x = g (f x) +infixr 1 |>, |>> + +(|>) :: a -> (a->b) -> b -- Reverse application +x |> f = f x + +---------------------- +(|>>) :: TrieMap m2 + => (XT (m2 a) -> m1 (m2 a) -> m1 (m2 a)) + -> (m2 a -> m2 a) + -> m1 (m2 a) -> m1 (m2 a) +(|>>) f g = f (Just . g . deMaybe) + +deMaybe :: TrieMap m => Maybe (m a) -> m a +deMaybe Nothing = emptyTM +deMaybe (Just m) = m + +{- +************************************************************************ +* * + IntMaps +* * +************************************************************************ +-} + +instance TrieMap IntMap.IntMap where + type Key IntMap.IntMap = Int + emptyTM = IntMap.empty + lookupTM k m = IntMap.lookup k m + alterTM = xtInt + foldTM k m z = IntMap.foldr k z m + mapTM f m = IntMap.map f m + +xtInt :: Int -> XT a -> IntMap.IntMap a -> IntMap.IntMap a +xtInt k f m = IntMap.alter f k m + +instance Ord k => TrieMap (Map.Map k) where + type Key (Map.Map k) = k + emptyTM = Map.empty + lookupTM = Map.lookup + alterTM k f m = Map.alter f k m + foldTM k m z = Map.foldr k z m + mapTM f m = Map.map f m + + +{- +Note [foldTM determinism] +~~~~~~~~~~~~~~~~~~~~~~~~~ +We want foldTM to be deterministic, which is why we have an instance of +TrieMap for UniqDFM, but not for UniqFM. Here's an example of some things that +go wrong if foldTM is nondeterministic. Consider: + + f a b = return (a <> b) + +Depending on the order that the typechecker generates constraints you +get either: + + f :: (Monad m, Monoid a) => a -> a -> m a + +or: + + f :: (Monoid a, Monad m) => a -> a -> m a + +The generated code will be different after desugaring as the dictionaries +will be bound in different orders, leading to potential ABI incompatibility. + +One way to solve this would be to notice that the typeclasses could be +sorted alphabetically. + +Unfortunately that doesn't quite work with this example: + + f a b = let x = a <> a; y = b <> b in x + +where you infer: + + f :: (Monoid m, Monoid m1) => m1 -> m -> m1 + +or: + + f :: (Monoid m1, Monoid m) => m1 -> m -> m1 + +Here you could decide to take the order of the type variables in the type +according to depth first traversal and use it to order the constraints. + +The real trouble starts when the user enables incoherent instances and +the compiler has to make an arbitrary choice. Consider: + + class T a b where + go :: a -> b -> String + + instance (Show b) => T Int b where + go a b = show a ++ show b + + instance (Show a) => T a Bool where + go a b = show a ++ show b + + f = go 10 True + +GHC is free to choose either dictionary to implement f, but for the sake of +determinism we'd like it to be consistent when compiling the same sources +with the same flags. + +inert_dicts :: DictMap is implemented with a TrieMap. In getUnsolvedInerts it +gets converted to a bag of (Wanted) Cts using a fold. Then in +solve_simple_wanteds it's merged with other WantedConstraints. We want the +conversion to a bag to be deterministic. For that purpose we use UniqDFM +instead of UniqFM to implement the TrieMap. + +See Note [Deterministic UniqFM] in UniqDFM for more details on how it's made +deterministic. +-} + +instance TrieMap UniqDFM where + type Key UniqDFM = Unique + emptyTM = emptyUDFM + lookupTM k m = lookupUDFM m k + alterTM k f m = alterUDFM f m k + foldTM k m z = foldUDFM k z m + mapTM f m = mapUDFM f m + +{- +************************************************************************ +* * + Maybes +* * +************************************************************************ + +If m is a map from k -> val +then (MaybeMap m) is a map from (Maybe k) -> val +-} + +data MaybeMap m a = MM { mm_nothing :: Maybe a, mm_just :: m a } + +instance TrieMap m => TrieMap (MaybeMap m) where + type Key (MaybeMap m) = Maybe (Key m) + emptyTM = MM { mm_nothing = Nothing, mm_just = emptyTM } + lookupTM = lkMaybe lookupTM + alterTM = xtMaybe alterTM + foldTM = fdMaybe + mapTM = mapMb + +mapMb :: TrieMap m => (a->b) -> MaybeMap m a -> MaybeMap m b +mapMb f (MM { mm_nothing = mn, mm_just = mj }) + = MM { mm_nothing = fmap f mn, mm_just = mapTM f mj } + +lkMaybe :: (forall b. k -> m b -> Maybe b) + -> Maybe k -> MaybeMap m a -> Maybe a +lkMaybe _ Nothing = mm_nothing +lkMaybe lk (Just x) = mm_just >.> lk x + +xtMaybe :: (forall b. k -> XT b -> m b -> m b) + -> Maybe k -> XT a -> MaybeMap m a -> MaybeMap m a +xtMaybe _ Nothing f m = m { mm_nothing = f (mm_nothing m) } +xtMaybe tr (Just x) f m = m { mm_just = mm_just m |> tr x f } + +fdMaybe :: TrieMap m => (a -> b -> b) -> MaybeMap m a -> b -> b +fdMaybe k m = foldMaybe k (mm_nothing m) + . foldTM k (mm_just m) + +{- +************************************************************************ +* * + Lists +* * +************************************************************************ +-} + +data ListMap m a + = LM { lm_nil :: Maybe a + , lm_cons :: m (ListMap m a) } + +instance TrieMap m => TrieMap (ListMap m) where + type Key (ListMap m) = [Key m] + emptyTM = LM { lm_nil = Nothing, lm_cons = emptyTM } + lookupTM = lkList lookupTM + alterTM = xtList alterTM + foldTM = fdList + mapTM = mapList + +instance (TrieMap m, Outputable a) => Outputable (ListMap m a) where + ppr m = text "List elts" <+> ppr (foldTM (:) m []) + +mapList :: TrieMap m => (a->b) -> ListMap m a -> ListMap m b +mapList f (LM { lm_nil = mnil, lm_cons = mcons }) + = LM { lm_nil = fmap f mnil, lm_cons = mapTM (mapTM f) mcons } + +lkList :: TrieMap m => (forall b. k -> m b -> Maybe b) + -> [k] -> ListMap m a -> Maybe a +lkList _ [] = lm_nil +lkList lk (x:xs) = lm_cons >.> lk x >=> lkList lk xs + +xtList :: TrieMap m => (forall b. k -> XT b -> m b -> m b) + -> [k] -> XT a -> ListMap m a -> ListMap m a +xtList _ [] f m = m { lm_nil = f (lm_nil m) } +xtList tr (x:xs) f m = m { lm_cons = lm_cons m |> tr x |>> xtList tr xs f } + +fdList :: forall m a b. TrieMap m + => (a -> b -> b) -> ListMap m a -> b -> b +fdList k m = foldMaybe k (lm_nil m) + . foldTM (fdList k) (lm_cons m) + +foldMaybe :: (a -> b -> b) -> Maybe a -> b -> b +foldMaybe _ Nothing b = b +foldMaybe k (Just a) b = k a b + +{- +************************************************************************ +* * + Basic maps +* * +************************************************************************ +-} + +type LiteralMap a = Map.Map Literal a + +{- +************************************************************************ +* * + GenMap +* * +************************************************************************ + +Note [Compressed TrieMap] +~~~~~~~~~~~~~~~~~~~~~~~~~ + +The GenMap constructor augments TrieMaps with leaf compression. This helps +solve the performance problem detailed in #9960: suppose we have a handful +H of entries in a TrieMap, each with a very large key, size K. If you fold over +such a TrieMap you'd expect time O(H). That would certainly be true of an +association list! But with TrieMap we actually have to navigate down a long +singleton structure to get to the elements, so it takes time O(K*H). This +can really hurt on many type-level computation benchmarks: +see for example T9872d. + +The point of a TrieMap is that you need to navigate to the point where only one +key remains, and then things should be fast. So the point of a SingletonMap +is that, once we are down to a single (key,value) pair, we stop and +just use SingletonMap. + +'EmptyMap' provides an even more basic (but essential) optimization: if there is +nothing in the map, don't bother building out the (possibly infinite) recursive +TrieMap structure! + +Compressed triemaps are heavily used by CoreMap. So we have to mark some things +as INLINEABLE to permit specialization. +-} + +data GenMap m a + = EmptyMap + | SingletonMap (Key m) a + | MultiMap (m a) + +instance (Outputable a, Outputable (m a)) => Outputable (GenMap m a) where + ppr EmptyMap = text "Empty map" + ppr (SingletonMap _ v) = text "Singleton map" <+> ppr v + ppr (MultiMap m) = ppr m + +-- TODO undecidable instance +instance (Eq (Key m), TrieMap m) => TrieMap (GenMap m) where + type Key (GenMap m) = Key m + emptyTM = EmptyMap + lookupTM = lkG + alterTM = xtG + foldTM = fdG + mapTM = mapG + +--We want to be able to specialize these functions when defining eg +--tries over (GenMap CoreExpr) which requires INLINEABLE + +{-# INLINEABLE lkG #-} +lkG :: (Eq (Key m), TrieMap m) => Key m -> GenMap m a -> Maybe a +lkG _ EmptyMap = Nothing +lkG k (SingletonMap k' v') | k == k' = Just v' + | otherwise = Nothing +lkG k (MultiMap m) = lookupTM k m + +{-# INLINEABLE xtG #-} +xtG :: (Eq (Key m), TrieMap m) => Key m -> XT a -> GenMap m a -> GenMap m a +xtG k f EmptyMap + = case f Nothing of + Just v -> SingletonMap k v + Nothing -> EmptyMap +xtG k f m@(SingletonMap k' v') + | k' == k + -- The new key matches the (single) key already in the tree. Hence, + -- apply @f@ to @Just v'@ and build a singleton or empty map depending + -- on the 'Just'/'Nothing' response respectively. + = case f (Just v') of + Just v'' -> SingletonMap k' v'' + Nothing -> EmptyMap + | otherwise + -- We've hit a singleton tree for a different key than the one we are + -- searching for. Hence apply @f@ to @Nothing@. If result is @Nothing@ then + -- we can just return the old map. If not, we need a map with *two* + -- entries. The easiest way to do that is to insert two items into an empty + -- map of type @m a@. + = case f Nothing of + Nothing -> m + Just v -> emptyTM |> alterTM k' (const (Just v')) + >.> alterTM k (const (Just v)) + >.> MultiMap +xtG k f (MultiMap m) = MultiMap (alterTM k f m) + +{-# INLINEABLE mapG #-} +mapG :: TrieMap m => (a -> b) -> GenMap m a -> GenMap m b +mapG _ EmptyMap = EmptyMap +mapG f (SingletonMap k v) = SingletonMap k (f v) +mapG f (MultiMap m) = MultiMap (mapTM f m) + +{-# INLINEABLE fdG #-} +fdG :: TrieMap m => (a -> b -> b) -> GenMap m a -> b -> b +fdG _ EmptyMap = \z -> z +fdG k (SingletonMap _ v) = \z -> k v z +fdG k (MultiMap m) = foldTM k m diff --git a/compiler/utils/UniqDFM.hs b/compiler/utils/UniqDFM.hs new file mode 100644 --- /dev/null +++ b/compiler/utils/UniqDFM.hs @@ -0,0 +1,412 @@ +{- +(c) Bartosz Nitka, Facebook, 2015 + +UniqDFM: Specialised deterministic finite maps, for things with @Uniques@. + +Basically, the things need to be in class @Uniquable@, and we use the +@getUnique@ method to grab their @Uniques@. + +This is very similar to @UniqFM@, the major difference being that the order of +folding is not dependent on @Unique@ ordering, giving determinism. +Currently the ordering is determined by insertion order. + +See Note [Unique Determinism] in Unique for explanation why @Unique@ ordering +is not deterministic. +-} + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -Wall #-} + +module UniqDFM ( + -- * Unique-keyed deterministic mappings + UniqDFM, -- abstract type + + -- ** Manipulating those mappings + emptyUDFM, + unitUDFM, + addToUDFM, + addToUDFM_C, + addListToUDFM, + delFromUDFM, + delListFromUDFM, + adjustUDFM, + alterUDFM, + mapUDFM, + plusUDFM, + plusUDFM_C, + lookupUDFM, lookupUDFM_Directly, + elemUDFM, + foldUDFM, + eltsUDFM, + filterUDFM, filterUDFM_Directly, + isNullUDFM, + sizeUDFM, + intersectUDFM, udfmIntersectUFM, + intersectsUDFM, + disjointUDFM, disjointUdfmUfm, + equalKeysUDFM, + minusUDFM, + listToUDFM, + udfmMinusUFM, + partitionUDFM, + anyUDFM, allUDFM, + pprUniqDFM, pprUDFM, + + udfmToList, + udfmToUfm, + nonDetFoldUDFM, + alwaysUnsafeUfmToUdfm, + ) where + +import GhcPrelude + +import Unique ( Uniquable(..), Unique, getKey ) +import Outputable + +import qualified Data.IntMap as M +import Data.Data +import Data.Functor.Classes (Eq1 (..)) +import Data.List (sortBy) +import Data.Function (on) +import qualified Data.Semigroup as Semi +import UniqFM (UniqFM, listToUFM_Directly, nonDetUFMToList, ufmToIntMap) + +-- Note [Deterministic UniqFM] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- A @UniqDFM@ is just like @UniqFM@ with the following additional +-- property: the function `udfmToList` returns the elements in some +-- deterministic order not depending on the Unique key for those elements. +-- +-- If the client of the map performs operations on the map in deterministic +-- order then `udfmToList` returns them in deterministic order. +-- +-- There is an implementation cost: each element is given a serial number +-- as it is added, and `udfmToList` sorts it's result by this serial +-- number. So you should only use `UniqDFM` if you need the deterministic +-- property. +-- +-- `foldUDFM` also preserves determinism. +-- +-- Normal @UniqFM@ when you turn it into a list will use +-- Data.IntMap.toList function that returns the elements in the order of +-- the keys. The keys in @UniqFM@ are always @Uniques@, so you end up with +-- with a list ordered by @Uniques@. +-- The order of @Uniques@ is known to be not stable across rebuilds. +-- See Note [Unique Determinism] in Unique. +-- +-- +-- There's more than one way to implement this. The implementation here tags +-- every value with the insertion time that can later be used to sort the +-- values when asked to convert to a list. +-- +-- An alternative would be to have +-- +-- data UniqDFM ele = UDFM (M.IntMap ele) [ele] +-- +-- where the list determines the order. This makes deletion tricky as we'd +-- only accumulate elements in that list, but makes merging easier as you +-- can just merge both structures independently. +-- Deletion can probably be done in amortized fashion when the size of the +-- list is twice the size of the set. + +-- | A type of values tagged with insertion time +data TaggedVal val = + TaggedVal + val + {-# UNPACK #-} !Int -- ^ insertion time + deriving Data + +taggedFst :: TaggedVal val -> val +taggedFst (TaggedVal v _) = v + +taggedSnd :: TaggedVal val -> Int +taggedSnd (TaggedVal _ i) = i + +instance Eq val => Eq (TaggedVal val) where + (TaggedVal v1 _) == (TaggedVal v2 _) = v1 == v2 + +instance Functor TaggedVal where + fmap f (TaggedVal val i) = TaggedVal (f val) i + +-- | Type of unique deterministic finite maps +data UniqDFM ele = + UDFM + !(M.IntMap (TaggedVal ele)) -- A map where keys are Unique's values and + -- values are tagged with insertion time. + -- The invariant is that all the tags will + -- be distinct within a single map + {-# UNPACK #-} !Int -- Upper bound on the values' insertion + -- time. See Note [Overflow on plusUDFM] + deriving (Data, Functor) + +emptyUDFM :: UniqDFM elt +emptyUDFM = UDFM M.empty 0 + +unitUDFM :: Uniquable key => key -> elt -> UniqDFM elt +unitUDFM k v = UDFM (M.singleton (getKey $ getUnique k) (TaggedVal v 0)) 1 + +-- The new binding always goes to the right of existing ones +addToUDFM :: Uniquable key => UniqDFM elt -> key -> elt -> UniqDFM elt +addToUDFM m k v = addToUDFM_Directly m (getUnique k) v + +-- The new binding always goes to the right of existing ones +addToUDFM_Directly :: UniqDFM elt -> Unique -> elt -> UniqDFM elt +addToUDFM_Directly (UDFM m i) u v + = UDFM (M.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1) + where + tf (TaggedVal new_v _) (TaggedVal _ old_i) = TaggedVal new_v old_i + -- Keep the old tag, but insert the new value + -- This means that udfmToList typically returns elements + -- in the order of insertion, rather than the reverse + +addToUDFM_Directly_C + :: (elt -> elt -> elt) -- old -> new -> result + -> UniqDFM elt + -> Unique -> elt + -> UniqDFM elt +addToUDFM_Directly_C f (UDFM m i) u v + = UDFM (M.insertWith tf (getKey u) (TaggedVal v i) m) (i + 1) + where + tf (TaggedVal new_v _) (TaggedVal old_v old_i) + = TaggedVal (f old_v new_v) old_i + -- Flip the arguments, because M.insertWith uses (new->old->result) + -- but f needs (old->new->result) + -- Like addToUDFM_Directly, keep the old tag + +addToUDFM_C + :: Uniquable key => (elt -> elt -> elt) -- old -> new -> result + -> UniqDFM elt -- old + -> key -> elt -- new + -> UniqDFM elt -- result +addToUDFM_C f m k v = addToUDFM_Directly_C f m (getUnique k) v + +addListToUDFM :: Uniquable key => UniqDFM elt -> [(key,elt)] -> UniqDFM elt +addListToUDFM = foldl' (\m (k, v) -> addToUDFM m k v) + +addListToUDFM_Directly :: UniqDFM elt -> [(Unique,elt)] -> UniqDFM elt +addListToUDFM_Directly = foldl' (\m (k, v) -> addToUDFM_Directly m k v) + +addListToUDFM_Directly_C + :: (elt -> elt -> elt) -> UniqDFM elt -> [(Unique,elt)] -> UniqDFM elt +addListToUDFM_Directly_C f = foldl' (\m (k, v) -> addToUDFM_Directly_C f m k v) + +delFromUDFM :: Uniquable key => UniqDFM elt -> key -> UniqDFM elt +delFromUDFM (UDFM m i) k = UDFM (M.delete (getKey $ getUnique k) m) i + +plusUDFM_C :: (elt -> elt -> elt) -> UniqDFM elt -> UniqDFM elt -> UniqDFM elt +plusUDFM_C f udfml@(UDFM _ i) udfmr@(UDFM _ j) + -- we will use the upper bound on the tag as a proxy for the set size, + -- to insert the smaller one into the bigger one + | i > j = insertUDFMIntoLeft_C f udfml udfmr + | otherwise = insertUDFMIntoLeft_C f udfmr udfml + +-- Note [Overflow on plusUDFM] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- There are multiple ways of implementing plusUDFM. +-- The main problem that needs to be solved is overlap on times of +-- insertion between different keys in two maps. +-- Consider: +-- +-- A = fromList [(a, (x, 1))] +-- B = fromList [(b, (y, 1))] +-- +-- If you merge them naively you end up with: +-- +-- C = fromList [(a, (x, 1)), (b, (y, 1))] +-- +-- Which loses information about ordering and brings us back into +-- non-deterministic world. +-- +-- The solution I considered before would increment the tags on one of the +-- sets by the upper bound of the other set. The problem with this approach +-- is that you'll run out of tags for some merge patterns. +-- Say you start with A with upper bound 1, you merge A with A to get A' and +-- the upper bound becomes 2. You merge A' with A' and the upper bound +-- doubles again. After 64 merges you overflow. +-- This solution would have the same time complexity as plusUFM, namely O(n+m). +-- +-- The solution I ended up with has time complexity of +-- O(m log m + m * min (n+m, W)) where m is the smaller set. +-- It simply inserts the elements of the smaller set into the larger +-- set in the order that they were inserted into the smaller set. That's +-- O(m log m) for extracting the elements from the smaller set in the +-- insertion order and O(m * min(n+m, W)) to insert them into the bigger +-- set. + +plusUDFM :: UniqDFM elt -> UniqDFM elt -> UniqDFM elt +plusUDFM udfml@(UDFM _ i) udfmr@(UDFM _ j) + -- we will use the upper bound on the tag as a proxy for the set size, + -- to insert the smaller one into the bigger one + | i > j = insertUDFMIntoLeft udfml udfmr + | otherwise = insertUDFMIntoLeft udfmr udfml + +insertUDFMIntoLeft :: UniqDFM elt -> UniqDFM elt -> UniqDFM elt +insertUDFMIntoLeft udfml udfmr = addListToUDFM_Directly udfml $ udfmToList udfmr + +insertUDFMIntoLeft_C + :: (elt -> elt -> elt) -> UniqDFM elt -> UniqDFM elt -> UniqDFM elt +insertUDFMIntoLeft_C f udfml udfmr = + addListToUDFM_Directly_C f udfml $ udfmToList udfmr + +lookupUDFM :: Uniquable key => UniqDFM elt -> key -> Maybe elt +lookupUDFM (UDFM m _i) k = taggedFst `fmap` M.lookup (getKey $ getUnique k) m + +lookupUDFM_Directly :: UniqDFM elt -> Unique -> Maybe elt +lookupUDFM_Directly (UDFM m _i) k = taggedFst `fmap` M.lookup (getKey k) m + +elemUDFM :: Uniquable key => key -> UniqDFM elt -> Bool +elemUDFM k (UDFM m _i) = M.member (getKey $ getUnique k) m + +-- | Performs a deterministic fold over the UniqDFM. +-- It's O(n log n) while the corresponding function on `UniqFM` is O(n). +foldUDFM :: (elt -> a -> a) -> a -> UniqDFM elt -> a +foldUDFM k z m = foldr k z (eltsUDFM m) + +-- | Performs a nondeterministic fold over the UniqDFM. +-- It's O(n), same as the corresponding function on `UniqFM`. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetFoldUDFM :: (elt -> a -> a) -> a -> UniqDFM elt -> a +nonDetFoldUDFM k z (UDFM m _i) = foldr k z $ map taggedFst $ M.elems m + +eltsUDFM :: UniqDFM elt -> [elt] +eltsUDFM (UDFM m _i) = + map taggedFst $ sortBy (compare `on` taggedSnd) $ M.elems m + +filterUDFM :: (elt -> Bool) -> UniqDFM elt -> UniqDFM elt +filterUDFM p (UDFM m i) = UDFM (M.filter (\(TaggedVal v _) -> p v) m) i + +filterUDFM_Directly :: (Unique -> elt -> Bool) -> UniqDFM elt -> UniqDFM elt +filterUDFM_Directly p (UDFM m i) = UDFM (M.filterWithKey p' m) i + where + p' k (TaggedVal v _) = p (getUnique k) v + +-- | Converts `UniqDFM` to a list, with elements in deterministic order. +-- It's O(n log n) while the corresponding function on `UniqFM` is O(n). +udfmToList :: UniqDFM elt -> [(Unique, elt)] +udfmToList (UDFM m _i) = + [ (getUnique k, taggedFst v) + | (k, v) <- sortBy (compare `on` (taggedSnd . snd)) $ M.toList m ] + +-- Determines whether two 'UniqDFM's contain the same keys. +equalKeysUDFM :: UniqDFM a -> UniqDFM b -> Bool +equalKeysUDFM (UDFM m1 _) (UDFM m2 _) = liftEq (\_ _ -> True) m1 m2 + +isNullUDFM :: UniqDFM elt -> Bool +isNullUDFM (UDFM m _) = M.null m + +sizeUDFM :: UniqDFM elt -> Int +sizeUDFM (UDFM m _i) = M.size m + +intersectUDFM :: UniqDFM elt -> UniqDFM elt -> UniqDFM elt +intersectUDFM (UDFM x i) (UDFM y _j) = UDFM (M.intersection x y) i + -- M.intersection is left biased, that means the result will only have + -- a subset of elements from the left set, so `i` is a good upper bound. + +udfmIntersectUFM :: UniqDFM elt1 -> UniqFM elt2 -> UniqDFM elt1 +udfmIntersectUFM (UDFM x i) y = UDFM (M.intersection x (ufmToIntMap y)) i + -- M.intersection is left biased, that means the result will only have + -- a subset of elements from the left set, so `i` is a good upper bound. + +intersectsUDFM :: UniqDFM elt -> UniqDFM elt -> Bool +intersectsUDFM x y = isNullUDFM (x `intersectUDFM` y) + +disjointUDFM :: UniqDFM elt -> UniqDFM elt -> Bool +disjointUDFM (UDFM x _i) (UDFM y _j) = M.null (M.intersection x y) + +disjointUdfmUfm :: UniqDFM elt -> UniqFM elt2 -> Bool +disjointUdfmUfm (UDFM x _i) y = M.null (M.intersection x (ufmToIntMap y)) + +minusUDFM :: UniqDFM elt1 -> UniqDFM elt2 -> UniqDFM elt1 +minusUDFM (UDFM x i) (UDFM y _j) = UDFM (M.difference x y) i + -- M.difference returns a subset of a left set, so `i` is a good upper + -- bound. + +udfmMinusUFM :: UniqDFM elt1 -> UniqFM elt2 -> UniqDFM elt1 +udfmMinusUFM (UDFM x i) y = UDFM (M.difference x (ufmToIntMap y)) i + -- M.difference returns a subset of a left set, so `i` is a good upper + -- bound. + +-- | Partition UniqDFM into two UniqDFMs according to the predicate +partitionUDFM :: (elt -> Bool) -> UniqDFM elt -> (UniqDFM elt, UniqDFM elt) +partitionUDFM p (UDFM m i) = + case M.partition (p . taggedFst) m of + (left, right) -> (UDFM left i, UDFM right i) + +-- | Delete a list of elements from a UniqDFM +delListFromUDFM :: Uniquable key => UniqDFM elt -> [key] -> UniqDFM elt +delListFromUDFM = foldl' delFromUDFM + +-- | This allows for lossy conversion from UniqDFM to UniqFM +udfmToUfm :: UniqDFM elt -> UniqFM elt +udfmToUfm (UDFM m _i) = + listToUFM_Directly [(getUnique k, taggedFst tv) | (k, tv) <- M.toList m] + +listToUDFM :: Uniquable key => [(key,elt)] -> UniqDFM elt +listToUDFM = foldl' (\m (k, v) -> addToUDFM m k v) emptyUDFM + +listToUDFM_Directly :: [(Unique, elt)] -> UniqDFM elt +listToUDFM_Directly = foldl' (\m (u, v) -> addToUDFM_Directly m u v) emptyUDFM + +-- | Apply a function to a particular element +adjustUDFM :: Uniquable key => (elt -> elt) -> UniqDFM elt -> key -> UniqDFM elt +adjustUDFM f (UDFM m i) k = UDFM (M.adjust (fmap f) (getKey $ getUnique k) m) i + +-- | The expression (alterUDFM f k map) alters value x at k, or absence +-- thereof. alterUDFM can be used to insert, delete, or update a value in +-- UniqDFM. Use addToUDFM, delFromUDFM or adjustUDFM when possible, they are +-- more efficient. +alterUDFM + :: Uniquable key + => (Maybe elt -> Maybe elt) -- How to adjust + -> UniqDFM elt -- old + -> key -- new + -> UniqDFM elt -- result +alterUDFM f (UDFM m i) k = + UDFM (M.alter alterf (getKey $ getUnique k) m) (i + 1) + where + alterf Nothing = inject $ f Nothing + alterf (Just (TaggedVal v _)) = inject $ f (Just v) + inject Nothing = Nothing + inject (Just v) = Just $ TaggedVal v i + +-- | Map a function over every value in a UniqDFM +mapUDFM :: (elt1 -> elt2) -> UniqDFM elt1 -> UniqDFM elt2 +mapUDFM f (UDFM m i) = UDFM (M.map (fmap f) m) i + +anyUDFM :: (elt -> Bool) -> UniqDFM elt -> Bool +anyUDFM p (UDFM m _i) = M.foldr ((||) . p . taggedFst) False m + +allUDFM :: (elt -> Bool) -> UniqDFM elt -> Bool +allUDFM p (UDFM m _i) = M.foldr ((&&) . p . taggedFst) True m + +instance Semi.Semigroup (UniqDFM a) where + (<>) = plusUDFM + +instance Monoid (UniqDFM a) where + mempty = emptyUDFM + mappend = (Semi.<>) + +-- This should not be used in commited code, provided for convenience to +-- make ad-hoc conversions when developing +alwaysUnsafeUfmToUdfm :: UniqFM elt -> UniqDFM elt +alwaysUnsafeUfmToUdfm = listToUDFM_Directly . nonDetUFMToList + +-- Output-ery + +instance Outputable a => Outputable (UniqDFM a) where + ppr ufm = pprUniqDFM ppr ufm + +pprUniqDFM :: (a -> SDoc) -> UniqDFM a -> SDoc +pprUniqDFM ppr_elt ufm + = brackets $ fsep $ punctuate comma $ + [ ppr uq <+> text ":->" <+> ppr_elt elt + | (uq, elt) <- udfmToList ufm ] + +pprUDFM :: UniqDFM a -- ^ The things to be pretty printed + -> ([a] -> SDoc) -- ^ The pretty printing function to use on the elements + -> SDoc -- ^ 'SDoc' where the things have been pretty + -- printed +pprUDFM ufm pp = pp (eltsUDFM ufm) diff --git a/compiler/utils/UniqDSet.hs b/compiler/utils/UniqDSet.hs new file mode 100644 --- /dev/null +++ b/compiler/utils/UniqDSet.hs @@ -0,0 +1,141 @@ +-- (c) Bartosz Nitka, Facebook, 2015 + +-- | +-- Specialised deterministic sets, for things with @Uniques@ +-- +-- Based on 'UniqDFM's (as you would expect). +-- See Note [Deterministic UniqFM] in UniqDFM for explanation why we need it. +-- +-- Basically, the things need to be in class 'Uniquable'. + +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} + +module UniqDSet ( + -- * Unique set type + UniqDSet, -- type synonym for UniqFM a + getUniqDSet, + pprUniqDSet, + + -- ** Manipulating these sets + delOneFromUniqDSet, delListFromUniqDSet, + emptyUniqDSet, + unitUniqDSet, + mkUniqDSet, + addOneToUniqDSet, addListToUniqDSet, + unionUniqDSets, unionManyUniqDSets, + minusUniqDSet, uniqDSetMinusUniqSet, + intersectUniqDSets, uniqDSetIntersectUniqSet, + foldUniqDSet, + elementOfUniqDSet, + filterUniqDSet, + sizeUniqDSet, + isEmptyUniqDSet, + lookupUniqDSet, + uniqDSetToList, + partitionUniqDSet, + mapUniqDSet + ) where + +import GhcPrelude + +import Outputable +import UniqDFM +import UniqSet +import Unique + +import Data.Coerce +import Data.Data +import qualified Data.Semigroup as Semi + +-- See Note [UniqSet invariant] in UniqSet.hs for why we want a newtype here. +-- Beyond preserving invariants, we may also want to 'override' typeclass +-- instances. + +newtype UniqDSet a = UniqDSet {getUniqDSet' :: UniqDFM a} + deriving (Data, Semi.Semigroup, Monoid) + +emptyUniqDSet :: UniqDSet a +emptyUniqDSet = UniqDSet emptyUDFM + +unitUniqDSet :: Uniquable a => a -> UniqDSet a +unitUniqDSet x = UniqDSet (unitUDFM x x) + +mkUniqDSet :: Uniquable a => [a] -> UniqDSet a +mkUniqDSet = foldl' addOneToUniqDSet emptyUniqDSet + +-- The new element always goes to the right of existing ones. +addOneToUniqDSet :: Uniquable a => UniqDSet a -> a -> UniqDSet a +addOneToUniqDSet (UniqDSet set) x = UniqDSet (addToUDFM set x x) + +addListToUniqDSet :: Uniquable a => UniqDSet a -> [a] -> UniqDSet a +addListToUniqDSet = foldl' addOneToUniqDSet + +delOneFromUniqDSet :: Uniquable a => UniqDSet a -> a -> UniqDSet a +delOneFromUniqDSet (UniqDSet s) = UniqDSet . delFromUDFM s + +delListFromUniqDSet :: Uniquable a => UniqDSet a -> [a] -> UniqDSet a +delListFromUniqDSet (UniqDSet s) = UniqDSet . delListFromUDFM s + +unionUniqDSets :: UniqDSet a -> UniqDSet a -> UniqDSet a +unionUniqDSets (UniqDSet s) (UniqDSet t) = UniqDSet (plusUDFM s t) + +unionManyUniqDSets :: [UniqDSet a] -> UniqDSet a +unionManyUniqDSets [] = emptyUniqDSet +unionManyUniqDSets sets = foldr1 unionUniqDSets sets + +minusUniqDSet :: UniqDSet a -> UniqDSet a -> UniqDSet a +minusUniqDSet (UniqDSet s) (UniqDSet t) = UniqDSet (minusUDFM s t) + +uniqDSetMinusUniqSet :: UniqDSet a -> UniqSet b -> UniqDSet a +uniqDSetMinusUniqSet xs ys + = UniqDSet (udfmMinusUFM (getUniqDSet xs) (getUniqSet ys)) + +intersectUniqDSets :: UniqDSet a -> UniqDSet a -> UniqDSet a +intersectUniqDSets (UniqDSet s) (UniqDSet t) = UniqDSet (intersectUDFM s t) + +uniqDSetIntersectUniqSet :: UniqDSet a -> UniqSet b -> UniqDSet a +uniqDSetIntersectUniqSet xs ys + = UniqDSet (udfmIntersectUFM (getUniqDSet xs) (getUniqSet ys)) + +foldUniqDSet :: (a -> b -> b) -> b -> UniqDSet a -> b +foldUniqDSet c n (UniqDSet s) = foldUDFM c n s + +elementOfUniqDSet :: Uniquable a => a -> UniqDSet a -> Bool +elementOfUniqDSet k = elemUDFM k . getUniqDSet + +filterUniqDSet :: (a -> Bool) -> UniqDSet a -> UniqDSet a +filterUniqDSet p (UniqDSet s) = UniqDSet (filterUDFM p s) + +sizeUniqDSet :: UniqDSet a -> Int +sizeUniqDSet = sizeUDFM . getUniqDSet + +isEmptyUniqDSet :: UniqDSet a -> Bool +isEmptyUniqDSet = isNullUDFM . getUniqDSet + +lookupUniqDSet :: Uniquable a => UniqDSet a -> a -> Maybe a +lookupUniqDSet = lookupUDFM . getUniqDSet + +uniqDSetToList :: UniqDSet a -> [a] +uniqDSetToList = eltsUDFM . getUniqDSet + +partitionUniqDSet :: (a -> Bool) -> UniqDSet a -> (UniqDSet a, UniqDSet a) +partitionUniqDSet p = coerce . partitionUDFM p . getUniqDSet + +-- See Note [UniqSet invariant] in UniqSet.hs +mapUniqDSet :: Uniquable b => (a -> b) -> UniqDSet a -> UniqDSet b +mapUniqDSet f = mkUniqDSet . map f . uniqDSetToList + +-- Two 'UniqDSet's are considered equal if they contain the same +-- uniques. +instance Eq (UniqDSet a) where + UniqDSet a == UniqDSet b = equalKeysUDFM a b + +getUniqDSet :: UniqDSet a -> UniqDFM a +getUniqDSet = getUniqDSet' + +instance Outputable a => Outputable (UniqDSet a) where + ppr = pprUniqDSet ppr + +pprUniqDSet :: (a -> SDoc) -> UniqDSet a -> SDoc +pprUniqDSet f = braces . pprWithCommas f . uniqDSetToList diff --git a/compiler/utils/UniqFM.hs b/compiler/utils/UniqFM.hs new file mode 100644 --- /dev/null +++ b/compiler/utils/UniqFM.hs @@ -0,0 +1,393 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1994-1998 + + +UniqFM: Specialised finite maps, for things with @Uniques@. + +Basically, the things need to be in class @Uniquable@, and we use the +@getUnique@ method to grab their @Uniques@. + +(A similar thing to @UniqSet@, as opposed to @Set@.) + +The interface is based on @FiniteMap@s, but the implementation uses +@Data.IntMap@, which is both maintained and faster than the past +implementation (see commit log). + +The @UniqFM@ interface maps directly to Data.IntMap, only +``Data.IntMap.union'' is left-biased and ``plusUFM'' right-biased +and ``addToUFM\_C'' and ``Data.IntMap.insertWith'' differ in the order +of arguments of combining function. +-} + +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# OPTIONS_GHC -Wall #-} + +module UniqFM ( + -- * Unique-keyed mappings + UniqFM, -- abstract type + + -- ** Manipulating those mappings + emptyUFM, + unitUFM, + unitDirectlyUFM, + listToUFM, + listToUFM_Directly, + listToUFM_C, + addToUFM,addToUFM_C,addToUFM_Acc, + addListToUFM,addListToUFM_C, + addToUFM_Directly, + addListToUFM_Directly, + adjustUFM, alterUFM, + adjustUFM_Directly, + delFromUFM, + delFromUFM_Directly, + delListFromUFM, + delListFromUFM_Directly, + plusUFM, + plusUFM_C, + plusUFM_CD, + plusMaybeUFM_C, + plusUFMList, + minusUFM, + intersectUFM, + intersectUFM_C, + disjointUFM, + equalKeysUFM, + nonDetFoldUFM, foldUFM, nonDetFoldUFM_Directly, + anyUFM, allUFM, seqEltsUFM, + mapUFM, mapUFM_Directly, + elemUFM, elemUFM_Directly, + filterUFM, filterUFM_Directly, partitionUFM, + sizeUFM, + isNullUFM, + lookupUFM, lookupUFM_Directly, + lookupWithDefaultUFM, lookupWithDefaultUFM_Directly, + nonDetEltsUFM, eltsUFM, nonDetKeysUFM, + ufmToSet_Directly, + nonDetUFMToList, ufmToIntMap, + pprUniqFM, pprUFM, pprUFMWithKeys, pluralUFM + ) where + +import GhcPrelude + +import Unique ( Uniquable(..), Unique, getKey ) +import Outputable + +import qualified Data.IntMap as M +import qualified Data.IntSet as S +import Data.Data +import qualified Data.Semigroup as Semi +import Data.Functor.Classes (Eq1 (..)) + + +newtype UniqFM ele = UFM (M.IntMap ele) + deriving (Data, Eq, Functor) + -- We used to derive Traversable and Foldable, but they were nondeterministic + -- and not obvious at the call site. You can use explicit nonDetEltsUFM + -- and fold a list if needed. + -- See Note [Deterministic UniqFM] in UniqDFM to learn about determinism. + +emptyUFM :: UniqFM elt +emptyUFM = UFM M.empty + +isNullUFM :: UniqFM elt -> Bool +isNullUFM (UFM m) = M.null m + +unitUFM :: Uniquable key => key -> elt -> UniqFM elt +unitUFM k v = UFM (M.singleton (getKey $ getUnique k) v) + +-- when you've got the Unique already +unitDirectlyUFM :: Unique -> elt -> UniqFM elt +unitDirectlyUFM u v = UFM (M.singleton (getKey u) v) + +listToUFM :: Uniquable key => [(key,elt)] -> UniqFM elt +listToUFM = foldl' (\m (k, v) -> addToUFM m k v) emptyUFM + +listToUFM_Directly :: [(Unique, elt)] -> UniqFM elt +listToUFM_Directly = foldl' (\m (u, v) -> addToUFM_Directly m u v) emptyUFM + +listToUFM_C + :: Uniquable key + => (elt -> elt -> elt) + -> [(key, elt)] + -> UniqFM elt +listToUFM_C f = foldl' (\m (k, v) -> addToUFM_C f m k v) emptyUFM + +addToUFM :: Uniquable key => UniqFM elt -> key -> elt -> UniqFM elt +addToUFM (UFM m) k v = UFM (M.insert (getKey $ getUnique k) v m) + +addListToUFM :: Uniquable key => UniqFM elt -> [(key,elt)] -> UniqFM elt +addListToUFM = foldl' (\m (k, v) -> addToUFM m k v) + +addListToUFM_Directly :: UniqFM elt -> [(Unique,elt)] -> UniqFM elt +addListToUFM_Directly = foldl' (\m (k, v) -> addToUFM_Directly m k v) + +addToUFM_Directly :: UniqFM elt -> Unique -> elt -> UniqFM elt +addToUFM_Directly (UFM m) u v = UFM (M.insert (getKey u) v m) + +addToUFM_C + :: Uniquable key + => (elt -> elt -> elt) -- old -> new -> result + -> UniqFM elt -- old + -> key -> elt -- new + -> UniqFM elt -- result +-- Arguments of combining function of M.insertWith and addToUFM_C are flipped. +addToUFM_C f (UFM m) k v = + UFM (M.insertWith (flip f) (getKey $ getUnique k) v m) + +addToUFM_Acc + :: Uniquable key + => (elt -> elts -> elts) -- Add to existing + -> (elt -> elts) -- New element + -> UniqFM elts -- old + -> key -> elt -- new + -> UniqFM elts -- result +addToUFM_Acc exi new (UFM m) k v = + UFM (M.insertWith (\_new old -> exi v old) (getKey $ getUnique k) (new v) m) + +alterUFM + :: Uniquable key + => (Maybe elt -> Maybe elt) -- How to adjust + -> UniqFM elt -- old + -> key -- new + -> UniqFM elt -- result +alterUFM f (UFM m) k = UFM (M.alter f (getKey $ getUnique k) m) + +addListToUFM_C + :: Uniquable key + => (elt -> elt -> elt) + -> UniqFM elt -> [(key,elt)] + -> UniqFM elt +addListToUFM_C f = foldl' (\m (k, v) -> addToUFM_C f m k v) + +adjustUFM :: Uniquable key => (elt -> elt) -> UniqFM elt -> key -> UniqFM elt +adjustUFM f (UFM m) k = UFM (M.adjust f (getKey $ getUnique k) m) + +adjustUFM_Directly :: (elt -> elt) -> UniqFM elt -> Unique -> UniqFM elt +adjustUFM_Directly f (UFM m) u = UFM (M.adjust f (getKey u) m) + +delFromUFM :: Uniquable key => UniqFM elt -> key -> UniqFM elt +delFromUFM (UFM m) k = UFM (M.delete (getKey $ getUnique k) m) + +delListFromUFM :: Uniquable key => UniqFM elt -> [key] -> UniqFM elt +delListFromUFM = foldl' delFromUFM + +delListFromUFM_Directly :: UniqFM elt -> [Unique] -> UniqFM elt +delListFromUFM_Directly = foldl' delFromUFM_Directly + +delFromUFM_Directly :: UniqFM elt -> Unique -> UniqFM elt +delFromUFM_Directly (UFM m) u = UFM (M.delete (getKey u) m) + +-- Bindings in right argument shadow those in the left +plusUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt +-- M.union is left-biased, plusUFM should be right-biased. +plusUFM (UFM x) (UFM y) = UFM (M.union y x) + -- Note (M.union y x), with arguments flipped + -- M.union is left-biased, plusUFM should be right-biased. + +plusUFM_C :: (elt -> elt -> elt) -> UniqFM elt -> UniqFM elt -> UniqFM elt +plusUFM_C f (UFM x) (UFM y) = UFM (M.unionWith f x y) + +-- | `plusUFM_CD f m1 d1 m2 d2` merges the maps using `f` as the +-- combinding function and `d1` resp. `d2` as the default value if +-- there is no entry in `m1` reps. `m2`. The domain is the union of +-- the domains of `m1` and `m2`. +-- +-- Representative example: +-- +-- @ +-- plusUFM_CD f {A: 1, B: 2} 23 {B: 3, C: 4} 42 +-- == {A: f 1 42, B: f 2 3, C: f 23 4 } +-- @ +plusUFM_CD + :: (elt -> elt -> elt) + -> UniqFM elt -- map X + -> elt -- default for X + -> UniqFM elt -- map Y + -> elt -- default for Y + -> UniqFM elt +plusUFM_CD f (UFM xm) dx (UFM ym) dy + = UFM $ M.mergeWithKey + (\_ x y -> Just (x `f` y)) + (M.map (\x -> x `f` dy)) + (M.map (\y -> dx `f` y)) + xm ym + +plusMaybeUFM_C :: (elt -> elt -> Maybe elt) + -> UniqFM elt -> UniqFM elt -> UniqFM elt +plusMaybeUFM_C f (UFM xm) (UFM ym) + = UFM $ M.mergeWithKey + (\_ x y -> x `f` y) + id + id + xm ym + +plusUFMList :: [UniqFM elt] -> UniqFM elt +plusUFMList = foldl' plusUFM emptyUFM + +minusUFM :: UniqFM elt1 -> UniqFM elt2 -> UniqFM elt1 +minusUFM (UFM x) (UFM y) = UFM (M.difference x y) + +intersectUFM :: UniqFM elt1 -> UniqFM elt2 -> UniqFM elt1 +intersectUFM (UFM x) (UFM y) = UFM (M.intersection x y) + +intersectUFM_C + :: (elt1 -> elt2 -> elt3) + -> UniqFM elt1 + -> UniqFM elt2 + -> UniqFM elt3 +intersectUFM_C f (UFM x) (UFM y) = UFM (M.intersectionWith f x y) + +disjointUFM :: UniqFM elt1 -> UniqFM elt2 -> Bool +disjointUFM (UFM x) (UFM y) = M.null (M.intersection x y) + +foldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a +foldUFM k z (UFM m) = M.foldr k z m + +mapUFM :: (elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2 +mapUFM f (UFM m) = UFM (M.map f m) + +mapUFM_Directly :: (Unique -> elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2 +mapUFM_Directly f (UFM m) = UFM (M.mapWithKey (f . getUnique) m) + +filterUFM :: (elt -> Bool) -> UniqFM elt -> UniqFM elt +filterUFM p (UFM m) = UFM (M.filter p m) + +filterUFM_Directly :: (Unique -> elt -> Bool) -> UniqFM elt -> UniqFM elt +filterUFM_Directly p (UFM m) = UFM (M.filterWithKey (p . getUnique) m) + +partitionUFM :: (elt -> Bool) -> UniqFM elt -> (UniqFM elt, UniqFM elt) +partitionUFM p (UFM m) = + case M.partition p m of + (left, right) -> (UFM left, UFM right) + +sizeUFM :: UniqFM elt -> Int +sizeUFM (UFM m) = M.size m + +elemUFM :: Uniquable key => key -> UniqFM elt -> Bool +elemUFM k (UFM m) = M.member (getKey $ getUnique k) m + +elemUFM_Directly :: Unique -> UniqFM elt -> Bool +elemUFM_Directly u (UFM m) = M.member (getKey u) m + +lookupUFM :: Uniquable key => UniqFM elt -> key -> Maybe elt +lookupUFM (UFM m) k = M.lookup (getKey $ getUnique k) m + +-- when you've got the Unique already +lookupUFM_Directly :: UniqFM elt -> Unique -> Maybe elt +lookupUFM_Directly (UFM m) u = M.lookup (getKey u) m + +lookupWithDefaultUFM :: Uniquable key => UniqFM elt -> elt -> key -> elt +lookupWithDefaultUFM (UFM m) v k = M.findWithDefault v (getKey $ getUnique k) m + +lookupWithDefaultUFM_Directly :: UniqFM elt -> elt -> Unique -> elt +lookupWithDefaultUFM_Directly (UFM m) v u = M.findWithDefault v (getKey u) m + +eltsUFM :: UniqFM elt -> [elt] +eltsUFM (UFM m) = M.elems m + +ufmToSet_Directly :: UniqFM elt -> S.IntSet +ufmToSet_Directly (UFM m) = M.keysSet m + +anyUFM :: (elt -> Bool) -> UniqFM elt -> Bool +anyUFM p (UFM m) = M.foldr ((||) . p) False m + +allUFM :: (elt -> Bool) -> UniqFM elt -> Bool +allUFM p (UFM m) = M.foldr ((&&) . p) True m + +seqEltsUFM :: ([elt] -> ()) -> UniqFM elt -> () +seqEltsUFM seqList = seqList . nonDetEltsUFM + -- It's OK to use nonDetEltsUFM here because the type guarantees that + -- the only interesting thing this function can do is to force the + -- elements. + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetEltsUFM :: UniqFM elt -> [elt] +nonDetEltsUFM (UFM m) = M.elems m + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetKeysUFM :: UniqFM elt -> [Unique] +nonDetKeysUFM (UFM m) = map getUnique $ M.keys m + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetFoldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a +nonDetFoldUFM k z (UFM m) = M.foldr k z m + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetFoldUFM_Directly:: (Unique -> elt -> a -> a) -> a -> UniqFM elt -> a +nonDetFoldUFM_Directly k z (UFM m) = M.foldrWithKey (k . getUnique) z m + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetUFMToList :: UniqFM elt -> [(Unique, elt)] +nonDetUFMToList (UFM m) = map (\(k, v) -> (getUnique k, v)) $ M.toList m + +ufmToIntMap :: UniqFM elt -> M.IntMap elt +ufmToIntMap (UFM m) = m + +-- Determines whether two 'UniqFM's contain the same keys. +equalKeysUFM :: UniqFM a -> UniqFM b -> Bool +equalKeysUFM (UFM m1) (UFM m2) = liftEq (\_ _ -> True) m1 m2 + +-- Instances + +instance Semi.Semigroup (UniqFM a) where + (<>) = plusUFM + +instance Monoid (UniqFM a) where + mempty = emptyUFM + mappend = (Semi.<>) + +-- Output-ery + +instance Outputable a => Outputable (UniqFM a) where + ppr ufm = pprUniqFM ppr ufm + +pprUniqFM :: (a -> SDoc) -> UniqFM a -> SDoc +pprUniqFM ppr_elt ufm + = brackets $ fsep $ punctuate comma $ + [ ppr uq <+> text ":->" <+> ppr_elt elt + | (uq, elt) <- nonDetUFMToList ufm ] + -- It's OK to use nonDetUFMToList here because we only use it for + -- pretty-printing. + +-- | Pretty-print a non-deterministic set. +-- The order of variables is non-deterministic and for pretty-printing that +-- shouldn't be a problem. +-- Having this function helps contain the non-determinism created with +-- nonDetEltsUFM. +pprUFM :: UniqFM a -- ^ The things to be pretty printed + -> ([a] -> SDoc) -- ^ The pretty printing function to use on the elements + -> SDoc -- ^ 'SDoc' where the things have been pretty + -- printed +pprUFM ufm pp = pp (nonDetEltsUFM ufm) + +-- | Pretty-print a non-deterministic set. +-- The order of variables is non-deterministic and for pretty-printing that +-- shouldn't be a problem. +-- Having this function helps contain the non-determinism created with +-- nonDetUFMToList. +pprUFMWithKeys + :: UniqFM a -- ^ The things to be pretty printed + -> ([(Unique, a)] -> SDoc) -- ^ The pretty printing function to use on the elements + -> SDoc -- ^ 'SDoc' where the things have been pretty + -- printed +pprUFMWithKeys ufm pp = pp (nonDetUFMToList ufm) + +-- | Determines the pluralisation suffix appropriate for the length of a set +-- in the same way that plural from Outputable does for lists. +pluralUFM :: UniqFM a -> SDoc +pluralUFM ufm + | sizeUFM ufm == 1 = empty + | otherwise = char 's' diff --git a/compiler/utils/UniqSet.hs b/compiler/utils/UniqSet.hs new file mode 100644 --- /dev/null +++ b/compiler/utils/UniqSet.hs @@ -0,0 +1,195 @@ +{- +(c) The University of Glasgow 2006 +(c) The AQUA Project, Glasgow University, 1994-1998 + +\section[UniqSet]{Specialised sets, for things with @Uniques@} + +Based on @UniqFMs@ (as you would expect). + +Basically, the things need to be in class @Uniquable@. +-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} + +module UniqSet ( + -- * Unique set type + UniqSet, -- type synonym for UniqFM a + getUniqSet, + pprUniqSet, + + -- ** Manipulating these sets + emptyUniqSet, + unitUniqSet, + mkUniqSet, + addOneToUniqSet, addListToUniqSet, + delOneFromUniqSet, delOneFromUniqSet_Directly, delListFromUniqSet, + delListFromUniqSet_Directly, + unionUniqSets, unionManyUniqSets, + minusUniqSet, uniqSetMinusUFM, + intersectUniqSets, + restrictUniqSetToUFM, + uniqSetAny, uniqSetAll, + elementOfUniqSet, + elemUniqSet_Directly, + filterUniqSet, + filterUniqSet_Directly, + sizeUniqSet, + isEmptyUniqSet, + lookupUniqSet, + lookupUniqSet_Directly, + partitionUniqSet, + mapUniqSet, + unsafeUFMToUniqSet, + nonDetEltsUniqSet, + nonDetKeysUniqSet, + nonDetFoldUniqSet, + nonDetFoldUniqSet_Directly + ) where + +import GhcPrelude + +import UniqFM +import Unique +import Data.Coerce +import Outputable +import Data.Data +import qualified Data.Semigroup as Semi + +-- Note [UniqSet invariant] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ +-- UniqSet has the following invariant: +-- The keys in the map are the uniques of the values +-- It means that to implement mapUniqSet you have to update +-- both the keys and the values. + +newtype UniqSet a = UniqSet {getUniqSet' :: UniqFM a} + deriving (Data, Semi.Semigroup, Monoid) + +emptyUniqSet :: UniqSet a +emptyUniqSet = UniqSet emptyUFM + +unitUniqSet :: Uniquable a => a -> UniqSet a +unitUniqSet x = UniqSet $ unitUFM x x + +mkUniqSet :: Uniquable a => [a] -> UniqSet a +mkUniqSet = foldl' addOneToUniqSet emptyUniqSet + +addOneToUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a +addOneToUniqSet (UniqSet set) x = UniqSet (addToUFM set x x) + +addListToUniqSet :: Uniquable a => UniqSet a -> [a] -> UniqSet a +addListToUniqSet = foldl' addOneToUniqSet + +delOneFromUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a +delOneFromUniqSet (UniqSet s) a = UniqSet (delFromUFM s a) + +delOneFromUniqSet_Directly :: UniqSet a -> Unique -> UniqSet a +delOneFromUniqSet_Directly (UniqSet s) u = UniqSet (delFromUFM_Directly s u) + +delListFromUniqSet :: Uniquable a => UniqSet a -> [a] -> UniqSet a +delListFromUniqSet (UniqSet s) l = UniqSet (delListFromUFM s l) + +delListFromUniqSet_Directly :: UniqSet a -> [Unique] -> UniqSet a +delListFromUniqSet_Directly (UniqSet s) l = + UniqSet (delListFromUFM_Directly s l) + +unionUniqSets :: UniqSet a -> UniqSet a -> UniqSet a +unionUniqSets (UniqSet s) (UniqSet t) = UniqSet (plusUFM s t) + +unionManyUniqSets :: [UniqSet a] -> UniqSet a +unionManyUniqSets = foldl' (flip unionUniqSets) emptyUniqSet + +minusUniqSet :: UniqSet a -> UniqSet a -> UniqSet a +minusUniqSet (UniqSet s) (UniqSet t) = UniqSet (minusUFM s t) + +intersectUniqSets :: UniqSet a -> UniqSet a -> UniqSet a +intersectUniqSets (UniqSet s) (UniqSet t) = UniqSet (intersectUFM s t) + +restrictUniqSetToUFM :: UniqSet a -> UniqFM b -> UniqSet a +restrictUniqSetToUFM (UniqSet s) m = UniqSet (intersectUFM s m) + +uniqSetMinusUFM :: UniqSet a -> UniqFM b -> UniqSet a +uniqSetMinusUFM (UniqSet s) t = UniqSet (minusUFM s t) + +elementOfUniqSet :: Uniquable a => a -> UniqSet a -> Bool +elementOfUniqSet a (UniqSet s) = elemUFM a s + +elemUniqSet_Directly :: Unique -> UniqSet a -> Bool +elemUniqSet_Directly a (UniqSet s) = elemUFM_Directly a s + +filterUniqSet :: (a -> Bool) -> UniqSet a -> UniqSet a +filterUniqSet p (UniqSet s) = UniqSet (filterUFM p s) + +filterUniqSet_Directly :: (Unique -> elt -> Bool) -> UniqSet elt -> UniqSet elt +filterUniqSet_Directly f (UniqSet s) = UniqSet (filterUFM_Directly f s) + +partitionUniqSet :: (a -> Bool) -> UniqSet a -> (UniqSet a, UniqSet a) +partitionUniqSet p (UniqSet s) = coerce (partitionUFM p s) + +uniqSetAny :: (a -> Bool) -> UniqSet a -> Bool +uniqSetAny p (UniqSet s) = anyUFM p s + +uniqSetAll :: (a -> Bool) -> UniqSet a -> Bool +uniqSetAll p (UniqSet s) = allUFM p s + +sizeUniqSet :: UniqSet a -> Int +sizeUniqSet (UniqSet s) = sizeUFM s + +isEmptyUniqSet :: UniqSet a -> Bool +isEmptyUniqSet (UniqSet s) = isNullUFM s + +lookupUniqSet :: Uniquable a => UniqSet b -> a -> Maybe b +lookupUniqSet (UniqSet s) k = lookupUFM s k + +lookupUniqSet_Directly :: UniqSet a -> Unique -> Maybe a +lookupUniqSet_Directly (UniqSet s) k = lookupUFM_Directly s k + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetEltsUniqSet :: UniqSet elt -> [elt] +nonDetEltsUniqSet = nonDetEltsUFM . getUniqSet' + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetKeysUniqSet :: UniqSet elt -> [Unique] +nonDetKeysUniqSet = nonDetKeysUFM . getUniqSet' + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetFoldUniqSet :: (elt -> a -> a) -> a -> UniqSet elt -> a +nonDetFoldUniqSet c n (UniqSet s) = nonDetFoldUFM c n s + +-- See Note [Deterministic UniqFM] to learn about nondeterminism. +-- If you use this please provide a justification why it doesn't introduce +-- nondeterminism. +nonDetFoldUniqSet_Directly:: (Unique -> elt -> a -> a) -> a -> UniqSet elt -> a +nonDetFoldUniqSet_Directly f n (UniqSet s) = nonDetFoldUFM_Directly f n s + +-- See Note [UniqSet invariant] +mapUniqSet :: Uniquable b => (a -> b) -> UniqSet a -> UniqSet b +mapUniqSet f = mkUniqSet . map f . nonDetEltsUniqSet + +-- Two 'UniqSet's are considered equal if they contain the same +-- uniques. +instance Eq (UniqSet a) where + UniqSet a == UniqSet b = equalKeysUFM a b + +getUniqSet :: UniqSet a -> UniqFM a +getUniqSet = getUniqSet' + +-- | 'unsafeUFMToUniqSet' converts a @'UniqFM' a@ into a @'UniqSet' a@ +-- assuming, without checking, that it maps each 'Unique' to a value +-- that has that 'Unique'. See Note [UniqSet invariant]. +unsafeUFMToUniqSet :: UniqFM a -> UniqSet a +unsafeUFMToUniqSet = UniqSet + +instance Outputable a => Outputable (UniqSet a) where + ppr = pprUniqSet ppr + +pprUniqSet :: (a -> SDoc) -> UniqSet a -> SDoc +-- It's OK to use nonDetUFMToList here because we only use it for +-- pretty-printing. +pprUniqSet f = braces . pprWithCommas f . nonDetEltsUniqSet diff --git a/compiler/utils/Util.hs b/compiler/utils/Util.hs new file mode 100644 --- /dev/null +++ b/compiler/utils/Util.hs @@ -0,0 +1,1505 @@ +-- (c) The University of Glasgow 2006 + +{-# LANGUAGE CPP #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TupleSections #-} + +-- | Highly random utility functions +-- +module Util ( + -- * Flags dependent on the compiler build + ghciSupported, debugIsOn, ncgDebugIsOn, + ghciTablesNextToCode, + isWindowsHost, isDarwinHost, + + -- * General list processing + zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal, + zipLazy, stretchZipWith, zipWithAndUnzip, zipAndUnzip, + + zipWithLazy, zipWith3Lazy, + + filterByList, filterByLists, partitionByList, + + unzipWith, + + mapFst, mapSnd, chkAppend, + mapAndUnzip, mapAndUnzip3, mapAccumL2, + filterOut, partitionWith, + + dropWhileEndLE, spanEnd, last2, lastMaybe, + + foldl1', foldl2, count, countWhile, all2, + + lengthExceeds, lengthIs, lengthIsNot, + lengthAtLeast, lengthAtMost, lengthLessThan, + listLengthCmp, atLength, + equalLength, neLength, compareLength, leLength, ltLength, + + isSingleton, only, singleton, + notNull, snocView, + + isIn, isn'tIn, + + chunkList, + + changeLast, + + -- * Tuples + fstOf3, sndOf3, thdOf3, + firstM, first3M, secondM, + fst3, snd3, third3, + uncurry3, + liftFst, liftSnd, + + -- * List operations controlled by another list + takeList, dropList, splitAtList, split, + dropTail, capitalise, + + -- * For loop + nTimes, + + -- * Sorting + sortWith, minWith, nubSort, ordNub, + + -- * Comparisons + isEqual, eqListBy, eqMaybeBy, + thenCmp, cmpList, + removeSpaces, + (<&&>), (<||>), + + -- * Edit distance + fuzzyMatch, fuzzyLookup, + + -- * Transitive closures + transitiveClosure, + + -- * Strictness + seqList, + + -- * Module names + looksLikeModuleName, + looksLikePackageName, + + -- * Argument processing + getCmd, toCmdArgs, toArgs, + + -- * Integers + exactLog2, + + -- * Floating point + readRational, + readHexRational, + + -- * read helpers + maybeRead, maybeReadFuzzy, + + -- * IO-ish utilities + doesDirNameExist, + getModificationUTCTime, + modificationTimeIfExists, + withAtomicRename, + + global, consIORef, globalM, + sharedGlobal, sharedGlobalM, + + -- * Filenames and paths + Suffix, + splitLongestPrefix, + escapeSpaces, + Direction(..), reslash, + makeRelativeTo, + + -- * Utils for defining Data instances + abstractConstr, abstractDataType, mkNoRepType, + + -- * Utils for printing C code + charToC, + + -- * Hashing + hashString, + + -- * Call stacks + HasCallStack, + HasDebugCallStack, + + -- * Utils for flags + OverridingBool(..), + overrideWith, + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import Exception +import Panic + +import Data.Data +import Data.IORef ( IORef, newIORef, atomicModifyIORef' ) +import System.IO.Unsafe ( unsafePerformIO ) +import Data.List hiding (group) + +import GHC.Exts +import GHC.Stack (HasCallStack) + +import Control.Applicative ( liftA2 ) +import Control.Monad ( liftM, guard ) +import Control.Monad.IO.Class ( MonadIO, liftIO ) +import GHC.Conc.Sync ( sharedCAF ) +import System.IO.Error as IO ( isDoesNotExistError ) +import System.Directory ( doesDirectoryExist, getModificationTime, renameFile ) +import System.FilePath + +import Data.Char ( isUpper, isAlphaNum, isSpace, chr, ord, isDigit, toUpper + , isHexDigit, digitToInt ) +import Data.Int +import Data.Ratio ( (%) ) +import Data.Ord ( comparing ) +import Data.Bits +import Data.Word +import qualified Data.IntMap as IM +import qualified Data.Set as Set + +import Data.Time + +#if defined(DEBUG) +import {-# SOURCE #-} Outputable ( warnPprTrace, text ) +#endif + +infixr 9 `thenCmp` + +{- +************************************************************************ +* * +\subsection{Is DEBUG on, are we on Windows, etc?} +* * +************************************************************************ + +These booleans are global constants, set by CPP flags. They allow us to +recompile a single module (this one) to change whether or not debug output +appears. They sometimes let us avoid even running CPP elsewhere. + +It's important that the flags are literal constants (True/False). Then, +with -0, tests of the flags in other modules will simplify to the correct +branch of the conditional, thereby dropping debug code altogether when +the flags are off. +-} + +ghciSupported :: Bool +#if defined(GHCI) +ghciSupported = True +#else +ghciSupported = False +#endif + +debugIsOn :: Bool +#if defined(DEBUG) +debugIsOn = True +#else +debugIsOn = False +#endif + +ncgDebugIsOn :: Bool +#if defined(NCG_DEBUG) +ncgDebugIsOn = True +#else +ncgDebugIsOn = False +#endif + +ghciTablesNextToCode :: Bool +#if defined(GHCI_TABLES_NEXT_TO_CODE) +ghciTablesNextToCode = True +#else +ghciTablesNextToCode = False +#endif + +isWindowsHost :: Bool +#if defined(mingw32_HOST_OS) +isWindowsHost = True +#else +isWindowsHost = False +#endif + +isDarwinHost :: Bool +#if defined(darwin_HOST_OS) +isDarwinHost = True +#else +isDarwinHost = False +#endif + +{- +************************************************************************ +* * +\subsection{A for loop} +* * +************************************************************************ +-} + +-- | Compose a function with itself n times. (nth rather than twice) +nTimes :: Int -> (a -> a) -> (a -> a) +nTimes 0 _ = id +nTimes 1 f = f +nTimes n f = f . nTimes (n-1) f + +fstOf3 :: (a,b,c) -> a +sndOf3 :: (a,b,c) -> b +thdOf3 :: (a,b,c) -> c +fstOf3 (a,_,_) = a +sndOf3 (_,b,_) = b +thdOf3 (_,_,c) = c + +fst3 :: (a -> d) -> (a, b, c) -> (d, b, c) +fst3 f (a, b, c) = (f a, b, c) + +snd3 :: (b -> d) -> (a, b, c) -> (a, d, c) +snd3 f (a, b, c) = (a, f b, c) + +third3 :: (c -> d) -> (a, b, c) -> (a, b, d) +third3 f (a, b, c) = (a, b, f c) + +uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d +uncurry3 f (a, b, c) = f a b c + +liftFst :: (a -> b) -> (a, c) -> (b, c) +liftFst f (a,c) = (f a, c) + +liftSnd :: (a -> b) -> (c, a) -> (c, b) +liftSnd f (c,a) = (c, f a) + +firstM :: Monad m => (a -> m c) -> (a, b) -> m (c, b) +firstM f (x, y) = liftM (\x' -> (x', y)) (f x) + +first3M :: Monad m => (a -> m d) -> (a, b, c) -> m (d, b, c) +first3M f (x, y, z) = liftM (\x' -> (x', y, z)) (f x) + +secondM :: Monad m => (b -> m c) -> (a, b) -> m (a, c) +secondM f (x, y) = (x,) <$> f y + +{- +************************************************************************ +* * +\subsection[Utils-lists]{General list processing} +* * +************************************************************************ +-} + +filterOut :: (a->Bool) -> [a] -> [a] +-- ^ Like filter, only it reverses the sense of the test +filterOut _ [] = [] +filterOut p (x:xs) | p x = filterOut p xs + | otherwise = x : filterOut p xs + +partitionWith :: (a -> Either b c) -> [a] -> ([b], [c]) +-- ^ Uses a function to determine which of two output lists an input element should join +partitionWith _ [] = ([],[]) +partitionWith f (x:xs) = case f x of + Left b -> (b:bs, cs) + Right c -> (bs, c:cs) + where (bs,cs) = partitionWith f xs + +chkAppend :: [a] -> [a] -> [a] +-- Checks for the second argument being empty +-- Used in situations where that situation is common +chkAppend xs ys + | null ys = xs + | otherwise = xs ++ ys + +{- +A paranoid @zip@ (and some @zipWith@ friends) that checks the lists +are of equal length. Alastair Reid thinks this should only happen if +DEBUGging on; hey, why not? +-} + +zipEqual :: String -> [a] -> [b] -> [(a,b)] +zipWithEqual :: String -> (a->b->c) -> [a]->[b]->[c] +zipWith3Equal :: String -> (a->b->c->d) -> [a]->[b]->[c]->[d] +zipWith4Equal :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e] + +#if !defined(DEBUG) +zipEqual _ = zip +zipWithEqual _ = zipWith +zipWith3Equal _ = zipWith3 +zipWith4Equal _ = zipWith4 +#else +zipEqual _ [] [] = [] +zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs +zipEqual msg _ _ = panic ("zipEqual: unequal lists:"++msg) + +zipWithEqual msg z (a:as) (b:bs)= z a b : zipWithEqual msg z as bs +zipWithEqual _ _ [] [] = [] +zipWithEqual msg _ _ _ = panic ("zipWithEqual: unequal lists:"++msg) + +zipWith3Equal msg z (a:as) (b:bs) (c:cs) + = z a b c : zipWith3Equal msg z as bs cs +zipWith3Equal _ _ [] [] [] = [] +zipWith3Equal msg _ _ _ _ = panic ("zipWith3Equal: unequal lists:"++msg) + +zipWith4Equal msg z (a:as) (b:bs) (c:cs) (d:ds) + = z a b c d : zipWith4Equal msg z as bs cs ds +zipWith4Equal _ _ [] [] [] [] = [] +zipWith4Equal msg _ _ _ _ _ = panic ("zipWith4Equal: unequal lists:"++msg) +#endif + +-- | 'zipLazy' is a kind of 'zip' that is lazy in the second list (observe the ~) +zipLazy :: [a] -> [b] -> [(a,b)] +zipLazy [] _ = [] +zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys + +-- | 'zipWithLazy' is like 'zipWith' but is lazy in the second list. +-- The length of the output is always the same as the length of the first +-- list. +zipWithLazy :: (a -> b -> c) -> [a] -> [b] -> [c] +zipWithLazy _ [] _ = [] +zipWithLazy f (a:as) ~(b:bs) = f a b : zipWithLazy f as bs + +-- | 'zipWith3Lazy' is like 'zipWith3' but is lazy in the second and third lists. +-- The length of the output is always the same as the length of the first +-- list. +zipWith3Lazy :: (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d] +zipWith3Lazy _ [] _ _ = [] +zipWith3Lazy f (a:as) ~(b:bs) ~(c:cs) = f a b c : zipWith3Lazy f as bs cs + +-- | 'filterByList' takes a list of Bools and a list of some elements and +-- filters out these elements for which the corresponding value in the list of +-- Bools is False. This function does not check whether the lists have equal +-- length. +filterByList :: [Bool] -> [a] -> [a] +filterByList (True:bs) (x:xs) = x : filterByList bs xs +filterByList (False:bs) (_:xs) = filterByList bs xs +filterByList _ _ = [] + +-- | 'filterByLists' takes a list of Bools and two lists as input, and +-- outputs a new list consisting of elements from the last two input lists. For +-- each Bool in the list, if it is 'True', then it takes an element from the +-- former list. If it is 'False', it takes an element from the latter list. +-- The elements taken correspond to the index of the Bool in its list. +-- For example: +-- +-- @ +-- filterByLists [True, False, True, False] \"abcd\" \"wxyz\" = \"axcz\" +-- @ +-- +-- This function does not check whether the lists have equal length. +filterByLists :: [Bool] -> [a] -> [a] -> [a] +filterByLists (True:bs) (x:xs) (_:ys) = x : filterByLists bs xs ys +filterByLists (False:bs) (_:xs) (y:ys) = y : filterByLists bs xs ys +filterByLists _ _ _ = [] + +-- | 'partitionByList' takes a list of Bools and a list of some elements and +-- partitions the list according to the list of Bools. Elements corresponding +-- to 'True' go to the left; elements corresponding to 'False' go to the right. +-- For example, @partitionByList [True, False, True] [1,2,3] == ([1,3], [2])@ +-- This function does not check whether the lists have equal +-- length. +partitionByList :: [Bool] -> [a] -> ([a], [a]) +partitionByList = go [] [] + where + go trues falses (True : bs) (x : xs) = go (x:trues) falses bs xs + go trues falses (False : bs) (x : xs) = go trues (x:falses) bs xs + go trues falses _ _ = (reverse trues, reverse falses) + +stretchZipWith :: (a -> Bool) -> b -> (a->b->c) -> [a] -> [b] -> [c] +-- ^ @stretchZipWith p z f xs ys@ stretches @ys@ by inserting @z@ in +-- the places where @p@ returns @True@ + +stretchZipWith _ _ _ [] _ = [] +stretchZipWith p z f (x:xs) ys + | p x = f x z : stretchZipWith p z f xs ys + | otherwise = case ys of + [] -> [] + (y:ys) -> f x y : stretchZipWith p z f xs ys + +mapFst :: (a->c) -> [(a,b)] -> [(c,b)] +mapSnd :: (b->c) -> [(a,b)] -> [(a,c)] + +mapFst f xys = [(f x, y) | (x,y) <- xys] +mapSnd f xys = [(x, f y) | (x,y) <- xys] + +mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c]) + +mapAndUnzip _ [] = ([], []) +mapAndUnzip f (x:xs) + = let (r1, r2) = f x + (rs1, rs2) = mapAndUnzip f xs + in + (r1:rs1, r2:rs2) + +mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d]) + +mapAndUnzip3 _ [] = ([], [], []) +mapAndUnzip3 f (x:xs) + = let (r1, r2, r3) = f x + (rs1, rs2, rs3) = mapAndUnzip3 f xs + in + (r1:rs1, r2:rs2, r3:rs3) + +zipWithAndUnzip :: (a -> b -> (c,d)) -> [a] -> [b] -> ([c],[d]) +zipWithAndUnzip f (a:as) (b:bs) + = let (r1, r2) = f a b + (rs1, rs2) = zipWithAndUnzip f as bs + in + (r1:rs1, r2:rs2) +zipWithAndUnzip _ _ _ = ([],[]) + +-- | This has the effect of making the two lists have equal length by dropping +-- the tail of the longer one. +zipAndUnzip :: [a] -> [b] -> ([a],[b]) +zipAndUnzip (a:as) (b:bs) + = let (rs1, rs2) = zipAndUnzip as bs + in + (a:rs1, b:rs2) +zipAndUnzip _ _ = ([],[]) + +mapAccumL2 :: (s1 -> s2 -> a -> (s1, s2, b)) -> s1 -> s2 -> [a] -> (s1, s2, [b]) +mapAccumL2 f s1 s2 xs = (s1', s2', ys) + where ((s1', s2'), ys) = mapAccumL (\(s1, s2) x -> case f s1 s2 x of + (s1', s2', y) -> ((s1', s2'), y)) + (s1, s2) xs + +-- | @atLength atLen atEnd ls n@ unravels list @ls@ to position @n@. Precisely: +-- +-- @ +-- atLength atLenPred atEndPred ls n +-- | n < 0 = atLenPred ls +-- | length ls < n = atEndPred (n - length ls) +-- | otherwise = atLenPred (drop n ls) +-- @ +atLength :: ([a] -> b) -- Called when length ls >= n, passed (drop n ls) + -- NB: arg passed to this function may be [] + -> b -- Called when length ls < n + -> [a] + -> Int + -> b +atLength atLenPred atEnd ls0 n0 + | n0 < 0 = atLenPred ls0 + | otherwise = go n0 ls0 + where + -- go's first arg n >= 0 + go 0 ls = atLenPred ls + go _ [] = atEnd -- n > 0 here + go n (_:xs) = go (n-1) xs + +-- Some special cases of atLength: + +-- | @(lengthExceeds xs n) = (length xs > n)@ +lengthExceeds :: [a] -> Int -> Bool +lengthExceeds lst n + | n < 0 + = True + | otherwise + = atLength notNull False lst n + +-- | @(lengthAtLeast xs n) = (length xs >= n)@ +lengthAtLeast :: [a] -> Int -> Bool +lengthAtLeast = atLength (const True) False + +-- | @(lengthIs xs n) = (length xs == n)@ +lengthIs :: [a] -> Int -> Bool +lengthIs lst n + | n < 0 + = False + | otherwise + = atLength null False lst n + +-- | @(lengthIsNot xs n) = (length xs /= n)@ +lengthIsNot :: [a] -> Int -> Bool +lengthIsNot lst n + | n < 0 = True + | otherwise = atLength notNull True lst n + +-- | @(lengthAtMost xs n) = (length xs <= n)@ +lengthAtMost :: [a] -> Int -> Bool +lengthAtMost lst n + | n < 0 + = False + | otherwise + = atLength null True lst n + +-- | @(lengthLessThan xs n) == (length xs < n)@ +lengthLessThan :: [a] -> Int -> Bool +lengthLessThan = atLength (const False) True + +listLengthCmp :: [a] -> Int -> Ordering +listLengthCmp = atLength atLen atEnd + where + atEnd = LT -- Not yet seen 'n' elts, so list length is < n. + + atLen [] = EQ + atLen _ = GT + +equalLength :: [a] -> [b] -> Bool +-- ^ True if length xs == length ys +equalLength [] [] = True +equalLength (_:xs) (_:ys) = equalLength xs ys +equalLength _ _ = False + +neLength :: [a] -> [b] -> Bool +-- ^ True if length xs /= length ys +neLength [] [] = False +neLength (_:xs) (_:ys) = neLength xs ys +neLength _ _ = True + +compareLength :: [a] -> [b] -> Ordering +compareLength [] [] = EQ +compareLength (_:xs) (_:ys) = compareLength xs ys +compareLength [] _ = LT +compareLength _ [] = GT + +leLength :: [a] -> [b] -> Bool +-- ^ True if length xs <= length ys +leLength xs ys = case compareLength xs ys of + LT -> True + EQ -> True + GT -> False + +ltLength :: [a] -> [b] -> Bool +-- ^ True if length xs < length ys +ltLength xs ys = case compareLength xs ys of + LT -> True + EQ -> False + GT -> False + +---------------------------- +singleton :: a -> [a] +singleton x = [x] + +isSingleton :: [a] -> Bool +isSingleton [_] = True +isSingleton _ = False + +notNull :: [a] -> Bool +notNull [] = False +notNull _ = True + +only :: [a] -> a +#if defined(DEBUG) +only [a] = a +#else +only (a:_) = a +#endif +only _ = panic "Util: only" + +-- Debugging/specialising versions of \tr{elem} and \tr{notElem} + +isIn, isn'tIn :: Eq a => String -> a -> [a] -> Bool + +# ifndef DEBUG +isIn _msg x ys = x `elem` ys +isn'tIn _msg x ys = x `notElem` ys + +# else /* DEBUG */ +isIn msg x ys + = elem100 0 x ys + where + elem100 :: Eq a => Int -> a -> [a] -> Bool + elem100 _ _ [] = False + elem100 i x (y:ys) + | i > 100 = WARN(True, text ("Over-long elem in " ++ msg)) (x `elem` (y:ys)) + | otherwise = x == y || elem100 (i + 1) x ys + +isn'tIn msg x ys + = notElem100 0 x ys + where + notElem100 :: Eq a => Int -> a -> [a] -> Bool + notElem100 _ _ [] = True + notElem100 i x (y:ys) + | i > 100 = WARN(True, text ("Over-long notElem in " ++ msg)) (x `notElem` (y:ys)) + | otherwise = x /= y && notElem100 (i + 1) x ys +# endif /* DEBUG */ + + +-- | Split a list into chunks of /n/ elements +chunkList :: Int -> [a] -> [[a]] +chunkList _ [] = [] +chunkList n xs = as : chunkList n bs where (as,bs) = splitAt n xs + +-- | Replace the last element of a list with another element. +changeLast :: [a] -> a -> [a] +changeLast [] _ = panic "changeLast" +changeLast [_] x = [x] +changeLast (x:xs) x' = x : changeLast xs x' + +{- +************************************************************************ +* * +\subsubsection{Sort utils} +* * +************************************************************************ +-} + +minWith :: Ord b => (a -> b) -> [a] -> a +minWith get_key xs = ASSERT( not (null xs) ) + head (sortWith get_key xs) + +nubSort :: Ord a => [a] -> [a] +nubSort = Set.toAscList . Set.fromList + +-- | Remove duplicates but keep elements in order. +-- O(n * log n) +ordNub :: Ord a => [a] -> [a] +ordNub xs + = go Set.empty xs + where + go _ [] = [] + go s (x:xs) + | Set.member x s = go s xs + | otherwise = x : go (Set.insert x s) xs + + +{- +************************************************************************ +* * +\subsection[Utils-transitive-closure]{Transitive closure} +* * +************************************************************************ + +This algorithm for transitive closure is straightforward, albeit quadratic. +-} + +transitiveClosure :: (a -> [a]) -- Successor function + -> (a -> a -> Bool) -- Equality predicate + -> [a] + -> [a] -- The transitive closure + +transitiveClosure succ eq xs + = go [] xs + where + go done [] = done + go done (x:xs) | x `is_in` done = go done xs + | otherwise = go (x:done) (succ x ++ xs) + + _ `is_in` [] = False + x `is_in` (y:ys) | eq x y = True + | otherwise = x `is_in` ys + +{- +************************************************************************ +* * +\subsection[Utils-accum]{Accumulating} +* * +************************************************************************ + +A combination of foldl with zip. It works with equal length lists. +-} + +foldl2 :: (acc -> a -> b -> acc) -> acc -> [a] -> [b] -> acc +foldl2 _ z [] [] = z +foldl2 k z (a:as) (b:bs) = foldl2 k (k z a b) as bs +foldl2 _ _ _ _ = panic "Util: foldl2" + +all2 :: (a -> b -> Bool) -> [a] -> [b] -> Bool +-- True if the lists are the same length, and +-- all corresponding elements satisfy the predicate +all2 _ [] [] = True +all2 p (x:xs) (y:ys) = p x y && all2 p xs ys +all2 _ _ _ = False + +-- Count the number of times a predicate is true + +count :: (a -> Bool) -> [a] -> Int +count p = go 0 + where go !n [] = n + go !n (x:xs) | p x = go (n+1) xs + | otherwise = go n xs + +countWhile :: (a -> Bool) -> [a] -> Int +-- Length of an /initial prefix/ of the list satsifying p +countWhile p = go 0 + where go !n (x:xs) | p x = go (n+1) xs + go !n _ = n + +{- +@splitAt@, @take@, and @drop@ but with length of another +list giving the break-off point: +-} + +takeList :: [b] -> [a] -> [a] +-- (takeList as bs) trims bs to the be same length +-- as as, unless as is longer in which case it's a no-op +takeList [] _ = [] +takeList (_:xs) ls = + case ls of + [] -> [] + (y:ys) -> y : takeList xs ys + +dropList :: [b] -> [a] -> [a] +dropList [] xs = xs +dropList _ xs@[] = xs +dropList (_:xs) (_:ys) = dropList xs ys + + +splitAtList :: [b] -> [a] -> ([a], [a]) +splitAtList [] xs = ([], xs) +splitAtList _ xs@[] = (xs, xs) +splitAtList (_:xs) (y:ys) = (y:ys', ys'') + where + (ys', ys'') = splitAtList xs ys + +-- drop from the end of a list +dropTail :: Int -> [a] -> [a] +-- Specification: dropTail n = reverse . drop n . reverse +-- Better implemention due to Joachim Breitner +-- http://www.joachim-breitner.de/blog/archives/600-On-taking-the-last-n-elements-of-a-list.html +dropTail n xs + = go (drop n xs) xs + where + go (_:ys) (x:xs) = x : go ys xs + go _ _ = [] -- Stop when ys runs out + -- It'll always run out before xs does + +-- dropWhile from the end of a list. This is similar to Data.List.dropWhileEnd, +-- but is lazy in the elements and strict in the spine. For reasonably short lists, +-- such as path names and typical lines of text, dropWhileEndLE is generally +-- faster than dropWhileEnd. Its advantage is magnified when the predicate is +-- expensive--using dropWhileEndLE isSpace to strip the space off a line of text +-- is generally much faster than using dropWhileEnd isSpace for that purpose. +-- Specification: dropWhileEndLE p = reverse . dropWhile p . reverse +-- Pay attention to the short-circuit (&&)! The order of its arguments is the only +-- difference between dropWhileEnd and dropWhileEndLE. +dropWhileEndLE :: (a -> Bool) -> [a] -> [a] +dropWhileEndLE p = foldr (\x r -> if null r && p x then [] else x:r) [] + +-- | @spanEnd p l == reverse (span p (reverse l))@. The first list +-- returns actually comes after the second list (when you look at the +-- input list). +spanEnd :: (a -> Bool) -> [a] -> ([a], [a]) +spanEnd p l = go l [] [] l + where go yes _rev_yes rev_no [] = (yes, reverse rev_no) + go yes rev_yes rev_no (x:xs) + | p x = go yes (x : rev_yes) rev_no xs + | otherwise = go xs [] (x : rev_yes ++ rev_no) xs + +-- | Get the last two elements in a list. Partial! +{-# INLINE last2 #-} +last2 :: [a] -> (a,a) +last2 = foldl' (\(_,x2) x -> (x2,x)) (partialError,partialError) + where + partialError = panic "last2 - list length less than two" + +lastMaybe :: [a] -> Maybe a +lastMaybe [] = Nothing +lastMaybe xs = Just $ last xs + +-- | Split a list into its last element and the initial part of the list. +-- @snocView xs = Just (init xs, last xs)@ for non-empty lists. +-- @snocView xs = Nothing@ otherwise. +-- Unless both parts of the result are guaranteed to be used +-- prefer separate calls to @last@ + @init@. +-- If you are guaranteed to use both, this will +-- be more efficient. +snocView :: [a] -> Maybe ([a],a) +snocView [] = Nothing +snocView xs + | (xs,x) <- go xs + = Just (xs,x) + where + go :: [a] -> ([a],a) + go [x] = ([],x) + go (x:xs) + | !(xs',x') <- go xs + = (x:xs', x') + go [] = error "impossible" + +split :: Char -> String -> [String] +split c s = case rest of + [] -> [chunk] + _:rest -> chunk : split c rest + where (chunk, rest) = break (==c) s + +-- | Convert a word to title case by capitalising the first letter +capitalise :: String -> String +capitalise [] = [] +capitalise (c:cs) = toUpper c : cs + + +{- +************************************************************************ +* * +\subsection[Utils-comparison]{Comparisons} +* * +************************************************************************ +-} + +isEqual :: Ordering -> Bool +-- Often used in (isEqual (a `compare` b)) +isEqual GT = False +isEqual EQ = True +isEqual LT = False + +thenCmp :: Ordering -> Ordering -> Ordering +{-# INLINE thenCmp #-} +thenCmp EQ ordering = ordering +thenCmp ordering _ = ordering + +eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool +eqListBy _ [] [] = True +eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys +eqListBy _ _ _ = False + +eqMaybeBy :: (a ->a->Bool) -> Maybe a -> Maybe a -> Bool +eqMaybeBy _ Nothing Nothing = True +eqMaybeBy eq (Just x) (Just y) = eq x y +eqMaybeBy _ _ _ = False + +cmpList :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering + -- `cmpList' uses a user-specified comparer + +cmpList _ [] [] = EQ +cmpList _ [] _ = LT +cmpList _ _ [] = GT +cmpList cmp (a:as) (b:bs) + = case cmp a b of { EQ -> cmpList cmp as bs; xxx -> xxx } + +removeSpaces :: String -> String +removeSpaces = dropWhileEndLE isSpace . dropWhile isSpace + +-- Boolean operators lifted to Applicative +(<&&>) :: Applicative f => f Bool -> f Bool -> f Bool +(<&&>) = liftA2 (&&) +infixr 3 <&&> -- same as (&&) + +(<||>) :: Applicative f => f Bool -> f Bool -> f Bool +(<||>) = liftA2 (||) +infixr 2 <||> -- same as (||) + +{- +************************************************************************ +* * +\subsection{Edit distance} +* * +************************************************************************ +-} + +-- | Find the "restricted" Damerau-Levenshtein edit distance between two strings. +-- See: . +-- Based on the algorithm presented in "A Bit-Vector Algorithm for Computing +-- Levenshtein and Damerau Edit Distances" in PSC'02 (Heikki Hyyro). +-- See http://www.cs.uta.fi/~helmu/pubs/psc02.pdf and +-- http://www.cs.uta.fi/~helmu/pubs/PSCerr.html for an explanation +restrictedDamerauLevenshteinDistance :: String -> String -> Int +restrictedDamerauLevenshteinDistance str1 str2 + = restrictedDamerauLevenshteinDistanceWithLengths m n str1 str2 + where + m = length str1 + n = length str2 + +restrictedDamerauLevenshteinDistanceWithLengths + :: Int -> Int -> String -> String -> Int +restrictedDamerauLevenshteinDistanceWithLengths m n str1 str2 + | m <= n + = if n <= 32 -- n must be larger so this check is sufficient + then restrictedDamerauLevenshteinDistance' (undefined :: Word32) m n str1 str2 + else restrictedDamerauLevenshteinDistance' (undefined :: Integer) m n str1 str2 + + | otherwise + = if m <= 32 -- m must be larger so this check is sufficient + then restrictedDamerauLevenshteinDistance' (undefined :: Word32) n m str2 str1 + else restrictedDamerauLevenshteinDistance' (undefined :: Integer) n m str2 str1 + +restrictedDamerauLevenshteinDistance' + :: (Bits bv, Num bv) => bv -> Int -> Int -> String -> String -> Int +restrictedDamerauLevenshteinDistance' _bv_dummy m n str1 str2 + | [] <- str1 = n + | otherwise = extractAnswer $ + foldl' (restrictedDamerauLevenshteinDistanceWorker + (matchVectors str1) top_bit_mask vector_mask) + (0, 0, m_ones, 0, m) str2 + where + m_ones@vector_mask = (2 ^ m) - 1 + top_bit_mask = (1 `shiftL` (m - 1)) `asTypeOf` _bv_dummy + extractAnswer (_, _, _, _, distance) = distance + +restrictedDamerauLevenshteinDistanceWorker + :: (Bits bv, Num bv) => IM.IntMap bv -> bv -> bv + -> (bv, bv, bv, bv, Int) -> Char -> (bv, bv, bv, bv, Int) +restrictedDamerauLevenshteinDistanceWorker str1_mvs top_bit_mask vector_mask + (pm, d0, vp, vn, distance) char2 + = seq str1_mvs $ seq top_bit_mask $ seq vector_mask $ + seq pm' $ seq d0' $ seq vp' $ seq vn' $ + seq distance'' $ seq char2 $ + (pm', d0', vp', vn', distance'') + where + pm' = IM.findWithDefault 0 (ord char2) str1_mvs + + d0' = ((((sizedComplement vector_mask d0) .&. pm') `shiftL` 1) .&. pm) + .|. ((((pm' .&. vp) + vp) .&. vector_mask) `xor` vp) .|. pm' .|. vn + -- No need to mask the shiftL because of the restricted range of pm + + hp' = vn .|. sizedComplement vector_mask (d0' .|. vp) + hn' = d0' .&. vp + + hp'_shift = ((hp' `shiftL` 1) .|. 1) .&. vector_mask + hn'_shift = (hn' `shiftL` 1) .&. vector_mask + vp' = hn'_shift .|. sizedComplement vector_mask (d0' .|. hp'_shift) + vn' = d0' .&. hp'_shift + + distance' = if hp' .&. top_bit_mask /= 0 then distance + 1 else distance + distance'' = if hn' .&. top_bit_mask /= 0 then distance' - 1 else distance' + +sizedComplement :: Bits bv => bv -> bv -> bv +sizedComplement vector_mask vect = vector_mask `xor` vect + +matchVectors :: (Bits bv, Num bv) => String -> IM.IntMap bv +matchVectors = snd . foldl' go (0 :: Int, IM.empty) + where + go (ix, im) char = let ix' = ix + 1 + im' = IM.insertWith (.|.) (ord char) (2 ^ ix) im + in seq ix' $ seq im' $ (ix', im') + +{-# SPECIALIZE INLINE restrictedDamerauLevenshteinDistance' + :: Word32 -> Int -> Int -> String -> String -> Int #-} +{-# SPECIALIZE INLINE restrictedDamerauLevenshteinDistance' + :: Integer -> Int -> Int -> String -> String -> Int #-} + +{-# SPECIALIZE restrictedDamerauLevenshteinDistanceWorker + :: IM.IntMap Word32 -> Word32 -> Word32 + -> (Word32, Word32, Word32, Word32, Int) + -> Char -> (Word32, Word32, Word32, Word32, Int) #-} +{-# SPECIALIZE restrictedDamerauLevenshteinDistanceWorker + :: IM.IntMap Integer -> Integer -> Integer + -> (Integer, Integer, Integer, Integer, Int) + -> Char -> (Integer, Integer, Integer, Integer, Int) #-} + +{-# SPECIALIZE INLINE sizedComplement :: Word32 -> Word32 -> Word32 #-} +{-# SPECIALIZE INLINE sizedComplement :: Integer -> Integer -> Integer #-} + +{-# SPECIALIZE matchVectors :: String -> IM.IntMap Word32 #-} +{-# SPECIALIZE matchVectors :: String -> IM.IntMap Integer #-} + +fuzzyMatch :: String -> [String] -> [String] +fuzzyMatch key vals = fuzzyLookup key [(v,v) | v <- vals] + +-- | Search for possible matches to the users input in the given list, +-- returning a small number of ranked results +fuzzyLookup :: String -> [(String,a)] -> [a] +fuzzyLookup user_entered possibilites + = map fst $ take mAX_RESULTS $ sortBy (comparing snd) + [ (poss_val, distance) | (poss_str, poss_val) <- possibilites + , let distance = restrictedDamerauLevenshteinDistance + poss_str user_entered + , distance <= fuzzy_threshold ] + where + -- Work out an approriate match threshold: + -- We report a candidate if its edit distance is <= the threshold, + -- The threshold is set to about a quarter of the # of characters the user entered + -- Length Threshold + -- 1 0 -- Don't suggest *any* candidates + -- 2 1 -- for single-char identifiers + -- 3 1 + -- 4 1 + -- 5 1 + -- 6 2 + -- + fuzzy_threshold = truncate $ fromIntegral (length user_entered + 2) / (4 :: Rational) + mAX_RESULTS = 3 + +{- +************************************************************************ +* * +\subsection[Utils-pairs]{Pairs} +* * +************************************************************************ +-} + +unzipWith :: (a -> b -> c) -> [(a, b)] -> [c] +unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs + +seqList :: [a] -> b -> b +seqList [] b = b +seqList (x:xs) b = x `seq` seqList xs b + + +{- +************************************************************************ +* * + Globals and the RTS +* * +************************************************************************ + +When a plugin is loaded, it currently gets linked against a *newly +loaded* copy of the GHC package. This would not be a problem, except +that the new copy has its own mutable state that is not shared with +that state that has already been initialized by the original GHC +package. + +(Note that if the GHC executable was dynamically linked this +wouldn't be a problem, because we could share the GHC library it +links to; this is only a problem if DYNAMIC_GHC_PROGRAMS=NO.) + +The solution is to make use of @sharedCAF@ through @sharedGlobal@ +for globals that are shared between multiple copies of ghc packages. +-} + +-- Global variables: + +global :: a -> IORef a +global a = unsafePerformIO (newIORef a) + +consIORef :: IORef [a] -> a -> IO () +consIORef var x = do + atomicModifyIORef' var (\xs -> (x:xs,())) + +globalM :: IO a -> IORef a +globalM ma = unsafePerformIO (ma >>= newIORef) + +-- Shared global variables: + +sharedGlobal :: a -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IORef a +sharedGlobal a get_or_set = unsafePerformIO $ + newIORef a >>= flip sharedCAF get_or_set + +sharedGlobalM :: IO a -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IORef a +sharedGlobalM ma get_or_set = unsafePerformIO $ + ma >>= newIORef >>= flip sharedCAF get_or_set + +-- Module names: + +looksLikeModuleName :: String -> Bool +looksLikeModuleName [] = False +looksLikeModuleName (c:cs) = isUpper c && go cs + where go [] = True + go ('.':cs) = looksLikeModuleName cs + go (c:cs) = (isAlphaNum c || c == '_' || c == '\'') && go cs + +-- Similar to 'parse' for Distribution.Package.PackageName, +-- but we don't want to depend on Cabal. +looksLikePackageName :: String -> Bool +looksLikePackageName = all (all isAlphaNum <&&> not . (all isDigit)) . split '-' + +{- +Akin to @Prelude.words@, but acts like the Bourne shell, treating +quoted strings as Haskell Strings, and also parses Haskell [String] +syntax. +-} + +getCmd :: String -> Either String -- Error + (String, String) -- (Cmd, Rest) +getCmd s = case break isSpace $ dropWhile isSpace s of + ([], _) -> Left ("Couldn't find command in " ++ show s) + res -> Right res + +toCmdArgs :: String -> Either String -- Error + (String, [String]) -- (Cmd, Args) +toCmdArgs s = case getCmd s of + Left err -> Left err + Right (cmd, s') -> case toArgs s' of + Left err -> Left err + Right args -> Right (cmd, args) + +toArgs :: String -> Either String -- Error + [String] -- Args +toArgs str + = case dropWhile isSpace str of + s@('[':_) -> case reads s of + [(args, spaces)] + | all isSpace spaces -> + Right args + _ -> + Left ("Couldn't read " ++ show str ++ " as [String]") + s -> toArgs' s + where + toArgs' :: String -> Either String [String] + -- Remove outer quotes: + -- > toArgs' "\"foo\" \"bar baz\"" + -- Right ["foo", "bar baz"] + -- + -- Keep inner quotes: + -- > toArgs' "-DFOO=\"bar baz\"" + -- Right ["-DFOO=\"bar baz\""] + toArgs' s = case dropWhile isSpace s of + [] -> Right [] + ('"' : _) -> do + -- readAsString removes outer quotes + (arg, rest) <- readAsString s + (arg:) `fmap` toArgs' rest + s' -> case break (isSpace <||> (== '"')) s' of + (argPart1, s''@('"':_)) -> do + (argPart2, rest) <- readAsString s'' + -- show argPart2 to keep inner quotes + ((argPart1 ++ show argPart2):) `fmap` toArgs' rest + (arg, s'') -> (arg:) `fmap` toArgs' s'' + + readAsString :: String -> Either String (String, String) + readAsString s = case reads s of + [(arg, rest)] + -- rest must either be [] or start with a space + | all isSpace (take 1 rest) -> + Right (arg, rest) + _ -> + Left ("Couldn't read " ++ show s ++ " as String") +----------------------------------------------------------------------------- +-- Integers + +-- This algorithm for determining the $\log_2$ of exact powers of 2 comes +-- from GCC. It requires bit manipulation primitives, and we use GHC +-- extensions. Tough. + +exactLog2 :: Integer -> Maybe Integer +exactLog2 x + = if (x <= 0 || x >= 2147483648) then + Nothing + else + if (x .&. (-x)) /= x then + Nothing + else + Just (pow2 x) + where + pow2 x | x == 1 = 0 + | otherwise = 1 + pow2 (x `shiftR` 1) + + +{- +-- ----------------------------------------------------------------------------- +-- Floats +-} + +readRational__ :: ReadS Rational -- NB: doesn't handle leading "-" +readRational__ r = do + (n,d,s) <- readFix r + (k,t) <- readExp s + return ((n%1)*10^^(k-d), t) + where + readFix r = do + (ds,s) <- lexDecDigits r + (ds',t) <- lexDotDigits s + return (read (ds++ds'), length ds', t) + + readExp (e:s) | e `elem` "eE" = readExp' s + readExp s = return (0,s) + + readExp' ('+':s) = readDec s + readExp' ('-':s) = do (k,t) <- readDec s + return (-k,t) + readExp' s = readDec s + + readDec s = do + (ds,r) <- nonnull isDigit s + return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ], + r) + + lexDecDigits = nonnull isDigit + + lexDotDigits ('.':s) = return (span' isDigit s) + lexDotDigits s = return ("",s) + + nonnull p s = do (cs@(_:_),t) <- return (span' p s) + return (cs,t) + + span' _ xs@[] = (xs, xs) + span' p xs@(x:xs') + | x == '_' = span' p xs' -- skip "_" (#14473) + | p x = let (ys,zs) = span' p xs' in (x:ys,zs) + | otherwise = ([],xs) + +readRational :: String -> Rational -- NB: *does* handle a leading "-" +readRational top_s + = case top_s of + '-' : xs -> - (read_me xs) + xs -> read_me xs + where + read_me s + = case (do { (x,"") <- readRational__ s ; return x }) of + [x] -> x + [] -> error ("readRational: no parse:" ++ top_s) + _ -> error ("readRational: ambiguous parse:" ++ top_s) + + +readHexRational :: String -> Rational +readHexRational str = + case str of + '-' : xs -> - (readMe xs) + xs -> readMe xs + where + readMe as = + case readHexRational__ as of + Just n -> n + _ -> error ("readHexRational: no parse:" ++ str) + + +readHexRational__ :: String -> Maybe Rational +readHexRational__ ('0' : x : rest) + | x == 'X' || x == 'x' = + do let (front,rest2) = span' isHexDigit rest + guard (not (null front)) + let frontNum = steps 16 0 front + case rest2 of + '.' : rest3 -> + do let (back,rest4) = span' isHexDigit rest3 + guard (not (null back)) + let backNum = steps 16 frontNum back + exp1 = -4 * length back + case rest4 of + p : ps | isExp p -> fmap (mk backNum . (+ exp1)) (getExp ps) + _ -> return (mk backNum exp1) + p : ps | isExp p -> fmap (mk frontNum) (getExp ps) + _ -> Nothing + + where + isExp p = p == 'p' || p == 'P' + + getExp ('+' : ds) = dec ds + getExp ('-' : ds) = fmap negate (dec ds) + getExp ds = dec ds + + mk :: Integer -> Int -> Rational + mk n e = fromInteger n * 2^^e + + dec cs = case span' isDigit cs of + (ds,"") | not (null ds) -> Just (steps 10 0 ds) + _ -> Nothing + + steps base n ds = foldl' (step base) n ds + step base n d = base * n + fromIntegral (digitToInt d) + + span' _ xs@[] = (xs, xs) + span' p xs@(x:xs') + | x == '_' = span' p xs' -- skip "_" (#14473) + | p x = let (ys,zs) = span' p xs' in (x:ys,zs) + | otherwise = ([],xs) + +readHexRational__ _ = Nothing + + + + +----------------------------------------------------------------------------- +-- read helpers + +maybeRead :: Read a => String -> Maybe a +maybeRead str = case reads str of + [(x, "")] -> Just x + _ -> Nothing + +maybeReadFuzzy :: Read a => String -> Maybe a +maybeReadFuzzy str = case reads str of + [(x, s)] + | all isSpace s -> + Just x + _ -> + Nothing + +----------------------------------------------------------------------------- +-- Verify that the 'dirname' portion of a FilePath exists. +-- +doesDirNameExist :: FilePath -> IO Bool +doesDirNameExist fpath = doesDirectoryExist (takeDirectory fpath) + +----------------------------------------------------------------------------- +-- Backwards compatibility definition of getModificationTime + +getModificationUTCTime :: FilePath -> IO UTCTime +getModificationUTCTime = getModificationTime + +-- -------------------------------------------------------------- +-- check existence & modification time at the same time + +modificationTimeIfExists :: FilePath -> IO (Maybe UTCTime) +modificationTimeIfExists f = do + (do t <- getModificationUTCTime f; return (Just t)) + `catchIO` \e -> if isDoesNotExistError e + then return Nothing + else ioError e + +-- -------------------------------------------------------------- +-- atomic file writing by writing to a temporary file first (see #14533) +-- +-- This should be used in all cases where GHC writes files to disk +-- and uses their modification time to skip work later, +-- as otherwise a partially written file (e.g. due to crash or Ctrl+C) +-- also results in a skip. + +withAtomicRename :: (MonadIO m) => FilePath -> (FilePath -> m a) -> m a +withAtomicRename targetFile f + | enableAtomicRename = do + -- The temp file must be on the same file system (mount) as the target file + -- to result in an atomic move on most platforms. + -- The standard way to ensure that is to place it into the same directory. + -- This can still be fooled when somebody mounts a different file system + -- at just the right time, but that is not a case we aim to cover here. + let temp = targetFile <.> "tmp" + res <- f temp + liftIO $ renameFile temp targetFile + return res + + | otherwise = f targetFile + where + -- As described in #16450, enabling this causes spurious build failures due + -- to apparently missing files. + enableAtomicRename :: Bool +#if defined(mingw32_BUILD_OS) + enableAtomicRename = False +#else + enableAtomicRename = True +#endif + +-- -------------------------------------------------------------- +-- split a string at the last character where 'pred' is True, +-- returning a pair of strings. The first component holds the string +-- up (but not including) the last character for which 'pred' returned +-- True, the second whatever comes after (but also not including the +-- last character). +-- +-- If 'pred' returns False for all characters in the string, the original +-- string is returned in the first component (and the second one is just +-- empty). +splitLongestPrefix :: String -> (Char -> Bool) -> (String,String) +splitLongestPrefix str pred + | null r_pre = (str, []) + | otherwise = (reverse (tail r_pre), reverse r_suf) + -- 'tail' drops the char satisfying 'pred' + where (r_suf, r_pre) = break pred (reverse str) + +escapeSpaces :: String -> String +escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) "" + +type Suffix = String + +-------------------------------------------------------------- +-- * Search path +-------------------------------------------------------------- + +data Direction = Forwards | Backwards + +reslash :: Direction -> FilePath -> FilePath +reslash d = f + where f ('/' : xs) = slash : f xs + f ('\\' : xs) = slash : f xs + f (x : xs) = x : f xs + f "" = "" + slash = case d of + Forwards -> '/' + Backwards -> '\\' + +makeRelativeTo :: FilePath -> FilePath -> FilePath +this `makeRelativeTo` that = directory thisFilename + where (thisDirectory, thisFilename) = splitFileName this + thatDirectory = dropFileName that + directory = joinPath $ f (splitPath thisDirectory) + (splitPath thatDirectory) + + f (x : xs) (y : ys) + | x == y = f xs ys + f xs ys = replicate (length ys) ".." ++ xs + +{- +************************************************************************ +* * +\subsection[Utils-Data]{Utils for defining Data instances} +* * +************************************************************************ + +These functions helps us to define Data instances for abstract types. +-} + +abstractConstr :: String -> Constr +abstractConstr n = mkConstr (abstractDataType n) ("{abstract:"++n++"}") [] Prefix + +abstractDataType :: String -> DataType +abstractDataType n = mkDataType n [abstractConstr n] + +{- +************************************************************************ +* * +\subsection[Utils-C]{Utils for printing C code} +* * +************************************************************************ +-} + +charToC :: Word8 -> String +charToC w = + case chr (fromIntegral w) of + '\"' -> "\\\"" + '\'' -> "\\\'" + '\\' -> "\\\\" + c | c >= ' ' && c <= '~' -> [c] + | otherwise -> ['\\', + chr (ord '0' + ord c `div` 64), + chr (ord '0' + ord c `div` 8 `mod` 8), + chr (ord '0' + ord c `mod` 8)] + +{- +************************************************************************ +* * +\subsection[Utils-Hashing]{Utils for hashing} +* * +************************************************************************ +-} + +-- | A sample hash function for Strings. We keep multiplying by the +-- golden ratio and adding. The implementation is: +-- +-- > hashString = foldl' f golden +-- > where f m c = fromIntegral (ord c) * magic + hashInt32 m +-- > magic = 0xdeadbeef +-- +-- Where hashInt32 works just as hashInt shown above. +-- +-- Knuth argues that repeated multiplication by the golden ratio +-- will minimize gaps in the hash space, and thus it's a good choice +-- for combining together multiple keys to form one. +-- +-- Here we know that individual characters c are often small, and this +-- produces frequent collisions if we use ord c alone. A +-- particular problem are the shorter low ASCII and ISO-8859-1 +-- character strings. We pre-multiply by a magic twiddle factor to +-- obtain a good distribution. In fact, given the following test: +-- +-- > testp :: Int32 -> Int +-- > testp k = (n - ) . length . group . sort . map hs . take n $ ls +-- > where ls = [] : [c : l | l <- ls, c <- ['\0'..'\xff']] +-- > hs = foldl' f golden +-- > f m c = fromIntegral (ord c) * k + hashInt32 m +-- > n = 100000 +-- +-- We discover that testp magic = 0. +hashString :: String -> Int32 +hashString = foldl' f golden + where f m c = fromIntegral (ord c) * magic + hashInt32 m + magic = fromIntegral (0xdeadbeef :: Word32) + +golden :: Int32 +golden = 1013904242 -- = round ((sqrt 5 - 1) * 2^32) :: Int32 +-- was -1640531527 = round ((sqrt 5 - 1) * 2^31) :: Int32 +-- but that has bad mulHi properties (even adding 2^32 to get its inverse) +-- Whereas the above works well and contains no hash duplications for +-- [-32767..65536] + +-- | A sample (and useful) hash function for Int32, +-- implemented by extracting the uppermost 32 bits of the 64-bit +-- result of multiplying by a 33-bit constant. The constant is from +-- Knuth, derived from the golden ratio: +-- +-- > golden = round ((sqrt 5 - 1) * 2^32) +-- +-- We get good key uniqueness on small inputs +-- (a problem with previous versions): +-- (length $ group $ sort $ map hashInt32 [-32767..65536]) == 65536 + 32768 +-- +hashInt32 :: Int32 -> Int32 +hashInt32 x = mulHi x golden + x + +-- hi 32 bits of a x-bit * 32 bit -> 64-bit multiply +mulHi :: Int32 -> Int32 -> Int32 +mulHi a b = fromIntegral (r `shiftR` 32) + where r :: Int64 + r = fromIntegral a * fromIntegral b + +-- | A call stack constraint, but only when 'isDebugOn'. +#if defined(DEBUG) +type HasDebugCallStack = HasCallStack +#else +type HasDebugCallStack = (() :: Constraint) +#endif + +data OverridingBool + = Auto + | Always + | Never + deriving Show + +overrideWith :: Bool -> OverridingBool -> Bool +overrideWith b Auto = b +overrideWith _ Always = True +overrideWith _ Never = False diff --git a/compiler/utils/md5.h b/compiler/utils/md5.h new file mode 100644 --- /dev/null +++ b/compiler/utils/md5.h @@ -0,0 +1,18 @@ +/* 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]); diff --git a/ghc-lib-parser.cabal b/ghc-lib-parser.cabal new file mode 100644 --- /dev/null +++ b/ghc-lib-parser.cabal @@ -0,0 +1,335 @@ +cabal-version: >=1.22 +build-type: Simple +name: ghc-lib-parser +version: 0.20190402 +license: BSD3 +license-file: LICENSE +category: Development +author: The GHC Team and Digital Asset +maintainer: Digital Asset +synopsis: The GHC API, decoupled from GHC versions +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-files: + settings + llvm-targets + llvm-passes + platformConstants +extra-source-files: + ghc-lib/generated/ghcautoconf.h + ghc-lib/generated/ghcplatform.h + ghc-lib/generated/ghcversion.h + ghc-lib/generated/DerivedConstants.h + 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/stage1/compiler/build/Config.hs + ghc-lib/stage0/compiler/build/Parser.hs + ghc-lib/stage0/compiler/build/Lexer.hs + includes/*.h + includes/CodeGen.Platform.hs + includes/rts/*.h + includes/rts/storage/*.h + includes/rts/prof/*.h + compiler/nativeGen/*.h + compiler/utils/*.h + compiler/*.h +tested-with:GHC==8.6.3 +source-repository head + type: git + location: git://git.haskell.org/ghc.git + +library + default-language: Haskell2010 + default-extensions: NoImplicitPrelude + include-dirs: + 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 -DGHCI -DGHC_IN_GHCI + if !os(windows) + build-depends: unix + else + build-depends: Win32 + build-depends: + ghc-prim > 0.2 && < 0.6, + base >= 4.11 && < 4.14, + containers >= 0.5 && < 0.7, + bytestring >= 0.9 && < 0.11, + binary == 0.8.*, + filepath >= 1 && < 1.5, + directory >= 1 && < 1.4, + array >= 0.1 && < 0.6, + deepseq >= 1.4 && < 1.5, + pretty == 1.1.*, + time >= 1.4 && < 1.10, + transformers == 0.5.*, + process >= 1 && < 1.7, + hpc == 0.6.* + build-tools: alex >= 3.1, happy >= 1.19.4 + other-extensions: + BangPatterns + CPP + DataKinds + DefaultSignatures + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + DisambiguateRecordFields + ExistentialQuantification + ExplicitForAll + FlexibleContexts + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + InstanceSigs + MagicHash + MultiParamTypeClasses + NamedFieldPuns + NondecreasingIndentation + RankNTypes + RecordWildCards + RoleAnnotations + ScopedTypeVariables + StandaloneDeriving + Trustworthy + TupleSections + TypeFamilies + TypeSynonymInstances + UnboxedTuples + UndecidableInstances + c-sources: + compiler/cbits/genSym.c + compiler/ghci/keepCAFsForGHCi.c + compiler/parser/cutils.c + hs-source-dirs: + compiler + compiler/backpack + compiler/basicTypes + compiler/cmm + compiler/coreSyn + compiler/deSugar + compiler/ghci + compiler/hsSyn + compiler/iface + compiler/main + compiler/nativeGen + compiler/parser + compiler/prelude + compiler/profiling + compiler/simplCore + compiler/simplStg + compiler/specialise + compiler/typecheck + compiler/types + compiler/utils + ghc-lib/stage0/compiler/build + ghc-lib/stage1/compiler/build + libraries/ghc-boot + libraries/ghc-boot-th + libraries/ghc-heap + libraries/ghci + libraries/template-haskell + autogen-modules: + Lexer + Parser + exposed-modules: + Annotations + ApiAnnotation + Avail + Bag + BasicTypes + BinFingerprint + Binary + BkpSyn + BooleanFormula + BufWrite + ByteCodeTypes + Class + CmdLineParser + CmmType + CoAxiom + Coercion + ConLike + Config + Constants + CoreArity + CoreFVs + CoreMap + CoreMonad + CoreOpt + CoreSeq + CoreStats + CoreSubst + CoreSyn + CoreTidy + CoreUnfold + CoreUtils + CostCentre + CostCentreState + Ctype + DataCon + Demand + Digraph + DriverPhases + DynFlags + Encoding + EnumSet + ErrUtils + Exception + FV + FamInstEnv + FastFunctions + FastMutInt + FastString + FastStringEnv + FieldLabel + FileCleanup + Fingerprint + FiniteMap + ForeignCall + GHC.Exts.Heap + GHC.Exts.Heap.ClosureTypes + GHC.Exts.Heap.Closures + GHC.Exts.Heap.Constants + GHC.Exts.Heap.InfoTable + GHC.Exts.Heap.InfoTable.Types + GHC.Exts.Heap.InfoTableProf + GHC.Exts.Heap.Utils + GHC.ForeignSrcLang + GHC.ForeignSrcLang.Type + GHC.LanguageExtensions + GHC.LanguageExtensions.Type + GHC.Lexeme + GHC.PackageDb + GHC.Serialized + GHCi.BreakArray + GHCi.FFI + GHCi.Message + GHCi.RemoteTypes + GHCi.TH.Binary + GhcMonad + GhcPrelude + HaddockUtils + Hooks + HsBinds + HsDecls + HsDoc + HsExpr + HsExtension + HsImpExp + HsInstances + HsLit + HsPat + HsSyn + HsTypes + HsUtils + HscTypes + IOEnv + Id + IdInfo + IfaceSyn + IfaceType + InstEnv + InteractiveEvalTypes + Json + Kind + KnownUniques + Language.Haskell.TH + Language.Haskell.TH.LanguageExtensions + Language.Haskell.TH.Lib + Language.Haskell.TH.Lib.Internal + Language.Haskell.TH.Lib.Map + Language.Haskell.TH.Ppr + Language.Haskell.TH.PprLib + Language.Haskell.TH.Syntax + Lexeme + Lexer + ListSetOps + Literal + Maybes + MkCore + MkId + Module + MonadUtils + Name + NameCache + NameEnv + NameSet + OccName + OccurAnal + OptCoercion + OrdList + Outputable + PackageConfig + Packages + Pair + Panic + Parser + PatSyn + PipelineMonad + PlaceHolder + Platform + PlatformConstants + Plugins + PmExpr + PprColour + PprCore + PrelNames + PrelRules + Pretty + PrimOp + RdrHsSyn + RdrName + RepType + Rules + SizedSeq + SrcLoc + StringBuffer + SysTools.BaseDir + SysTools.Terminal + TcEvidence + TcRnTypes + TcType + ToIface + TrieMap + TyCoRep + TyCon + Type + TysPrim + TysWiredIn + Unify + UniqDFM + UniqDSet + UniqFM + UniqSet + UniqSupply + Unique + Util + Var + VarEnv + VarSet diff --git a/ghc-lib/generated/DerivedConstants.h b/ghc-lib/generated/DerivedConstants.h new file mode 100644 --- /dev/null +++ b/ghc-lib/generated/DerivedConstants.h @@ -0,0 +1,554 @@ +/* This file is created automatically. Do not edit by hand.*/ + +#define CONTROL_GROUP_CONST_291 291 +#define STD_HDR_SIZE 1 +#define PROF_HDR_SIZE 2 +#define BLOCK_SIZE 4096 +#define MBLOCK_SIZE 1048576 +#define BLOCKS_PER_MBLOCK 252 +#define TICKY_BIN_COUNT 9 +#define OFFSET_StgRegTable_rR1 0 +#define OFFSET_StgRegTable_rR2 8 +#define OFFSET_StgRegTable_rR3 16 +#define OFFSET_StgRegTable_rR4 24 +#define OFFSET_StgRegTable_rR5 32 +#define OFFSET_StgRegTable_rR6 40 +#define OFFSET_StgRegTable_rR7 48 +#define OFFSET_StgRegTable_rR8 56 +#define OFFSET_StgRegTable_rR9 64 +#define OFFSET_StgRegTable_rR10 72 +#define OFFSET_StgRegTable_rF1 80 +#define OFFSET_StgRegTable_rF2 84 +#define OFFSET_StgRegTable_rF3 88 +#define OFFSET_StgRegTable_rF4 92 +#define OFFSET_StgRegTable_rF5 96 +#define OFFSET_StgRegTable_rF6 100 +#define OFFSET_StgRegTable_rD1 104 +#define OFFSET_StgRegTable_rD2 112 +#define OFFSET_StgRegTable_rD3 120 +#define OFFSET_StgRegTable_rD4 128 +#define OFFSET_StgRegTable_rD5 136 +#define OFFSET_StgRegTable_rD6 144 +#define OFFSET_StgRegTable_rXMM1 152 +#define OFFSET_StgRegTable_rXMM2 168 +#define OFFSET_StgRegTable_rXMM3 184 +#define OFFSET_StgRegTable_rXMM4 200 +#define OFFSET_StgRegTable_rXMM5 216 +#define OFFSET_StgRegTable_rXMM6 232 +#define OFFSET_StgRegTable_rYMM1 248 +#define OFFSET_StgRegTable_rYMM2 280 +#define OFFSET_StgRegTable_rYMM3 312 +#define OFFSET_StgRegTable_rYMM4 344 +#define OFFSET_StgRegTable_rYMM5 376 +#define OFFSET_StgRegTable_rYMM6 408 +#define OFFSET_StgRegTable_rZMM1 440 +#define OFFSET_StgRegTable_rZMM2 504 +#define OFFSET_StgRegTable_rZMM3 568 +#define OFFSET_StgRegTable_rZMM4 632 +#define OFFSET_StgRegTable_rZMM5 696 +#define OFFSET_StgRegTable_rZMM6 760 +#define OFFSET_StgRegTable_rL1 824 +#define OFFSET_StgRegTable_rSp 832 +#define OFFSET_StgRegTable_rSpLim 840 +#define OFFSET_StgRegTable_rHp 848 +#define OFFSET_StgRegTable_rHpLim 856 +#define OFFSET_StgRegTable_rCCCS 864 +#define OFFSET_StgRegTable_rCurrentTSO 872 +#define OFFSET_StgRegTable_rCurrentNursery 888 +#define OFFSET_StgRegTable_rHpAlloc 904 +#define OFFSET_StgRegTable_rRet 912 +#define REP_StgRegTable_rRet b64 +#define StgRegTable_rRet(__ptr__) REP_StgRegTable_rRet[__ptr__+OFFSET_StgRegTable_rRet] +#define OFFSET_StgRegTable_rNursery 880 +#define REP_StgRegTable_rNursery b64 +#define StgRegTable_rNursery(__ptr__) REP_StgRegTable_rNursery[__ptr__+OFFSET_StgRegTable_rNursery] +#define OFFSET_stgEagerBlackholeInfo -24 +#define OFFSET_stgGCEnter1 -16 +#define OFFSET_stgGCFun -8 +#define OFFSET_Capability_r 24 +#define OFFSET_Capability_lock 1096 +#define OFFSET_Capability_no 944 +#define REP_Capability_no b32 +#define Capability_no(__ptr__) REP_Capability_no[__ptr__+OFFSET_Capability_no] +#define OFFSET_Capability_mut_lists 1016 +#define REP_Capability_mut_lists b64 +#define Capability_mut_lists(__ptr__) REP_Capability_mut_lists[__ptr__+OFFSET_Capability_mut_lists] +#define OFFSET_Capability_context_switch 1064 +#define REP_Capability_context_switch b32 +#define Capability_context_switch(__ptr__) REP_Capability_context_switch[__ptr__+OFFSET_Capability_context_switch] +#define OFFSET_Capability_interrupt 1068 +#define REP_Capability_interrupt b32 +#define Capability_interrupt(__ptr__) REP_Capability_interrupt[__ptr__+OFFSET_Capability_interrupt] +#define OFFSET_Capability_sparks 1200 +#define REP_Capability_sparks b64 +#define Capability_sparks(__ptr__) REP_Capability_sparks[__ptr__+OFFSET_Capability_sparks] +#define OFFSET_Capability_total_allocated 1072 +#define REP_Capability_total_allocated b64 +#define Capability_total_allocated(__ptr__) REP_Capability_total_allocated[__ptr__+OFFSET_Capability_total_allocated] +#define OFFSET_Capability_weak_ptr_list_hd 1048 +#define REP_Capability_weak_ptr_list_hd b64 +#define Capability_weak_ptr_list_hd(__ptr__) REP_Capability_weak_ptr_list_hd[__ptr__+OFFSET_Capability_weak_ptr_list_hd] +#define OFFSET_Capability_weak_ptr_list_tl 1056 +#define REP_Capability_weak_ptr_list_tl b64 +#define Capability_weak_ptr_list_tl(__ptr__) REP_Capability_weak_ptr_list_tl[__ptr__+OFFSET_Capability_weak_ptr_list_tl] +#define OFFSET_bdescr_start 0 +#define REP_bdescr_start b64 +#define bdescr_start(__ptr__) REP_bdescr_start[__ptr__+OFFSET_bdescr_start] +#define OFFSET_bdescr_free 8 +#define REP_bdescr_free b64 +#define bdescr_free(__ptr__) REP_bdescr_free[__ptr__+OFFSET_bdescr_free] +#define OFFSET_bdescr_blocks 48 +#define REP_bdescr_blocks b32 +#define bdescr_blocks(__ptr__) REP_bdescr_blocks[__ptr__+OFFSET_bdescr_blocks] +#define OFFSET_bdescr_gen_no 40 +#define REP_bdescr_gen_no b16 +#define bdescr_gen_no(__ptr__) REP_bdescr_gen_no[__ptr__+OFFSET_bdescr_gen_no] +#define OFFSET_bdescr_link 16 +#define REP_bdescr_link b64 +#define bdescr_link(__ptr__) REP_bdescr_link[__ptr__+OFFSET_bdescr_link] +#define OFFSET_bdescr_flags 46 +#define REP_bdescr_flags b16 +#define bdescr_flags(__ptr__) REP_bdescr_flags[__ptr__+OFFSET_bdescr_flags] +#define SIZEOF_generation 384 +#define OFFSET_generation_n_new_large_words 56 +#define REP_generation_n_new_large_words b64 +#define generation_n_new_large_words(__ptr__) REP_generation_n_new_large_words[__ptr__+OFFSET_generation_n_new_large_words] +#define OFFSET_generation_weak_ptr_list 112 +#define REP_generation_weak_ptr_list b64 +#define generation_weak_ptr_list(__ptr__) REP_generation_weak_ptr_list[__ptr__+OFFSET_generation_weak_ptr_list] +#define SIZEOF_CostCentreStack 96 +#define OFFSET_CostCentreStack_ccsID 0 +#define REP_CostCentreStack_ccsID b64 +#define CostCentreStack_ccsID(__ptr__) REP_CostCentreStack_ccsID[__ptr__+OFFSET_CostCentreStack_ccsID] +#define OFFSET_CostCentreStack_mem_alloc 72 +#define REP_CostCentreStack_mem_alloc b64 +#define CostCentreStack_mem_alloc(__ptr__) REP_CostCentreStack_mem_alloc[__ptr__+OFFSET_CostCentreStack_mem_alloc] +#define OFFSET_CostCentreStack_scc_count 48 +#define REP_CostCentreStack_scc_count b64 +#define CostCentreStack_scc_count(__ptr__) REP_CostCentreStack_scc_count[__ptr__+OFFSET_CostCentreStack_scc_count] +#define OFFSET_CostCentreStack_prevStack 16 +#define REP_CostCentreStack_prevStack b64 +#define CostCentreStack_prevStack(__ptr__) REP_CostCentreStack_prevStack[__ptr__+OFFSET_CostCentreStack_prevStack] +#define OFFSET_CostCentre_ccID 0 +#define REP_CostCentre_ccID b64 +#define CostCentre_ccID(__ptr__) REP_CostCentre_ccID[__ptr__+OFFSET_CostCentre_ccID] +#define OFFSET_CostCentre_link 56 +#define REP_CostCentre_link b64 +#define CostCentre_link(__ptr__) REP_CostCentre_link[__ptr__+OFFSET_CostCentre_link] +#define OFFSET_StgHeader_info 0 +#define REP_StgHeader_info b64 +#define StgHeader_info(__ptr__) REP_StgHeader_info[__ptr__+OFFSET_StgHeader_info] +#define OFFSET_StgHeader_ccs 8 +#define REP_StgHeader_ccs b64 +#define StgHeader_ccs(__ptr__) REP_StgHeader_ccs[__ptr__+OFFSET_StgHeader_ccs] +#define OFFSET_StgHeader_ldvw 16 +#define REP_StgHeader_ldvw b64 +#define StgHeader_ldvw(__ptr__) REP_StgHeader_ldvw[__ptr__+OFFSET_StgHeader_ldvw] +#define SIZEOF_StgSMPThunkHeader 8 +#define OFFSET_StgClosure_payload 0 +#define StgClosure_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgClosure_payload + WDS(__ix__)] +#define OFFSET_StgEntCounter_allocs 48 +#define REP_StgEntCounter_allocs b64 +#define StgEntCounter_allocs(__ptr__) REP_StgEntCounter_allocs[__ptr__+OFFSET_StgEntCounter_allocs] +#define OFFSET_StgEntCounter_allocd 16 +#define REP_StgEntCounter_allocd b64 +#define StgEntCounter_allocd(__ptr__) REP_StgEntCounter_allocd[__ptr__+OFFSET_StgEntCounter_allocd] +#define OFFSET_StgEntCounter_registeredp 0 +#define REP_StgEntCounter_registeredp b64 +#define StgEntCounter_registeredp(__ptr__) REP_StgEntCounter_registeredp[__ptr__+OFFSET_StgEntCounter_registeredp] +#define OFFSET_StgEntCounter_link 56 +#define REP_StgEntCounter_link b64 +#define StgEntCounter_link(__ptr__) REP_StgEntCounter_link[__ptr__+OFFSET_StgEntCounter_link] +#define OFFSET_StgEntCounter_entry_count 40 +#define REP_StgEntCounter_entry_count b64 +#define StgEntCounter_entry_count(__ptr__) REP_StgEntCounter_entry_count[__ptr__+OFFSET_StgEntCounter_entry_count] +#define SIZEOF_StgUpdateFrame_NoHdr 8 +#define SIZEOF_StgUpdateFrame (SIZEOF_StgHeader+8) +#define SIZEOF_StgCatchFrame_NoHdr 16 +#define SIZEOF_StgCatchFrame (SIZEOF_StgHeader+16) +#define SIZEOF_StgStopFrame_NoHdr 0 +#define SIZEOF_StgStopFrame (SIZEOF_StgHeader+0) +#define SIZEOF_StgMutArrPtrs_NoHdr 16 +#define SIZEOF_StgMutArrPtrs (SIZEOF_StgHeader+16) +#define OFFSET_StgMutArrPtrs_ptrs 0 +#define REP_StgMutArrPtrs_ptrs b64 +#define StgMutArrPtrs_ptrs(__ptr__) REP_StgMutArrPtrs_ptrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgMutArrPtrs_ptrs] +#define OFFSET_StgMutArrPtrs_size 8 +#define REP_StgMutArrPtrs_size b64 +#define StgMutArrPtrs_size(__ptr__) REP_StgMutArrPtrs_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgMutArrPtrs_size] +#define SIZEOF_StgSmallMutArrPtrs_NoHdr 8 +#define SIZEOF_StgSmallMutArrPtrs (SIZEOF_StgHeader+8) +#define OFFSET_StgSmallMutArrPtrs_ptrs 0 +#define REP_StgSmallMutArrPtrs_ptrs b64 +#define StgSmallMutArrPtrs_ptrs(__ptr__) REP_StgSmallMutArrPtrs_ptrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgSmallMutArrPtrs_ptrs] +#define SIZEOF_StgArrBytes_NoHdr 8 +#define SIZEOF_StgArrBytes (SIZEOF_StgHeader+8) +#define OFFSET_StgArrBytes_bytes 0 +#define REP_StgArrBytes_bytes b64 +#define StgArrBytes_bytes(__ptr__) REP_StgArrBytes_bytes[__ptr__+SIZEOF_StgHeader+OFFSET_StgArrBytes_bytes] +#define OFFSET_StgArrBytes_payload 8 +#define StgArrBytes_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgArrBytes_payload + WDS(__ix__)] +#define OFFSET_StgTSO__link 0 +#define REP_StgTSO__link b64 +#define StgTSO__link(__ptr__) REP_StgTSO__link[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO__link] +#define OFFSET_StgTSO_global_link 8 +#define REP_StgTSO_global_link b64 +#define StgTSO_global_link(__ptr__) REP_StgTSO_global_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_global_link] +#define OFFSET_StgTSO_what_next 24 +#define REP_StgTSO_what_next b16 +#define StgTSO_what_next(__ptr__) REP_StgTSO_what_next[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_what_next] +#define OFFSET_StgTSO_why_blocked 26 +#define REP_StgTSO_why_blocked b16 +#define StgTSO_why_blocked(__ptr__) REP_StgTSO_why_blocked[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_why_blocked] +#define OFFSET_StgTSO_block_info 32 +#define REP_StgTSO_block_info b64 +#define StgTSO_block_info(__ptr__) REP_StgTSO_block_info[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_block_info] +#define OFFSET_StgTSO_blocked_exceptions 80 +#define REP_StgTSO_blocked_exceptions b64 +#define StgTSO_blocked_exceptions(__ptr__) REP_StgTSO_blocked_exceptions[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_blocked_exceptions] +#define OFFSET_StgTSO_id 40 +#define REP_StgTSO_id b32 +#define StgTSO_id(__ptr__) REP_StgTSO_id[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_id] +#define OFFSET_StgTSO_cap 64 +#define REP_StgTSO_cap b64 +#define StgTSO_cap(__ptr__) REP_StgTSO_cap[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_cap] +#define OFFSET_StgTSO_saved_errno 44 +#define REP_StgTSO_saved_errno b32 +#define StgTSO_saved_errno(__ptr__) REP_StgTSO_saved_errno[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_saved_errno] +#define OFFSET_StgTSO_trec 72 +#define REP_StgTSO_trec b64 +#define StgTSO_trec(__ptr__) REP_StgTSO_trec[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_trec] +#define OFFSET_StgTSO_flags 28 +#define REP_StgTSO_flags b32 +#define StgTSO_flags(__ptr__) REP_StgTSO_flags[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_flags] +#define OFFSET_StgTSO_dirty 48 +#define REP_StgTSO_dirty b32 +#define StgTSO_dirty(__ptr__) REP_StgTSO_dirty[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_dirty] +#define OFFSET_StgTSO_bq 88 +#define REP_StgTSO_bq b64 +#define StgTSO_bq(__ptr__) REP_StgTSO_bq[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_bq] +#define OFFSET_StgTSO_alloc_limit 96 +#define REP_StgTSO_alloc_limit b64 +#define StgTSO_alloc_limit(__ptr__) REP_StgTSO_alloc_limit[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_alloc_limit] +#define OFFSET_StgTSO_cccs 112 +#define REP_StgTSO_cccs b64 +#define StgTSO_cccs(__ptr__) REP_StgTSO_cccs[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_cccs] +#define OFFSET_StgTSO_stackobj 16 +#define REP_StgTSO_stackobj b64 +#define StgTSO_stackobj(__ptr__) REP_StgTSO_stackobj[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_stackobj] +#define OFFSET_StgStack_sp 8 +#define REP_StgStack_sp b64 +#define StgStack_sp(__ptr__) REP_StgStack_sp[__ptr__+SIZEOF_StgHeader+OFFSET_StgStack_sp] +#define OFFSET_StgStack_stack 16 +#define OFFSET_StgStack_stack_size 0 +#define REP_StgStack_stack_size b32 +#define StgStack_stack_size(__ptr__) REP_StgStack_stack_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgStack_stack_size] +#define OFFSET_StgStack_dirty 4 +#define REP_StgStack_dirty b32 +#define StgStack_dirty(__ptr__) REP_StgStack_dirty[__ptr__+SIZEOF_StgHeader+OFFSET_StgStack_dirty] +#define SIZEOF_StgTSOProfInfo 8 +#define OFFSET_StgUpdateFrame_updatee 0 +#define REP_StgUpdateFrame_updatee b64 +#define StgUpdateFrame_updatee(__ptr__) REP_StgUpdateFrame_updatee[__ptr__+SIZEOF_StgHeader+OFFSET_StgUpdateFrame_updatee] +#define OFFSET_StgCatchFrame_handler 8 +#define REP_StgCatchFrame_handler b64 +#define StgCatchFrame_handler(__ptr__) REP_StgCatchFrame_handler[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchFrame_handler] +#define OFFSET_StgCatchFrame_exceptions_blocked 0 +#define REP_StgCatchFrame_exceptions_blocked b64 +#define StgCatchFrame_exceptions_blocked(__ptr__) REP_StgCatchFrame_exceptions_blocked[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchFrame_exceptions_blocked] +#define SIZEOF_StgPAP_NoHdr 16 +#define SIZEOF_StgPAP (SIZEOF_StgHeader+16) +#define OFFSET_StgPAP_n_args 4 +#define REP_StgPAP_n_args b32 +#define StgPAP_n_args(__ptr__) REP_StgPAP_n_args[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_n_args] +#define OFFSET_StgPAP_fun 8 +#define REP_StgPAP_fun gcptr +#define StgPAP_fun(__ptr__) REP_StgPAP_fun[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_fun] +#define OFFSET_StgPAP_arity 0 +#define REP_StgPAP_arity b32 +#define StgPAP_arity(__ptr__) REP_StgPAP_arity[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_arity] +#define OFFSET_StgPAP_payload 16 +#define StgPAP_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_payload + WDS(__ix__)] +#define SIZEOF_StgAP_NoThunkHdr 16 +#define SIZEOF_StgAP_NoHdr 24 +#define SIZEOF_StgAP (SIZEOF_StgHeader+24) +#define OFFSET_StgAP_n_args 12 +#define REP_StgAP_n_args b32 +#define StgAP_n_args(__ptr__) REP_StgAP_n_args[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_n_args] +#define OFFSET_StgAP_fun 16 +#define REP_StgAP_fun gcptr +#define StgAP_fun(__ptr__) REP_StgAP_fun[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_fun] +#define OFFSET_StgAP_payload 24 +#define StgAP_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_payload + WDS(__ix__)] +#define SIZEOF_StgAP_STACK_NoThunkHdr 16 +#define SIZEOF_StgAP_STACK_NoHdr 24 +#define SIZEOF_StgAP_STACK (SIZEOF_StgHeader+24) +#define OFFSET_StgAP_STACK_size 8 +#define REP_StgAP_STACK_size b64 +#define StgAP_STACK_size(__ptr__) REP_StgAP_STACK_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_STACK_size] +#define OFFSET_StgAP_STACK_fun 16 +#define REP_StgAP_STACK_fun gcptr +#define StgAP_STACK_fun(__ptr__) REP_StgAP_STACK_fun[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_STACK_fun] +#define OFFSET_StgAP_STACK_payload 24 +#define StgAP_STACK_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_STACK_payload + WDS(__ix__)] +#define SIZEOF_StgSelector_NoThunkHdr 8 +#define SIZEOF_StgSelector_NoHdr 16 +#define SIZEOF_StgSelector (SIZEOF_StgHeader+16) +#define OFFSET_StgInd_indirectee 0 +#define REP_StgInd_indirectee gcptr +#define StgInd_indirectee(__ptr__) REP_StgInd_indirectee[__ptr__+SIZEOF_StgHeader+OFFSET_StgInd_indirectee] +#define SIZEOF_StgMutVar_NoHdr 8 +#define SIZEOF_StgMutVar (SIZEOF_StgHeader+8) +#define OFFSET_StgMutVar_var 0 +#define REP_StgMutVar_var b64 +#define StgMutVar_var(__ptr__) REP_StgMutVar_var[__ptr__+SIZEOF_StgHeader+OFFSET_StgMutVar_var] +#define SIZEOF_StgAtomicallyFrame_NoHdr 16 +#define SIZEOF_StgAtomicallyFrame (SIZEOF_StgHeader+16) +#define OFFSET_StgAtomicallyFrame_code 0 +#define REP_StgAtomicallyFrame_code b64 +#define StgAtomicallyFrame_code(__ptr__) REP_StgAtomicallyFrame_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgAtomicallyFrame_code] +#define OFFSET_StgAtomicallyFrame_result 8 +#define REP_StgAtomicallyFrame_result b64 +#define StgAtomicallyFrame_result(__ptr__) REP_StgAtomicallyFrame_result[__ptr__+SIZEOF_StgHeader+OFFSET_StgAtomicallyFrame_result] +#define OFFSET_StgTRecHeader_enclosing_trec 0 +#define REP_StgTRecHeader_enclosing_trec b64 +#define StgTRecHeader_enclosing_trec(__ptr__) REP_StgTRecHeader_enclosing_trec[__ptr__+SIZEOF_StgHeader+OFFSET_StgTRecHeader_enclosing_trec] +#define SIZEOF_StgCatchSTMFrame_NoHdr 16 +#define SIZEOF_StgCatchSTMFrame (SIZEOF_StgHeader+16) +#define OFFSET_StgCatchSTMFrame_handler 8 +#define REP_StgCatchSTMFrame_handler b64 +#define StgCatchSTMFrame_handler(__ptr__) REP_StgCatchSTMFrame_handler[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchSTMFrame_handler] +#define OFFSET_StgCatchSTMFrame_code 0 +#define REP_StgCatchSTMFrame_code b64 +#define StgCatchSTMFrame_code(__ptr__) REP_StgCatchSTMFrame_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchSTMFrame_code] +#define SIZEOF_StgCatchRetryFrame_NoHdr 24 +#define SIZEOF_StgCatchRetryFrame (SIZEOF_StgHeader+24) +#define OFFSET_StgCatchRetryFrame_running_alt_code 0 +#define REP_StgCatchRetryFrame_running_alt_code b64 +#define StgCatchRetryFrame_running_alt_code(__ptr__) REP_StgCatchRetryFrame_running_alt_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchRetryFrame_running_alt_code] +#define OFFSET_StgCatchRetryFrame_first_code 8 +#define REP_StgCatchRetryFrame_first_code b64 +#define StgCatchRetryFrame_first_code(__ptr__) REP_StgCatchRetryFrame_first_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchRetryFrame_first_code] +#define OFFSET_StgCatchRetryFrame_alt_code 16 +#define REP_StgCatchRetryFrame_alt_code b64 +#define StgCatchRetryFrame_alt_code(__ptr__) REP_StgCatchRetryFrame_alt_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchRetryFrame_alt_code] +#define OFFSET_StgTVarWatchQueue_closure 0 +#define REP_StgTVarWatchQueue_closure b64 +#define StgTVarWatchQueue_closure(__ptr__) REP_StgTVarWatchQueue_closure[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVarWatchQueue_closure] +#define OFFSET_StgTVarWatchQueue_next_queue_entry 8 +#define REP_StgTVarWatchQueue_next_queue_entry b64 +#define StgTVarWatchQueue_next_queue_entry(__ptr__) REP_StgTVarWatchQueue_next_queue_entry[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVarWatchQueue_next_queue_entry] +#define OFFSET_StgTVarWatchQueue_prev_queue_entry 16 +#define REP_StgTVarWatchQueue_prev_queue_entry b64 +#define StgTVarWatchQueue_prev_queue_entry(__ptr__) REP_StgTVarWatchQueue_prev_queue_entry[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVarWatchQueue_prev_queue_entry] +#define SIZEOF_StgTVar_NoHdr 24 +#define SIZEOF_StgTVar (SIZEOF_StgHeader+24) +#define OFFSET_StgTVar_current_value 0 +#define REP_StgTVar_current_value b64 +#define StgTVar_current_value(__ptr__) REP_StgTVar_current_value[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVar_current_value] +#define OFFSET_StgTVar_first_watch_queue_entry 8 +#define REP_StgTVar_first_watch_queue_entry b64 +#define StgTVar_first_watch_queue_entry(__ptr__) REP_StgTVar_first_watch_queue_entry[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVar_first_watch_queue_entry] +#define OFFSET_StgTVar_num_updates 16 +#define REP_StgTVar_num_updates b64 +#define StgTVar_num_updates(__ptr__) REP_StgTVar_num_updates[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVar_num_updates] +#define SIZEOF_StgWeak_NoHdr 40 +#define SIZEOF_StgWeak (SIZEOF_StgHeader+40) +#define OFFSET_StgWeak_link 32 +#define REP_StgWeak_link b64 +#define StgWeak_link(__ptr__) REP_StgWeak_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_link] +#define OFFSET_StgWeak_key 8 +#define REP_StgWeak_key b64 +#define StgWeak_key(__ptr__) REP_StgWeak_key[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_key] +#define OFFSET_StgWeak_value 16 +#define REP_StgWeak_value b64 +#define StgWeak_value(__ptr__) REP_StgWeak_value[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_value] +#define OFFSET_StgWeak_finalizer 24 +#define REP_StgWeak_finalizer b64 +#define StgWeak_finalizer(__ptr__) REP_StgWeak_finalizer[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_finalizer] +#define OFFSET_StgWeak_cfinalizers 0 +#define REP_StgWeak_cfinalizers b64 +#define StgWeak_cfinalizers(__ptr__) REP_StgWeak_cfinalizers[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_cfinalizers] +#define SIZEOF_StgCFinalizerList_NoHdr 40 +#define SIZEOF_StgCFinalizerList (SIZEOF_StgHeader+40) +#define OFFSET_StgCFinalizerList_link 0 +#define REP_StgCFinalizerList_link b64 +#define StgCFinalizerList_link(__ptr__) REP_StgCFinalizerList_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_link] +#define OFFSET_StgCFinalizerList_fptr 8 +#define REP_StgCFinalizerList_fptr b64 +#define StgCFinalizerList_fptr(__ptr__) REP_StgCFinalizerList_fptr[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_fptr] +#define OFFSET_StgCFinalizerList_ptr 16 +#define REP_StgCFinalizerList_ptr b64 +#define StgCFinalizerList_ptr(__ptr__) REP_StgCFinalizerList_ptr[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_ptr] +#define OFFSET_StgCFinalizerList_eptr 24 +#define REP_StgCFinalizerList_eptr b64 +#define StgCFinalizerList_eptr(__ptr__) REP_StgCFinalizerList_eptr[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_eptr] +#define OFFSET_StgCFinalizerList_flag 32 +#define REP_StgCFinalizerList_flag b64 +#define StgCFinalizerList_flag(__ptr__) REP_StgCFinalizerList_flag[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_flag] +#define SIZEOF_StgMVar_NoHdr 24 +#define SIZEOF_StgMVar (SIZEOF_StgHeader+24) +#define OFFSET_StgMVar_head 0 +#define REP_StgMVar_head b64 +#define StgMVar_head(__ptr__) REP_StgMVar_head[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVar_head] +#define OFFSET_StgMVar_tail 8 +#define REP_StgMVar_tail b64 +#define StgMVar_tail(__ptr__) REP_StgMVar_tail[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVar_tail] +#define OFFSET_StgMVar_value 16 +#define REP_StgMVar_value b64 +#define StgMVar_value(__ptr__) REP_StgMVar_value[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVar_value] +#define SIZEOF_StgMVarTSOQueue_NoHdr 16 +#define SIZEOF_StgMVarTSOQueue (SIZEOF_StgHeader+16) +#define OFFSET_StgMVarTSOQueue_link 0 +#define REP_StgMVarTSOQueue_link b64 +#define StgMVarTSOQueue_link(__ptr__) REP_StgMVarTSOQueue_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVarTSOQueue_link] +#define OFFSET_StgMVarTSOQueue_tso 8 +#define REP_StgMVarTSOQueue_tso b64 +#define StgMVarTSOQueue_tso(__ptr__) REP_StgMVarTSOQueue_tso[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVarTSOQueue_tso] +#define SIZEOF_StgBCO_NoHdr 32 +#define SIZEOF_StgBCO (SIZEOF_StgHeader+32) +#define OFFSET_StgBCO_instrs 0 +#define REP_StgBCO_instrs b64 +#define StgBCO_instrs(__ptr__) REP_StgBCO_instrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_instrs] +#define OFFSET_StgBCO_literals 8 +#define REP_StgBCO_literals b64 +#define StgBCO_literals(__ptr__) REP_StgBCO_literals[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_literals] +#define OFFSET_StgBCO_ptrs 16 +#define REP_StgBCO_ptrs b64 +#define StgBCO_ptrs(__ptr__) REP_StgBCO_ptrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_ptrs] +#define OFFSET_StgBCO_arity 24 +#define REP_StgBCO_arity b32 +#define StgBCO_arity(__ptr__) REP_StgBCO_arity[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_arity] +#define OFFSET_StgBCO_size 28 +#define REP_StgBCO_size b32 +#define StgBCO_size(__ptr__) REP_StgBCO_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_size] +#define OFFSET_StgBCO_bitmap 32 +#define StgBCO_bitmap(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_bitmap + WDS(__ix__)] +#define SIZEOF_StgStableName_NoHdr 8 +#define SIZEOF_StgStableName (SIZEOF_StgHeader+8) +#define OFFSET_StgStableName_sn 0 +#define REP_StgStableName_sn b64 +#define StgStableName_sn(__ptr__) REP_StgStableName_sn[__ptr__+SIZEOF_StgHeader+OFFSET_StgStableName_sn] +#define SIZEOF_StgBlockingQueue_NoHdr 32 +#define SIZEOF_StgBlockingQueue (SIZEOF_StgHeader+32) +#define OFFSET_StgBlockingQueue_bh 8 +#define REP_StgBlockingQueue_bh b64 +#define StgBlockingQueue_bh(__ptr__) REP_StgBlockingQueue_bh[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_bh] +#define OFFSET_StgBlockingQueue_owner 16 +#define REP_StgBlockingQueue_owner b64 +#define StgBlockingQueue_owner(__ptr__) REP_StgBlockingQueue_owner[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_owner] +#define OFFSET_StgBlockingQueue_queue 24 +#define REP_StgBlockingQueue_queue b64 +#define StgBlockingQueue_queue(__ptr__) REP_StgBlockingQueue_queue[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_queue] +#define OFFSET_StgBlockingQueue_link 0 +#define REP_StgBlockingQueue_link b64 +#define StgBlockingQueue_link(__ptr__) REP_StgBlockingQueue_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_link] +#define SIZEOF_MessageBlackHole_NoHdr 24 +#define SIZEOF_MessageBlackHole (SIZEOF_StgHeader+24) +#define OFFSET_MessageBlackHole_link 0 +#define REP_MessageBlackHole_link b64 +#define MessageBlackHole_link(__ptr__) REP_MessageBlackHole_link[__ptr__+SIZEOF_StgHeader+OFFSET_MessageBlackHole_link] +#define OFFSET_MessageBlackHole_tso 8 +#define REP_MessageBlackHole_tso b64 +#define MessageBlackHole_tso(__ptr__) REP_MessageBlackHole_tso[__ptr__+SIZEOF_StgHeader+OFFSET_MessageBlackHole_tso] +#define OFFSET_MessageBlackHole_bh 16 +#define REP_MessageBlackHole_bh b64 +#define MessageBlackHole_bh(__ptr__) REP_MessageBlackHole_bh[__ptr__+SIZEOF_StgHeader+OFFSET_MessageBlackHole_bh] +#define SIZEOF_StgCompactNFData_NoHdr 64 +#define SIZEOF_StgCompactNFData (SIZEOF_StgHeader+64) +#define OFFSET_StgCompactNFData_totalW 0 +#define REP_StgCompactNFData_totalW b64 +#define StgCompactNFData_totalW(__ptr__) REP_StgCompactNFData_totalW[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_totalW] +#define OFFSET_StgCompactNFData_autoBlockW 8 +#define REP_StgCompactNFData_autoBlockW b64 +#define StgCompactNFData_autoBlockW(__ptr__) REP_StgCompactNFData_autoBlockW[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_autoBlockW] +#define OFFSET_StgCompactNFData_nursery 32 +#define REP_StgCompactNFData_nursery b64 +#define StgCompactNFData_nursery(__ptr__) REP_StgCompactNFData_nursery[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_nursery] +#define OFFSET_StgCompactNFData_last 40 +#define REP_StgCompactNFData_last b64 +#define StgCompactNFData_last(__ptr__) REP_StgCompactNFData_last[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_last] +#define OFFSET_StgCompactNFData_hp 16 +#define REP_StgCompactNFData_hp b64 +#define StgCompactNFData_hp(__ptr__) REP_StgCompactNFData_hp[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_hp] +#define OFFSET_StgCompactNFData_hpLim 24 +#define REP_StgCompactNFData_hpLim b64 +#define StgCompactNFData_hpLim(__ptr__) REP_StgCompactNFData_hpLim[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_hpLim] +#define OFFSET_StgCompactNFData_hash 48 +#define REP_StgCompactNFData_hash b64 +#define StgCompactNFData_hash(__ptr__) REP_StgCompactNFData_hash[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_hash] +#define OFFSET_StgCompactNFData_result 56 +#define REP_StgCompactNFData_result b64 +#define StgCompactNFData_result(__ptr__) REP_StgCompactNFData_result[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_result] +#define SIZEOF_StgCompactNFDataBlock 24 +#define OFFSET_StgCompactNFDataBlock_self 0 +#define REP_StgCompactNFDataBlock_self b64 +#define StgCompactNFDataBlock_self(__ptr__) REP_StgCompactNFDataBlock_self[__ptr__+OFFSET_StgCompactNFDataBlock_self] +#define OFFSET_StgCompactNFDataBlock_owner 8 +#define REP_StgCompactNFDataBlock_owner b64 +#define StgCompactNFDataBlock_owner(__ptr__) REP_StgCompactNFDataBlock_owner[__ptr__+OFFSET_StgCompactNFDataBlock_owner] +#define OFFSET_StgCompactNFDataBlock_next 16 +#define REP_StgCompactNFDataBlock_next b64 +#define StgCompactNFDataBlock_next(__ptr__) REP_StgCompactNFDataBlock_next[__ptr__+OFFSET_StgCompactNFDataBlock_next] +#define OFFSET_RtsFlags_ProfFlags_showCCSOnException 269 +#define REP_RtsFlags_ProfFlags_showCCSOnException b8 +#define RtsFlags_ProfFlags_showCCSOnException(__ptr__) REP_RtsFlags_ProfFlags_showCCSOnException[__ptr__+OFFSET_RtsFlags_ProfFlags_showCCSOnException] +#define OFFSET_RtsFlags_DebugFlags_apply 210 +#define REP_RtsFlags_DebugFlags_apply b8 +#define RtsFlags_DebugFlags_apply(__ptr__) REP_RtsFlags_DebugFlags_apply[__ptr__+OFFSET_RtsFlags_DebugFlags_apply] +#define OFFSET_RtsFlags_DebugFlags_sanity 206 +#define REP_RtsFlags_DebugFlags_sanity b8 +#define RtsFlags_DebugFlags_sanity(__ptr__) REP_RtsFlags_DebugFlags_sanity[__ptr__+OFFSET_RtsFlags_DebugFlags_sanity] +#define OFFSET_RtsFlags_DebugFlags_weak 202 +#define REP_RtsFlags_DebugFlags_weak b8 +#define RtsFlags_DebugFlags_weak(__ptr__) REP_RtsFlags_DebugFlags_weak[__ptr__+OFFSET_RtsFlags_DebugFlags_weak] +#define OFFSET_RtsFlags_GcFlags_initialStkSize 16 +#define REP_RtsFlags_GcFlags_initialStkSize b32 +#define RtsFlags_GcFlags_initialStkSize(__ptr__) REP_RtsFlags_GcFlags_initialStkSize[__ptr__+OFFSET_RtsFlags_GcFlags_initialStkSize] +#define OFFSET_RtsFlags_MiscFlags_tickInterval 176 +#define REP_RtsFlags_MiscFlags_tickInterval b64 +#define RtsFlags_MiscFlags_tickInterval(__ptr__) REP_RtsFlags_MiscFlags_tickInterval[__ptr__+OFFSET_RtsFlags_MiscFlags_tickInterval] +#define SIZEOF_StgFunInfoExtraFwd 32 +#define OFFSET_StgFunInfoExtraFwd_slow_apply 24 +#define REP_StgFunInfoExtraFwd_slow_apply b64 +#define StgFunInfoExtraFwd_slow_apply(__ptr__) REP_StgFunInfoExtraFwd_slow_apply[__ptr__+OFFSET_StgFunInfoExtraFwd_slow_apply] +#define OFFSET_StgFunInfoExtraFwd_fun_type 0 +#define REP_StgFunInfoExtraFwd_fun_type b32 +#define StgFunInfoExtraFwd_fun_type(__ptr__) REP_StgFunInfoExtraFwd_fun_type[__ptr__+OFFSET_StgFunInfoExtraFwd_fun_type] +#define OFFSET_StgFunInfoExtraFwd_arity 4 +#define REP_StgFunInfoExtraFwd_arity b32 +#define StgFunInfoExtraFwd_arity(__ptr__) REP_StgFunInfoExtraFwd_arity[__ptr__+OFFSET_StgFunInfoExtraFwd_arity] +#define OFFSET_StgFunInfoExtraFwd_bitmap 16 +#define REP_StgFunInfoExtraFwd_bitmap b64 +#define StgFunInfoExtraFwd_bitmap(__ptr__) REP_StgFunInfoExtraFwd_bitmap[__ptr__+OFFSET_StgFunInfoExtraFwd_bitmap] +#define SIZEOF_StgFunInfoExtraRev 24 +#define OFFSET_StgFunInfoExtraRev_slow_apply_offset 0 +#define REP_StgFunInfoExtraRev_slow_apply_offset b32 +#define StgFunInfoExtraRev_slow_apply_offset(__ptr__) REP_StgFunInfoExtraRev_slow_apply_offset[__ptr__+OFFSET_StgFunInfoExtraRev_slow_apply_offset] +#define OFFSET_StgFunInfoExtraRev_fun_type 16 +#define REP_StgFunInfoExtraRev_fun_type b32 +#define StgFunInfoExtraRev_fun_type(__ptr__) REP_StgFunInfoExtraRev_fun_type[__ptr__+OFFSET_StgFunInfoExtraRev_fun_type] +#define OFFSET_StgFunInfoExtraRev_arity 20 +#define REP_StgFunInfoExtraRev_arity b32 +#define StgFunInfoExtraRev_arity(__ptr__) REP_StgFunInfoExtraRev_arity[__ptr__+OFFSET_StgFunInfoExtraRev_arity] +#define OFFSET_StgFunInfoExtraRev_bitmap 8 +#define REP_StgFunInfoExtraRev_bitmap b64 +#define StgFunInfoExtraRev_bitmap(__ptr__) REP_StgFunInfoExtraRev_bitmap[__ptr__+OFFSET_StgFunInfoExtraRev_bitmap] +#define OFFSET_StgFunInfoExtraRev_bitmap_offset 8 +#define REP_StgFunInfoExtraRev_bitmap_offset b32 +#define StgFunInfoExtraRev_bitmap_offset(__ptr__) REP_StgFunInfoExtraRev_bitmap_offset[__ptr__+OFFSET_StgFunInfoExtraRev_bitmap_offset] +#define OFFSET_StgLargeBitmap_size 0 +#define REP_StgLargeBitmap_size b64 +#define StgLargeBitmap_size(__ptr__) REP_StgLargeBitmap_size[__ptr__+OFFSET_StgLargeBitmap_size] +#define OFFSET_StgLargeBitmap_bitmap 8 +#define SIZEOF_snEntry 24 +#define OFFSET_snEntry_sn_obj 16 +#define REP_snEntry_sn_obj b64 +#define snEntry_sn_obj(__ptr__) REP_snEntry_sn_obj[__ptr__+OFFSET_snEntry_sn_obj] +#define OFFSET_snEntry_addr 0 +#define REP_snEntry_addr b64 +#define snEntry_addr(__ptr__) REP_snEntry_addr[__ptr__+OFFSET_snEntry_addr] +#define SIZEOF_spEntry 8 +#define OFFSET_spEntry_addr 0 +#define REP_spEntry_addr b64 +#define spEntry_addr(__ptr__) REP_spEntry_addr[__ptr__+OFFSET_spEntry_addr] diff --git a/ghc-lib/generated/GHCConstantsHaskellExports.hs b/ghc-lib/generated/GHCConstantsHaskellExports.hs new file mode 100644 --- /dev/null +++ b/ghc-lib/generated/GHCConstantsHaskellExports.hs @@ -0,0 +1,125 @@ + cONTROL_GROUP_CONST_291, + sTD_HDR_SIZE, + pROF_HDR_SIZE, + bLOCK_SIZE, + bLOCKS_PER_MBLOCK, + tICKY_BIN_COUNT, + oFFSET_StgRegTable_rR1, + oFFSET_StgRegTable_rR2, + oFFSET_StgRegTable_rR3, + oFFSET_StgRegTable_rR4, + oFFSET_StgRegTable_rR5, + oFFSET_StgRegTable_rR6, + oFFSET_StgRegTable_rR7, + oFFSET_StgRegTable_rR8, + oFFSET_StgRegTable_rR9, + oFFSET_StgRegTable_rR10, + oFFSET_StgRegTable_rF1, + oFFSET_StgRegTable_rF2, + oFFSET_StgRegTable_rF3, + oFFSET_StgRegTable_rF4, + oFFSET_StgRegTable_rF5, + oFFSET_StgRegTable_rF6, + oFFSET_StgRegTable_rD1, + oFFSET_StgRegTable_rD2, + oFFSET_StgRegTable_rD3, + oFFSET_StgRegTable_rD4, + oFFSET_StgRegTable_rD5, + oFFSET_StgRegTable_rD6, + oFFSET_StgRegTable_rXMM1, + oFFSET_StgRegTable_rXMM2, + oFFSET_StgRegTable_rXMM3, + oFFSET_StgRegTable_rXMM4, + oFFSET_StgRegTable_rXMM5, + oFFSET_StgRegTable_rXMM6, + oFFSET_StgRegTable_rYMM1, + oFFSET_StgRegTable_rYMM2, + oFFSET_StgRegTable_rYMM3, + oFFSET_StgRegTable_rYMM4, + oFFSET_StgRegTable_rYMM5, + oFFSET_StgRegTable_rYMM6, + oFFSET_StgRegTable_rZMM1, + oFFSET_StgRegTable_rZMM2, + oFFSET_StgRegTable_rZMM3, + oFFSET_StgRegTable_rZMM4, + oFFSET_StgRegTable_rZMM5, + oFFSET_StgRegTable_rZMM6, + oFFSET_StgRegTable_rL1, + oFFSET_StgRegTable_rSp, + oFFSET_StgRegTable_rSpLim, + oFFSET_StgRegTable_rHp, + oFFSET_StgRegTable_rHpLim, + oFFSET_StgRegTable_rCCCS, + oFFSET_StgRegTable_rCurrentTSO, + oFFSET_StgRegTable_rCurrentNursery, + oFFSET_StgRegTable_rHpAlloc, + oFFSET_stgEagerBlackholeInfo, + oFFSET_stgGCEnter1, + oFFSET_stgGCFun, + oFFSET_Capability_r, + oFFSET_bdescr_start, + oFFSET_bdescr_free, + oFFSET_bdescr_blocks, + oFFSET_bdescr_flags, + sIZEOF_CostCentreStack, + oFFSET_CostCentreStack_mem_alloc, + oFFSET_CostCentreStack_scc_count, + oFFSET_StgHeader_ccs, + oFFSET_StgHeader_ldvw, + sIZEOF_StgSMPThunkHeader, + oFFSET_StgEntCounter_allocs, + oFFSET_StgEntCounter_allocd, + oFFSET_StgEntCounter_registeredp, + oFFSET_StgEntCounter_link, + oFFSET_StgEntCounter_entry_count, + sIZEOF_StgUpdateFrame_NoHdr, + sIZEOF_StgMutArrPtrs_NoHdr, + oFFSET_StgMutArrPtrs_ptrs, + oFFSET_StgMutArrPtrs_size, + sIZEOF_StgSmallMutArrPtrs_NoHdr, + oFFSET_StgSmallMutArrPtrs_ptrs, + sIZEOF_StgArrBytes_NoHdr, + oFFSET_StgArrBytes_bytes, + oFFSET_StgTSO_alloc_limit, + oFFSET_StgTSO_cccs, + oFFSET_StgTSO_stackobj, + oFFSET_StgStack_sp, + oFFSET_StgStack_stack, + oFFSET_StgUpdateFrame_updatee, + oFFSET_StgFunInfoExtraFwd_arity, + sIZEOF_StgFunInfoExtraRev, + oFFSET_StgFunInfoExtraRev_arity, + mAX_SPEC_SELECTEE_SIZE, + mAX_SPEC_AP_SIZE, + mIN_PAYLOAD_SIZE, + mIN_INTLIKE, + mAX_INTLIKE, + mIN_CHARLIKE, + mAX_CHARLIKE, + mUT_ARR_PTRS_CARD_BITS, + mAX_Vanilla_REG, + mAX_Float_REG, + mAX_Double_REG, + mAX_Long_REG, + mAX_XMM_REG, + mAX_Real_Vanilla_REG, + mAX_Real_Float_REG, + mAX_Real_Double_REG, + mAX_Real_XMM_REG, + mAX_Real_Long_REG, + rESERVED_C_STACK_BYTES, + rESERVED_STACK_WORDS, + aP_STACK_SPLIM, + wORD_SIZE, + dOUBLE_SIZE, + cINT_SIZE, + cLONG_SIZE, + cLONG_LONG_SIZE, + bITMAP_BITS_SHIFT, + tAG_BITS, + wORDS_BIGENDIAN, + dYNAMIC_BY_DEFAULT, + lDV_SHIFT, + iLDV_CREATE_MASK, + iLDV_STATE_CREATE, + iLDV_STATE_USE, diff --git a/ghc-lib/generated/GHCConstantsHaskellType.hs b/ghc-lib/generated/GHCConstantsHaskellType.hs new file mode 100644 --- /dev/null +++ b/ghc-lib/generated/GHCConstantsHaskellType.hs @@ -0,0 +1,134 @@ +data PlatformConstants = PlatformConstants { + pc_platformConstants :: () + , pc_CONTROL_GROUP_CONST_291 :: Int + , pc_STD_HDR_SIZE :: Int + , pc_PROF_HDR_SIZE :: Int + , pc_BLOCK_SIZE :: Int + , pc_BLOCKS_PER_MBLOCK :: Int + , pc_TICKY_BIN_COUNT :: Int + , pc_OFFSET_StgRegTable_rR1 :: Int + , pc_OFFSET_StgRegTable_rR2 :: Int + , pc_OFFSET_StgRegTable_rR3 :: Int + , pc_OFFSET_StgRegTable_rR4 :: Int + , pc_OFFSET_StgRegTable_rR5 :: Int + , pc_OFFSET_StgRegTable_rR6 :: Int + , pc_OFFSET_StgRegTable_rR7 :: Int + , pc_OFFSET_StgRegTable_rR8 :: Int + , pc_OFFSET_StgRegTable_rR9 :: Int + , pc_OFFSET_StgRegTable_rR10 :: Int + , pc_OFFSET_StgRegTable_rF1 :: Int + , pc_OFFSET_StgRegTable_rF2 :: Int + , pc_OFFSET_StgRegTable_rF3 :: Int + , pc_OFFSET_StgRegTable_rF4 :: Int + , pc_OFFSET_StgRegTable_rF5 :: Int + , pc_OFFSET_StgRegTable_rF6 :: Int + , pc_OFFSET_StgRegTable_rD1 :: Int + , pc_OFFSET_StgRegTable_rD2 :: Int + , pc_OFFSET_StgRegTable_rD3 :: Int + , pc_OFFSET_StgRegTable_rD4 :: Int + , pc_OFFSET_StgRegTable_rD5 :: Int + , pc_OFFSET_StgRegTable_rD6 :: Int + , pc_OFFSET_StgRegTable_rXMM1 :: Int + , pc_OFFSET_StgRegTable_rXMM2 :: Int + , pc_OFFSET_StgRegTable_rXMM3 :: Int + , pc_OFFSET_StgRegTable_rXMM4 :: Int + , pc_OFFSET_StgRegTable_rXMM5 :: Int + , pc_OFFSET_StgRegTable_rXMM6 :: Int + , pc_OFFSET_StgRegTable_rYMM1 :: Int + , pc_OFFSET_StgRegTable_rYMM2 :: Int + , pc_OFFSET_StgRegTable_rYMM3 :: Int + , pc_OFFSET_StgRegTable_rYMM4 :: Int + , pc_OFFSET_StgRegTable_rYMM5 :: Int + , pc_OFFSET_StgRegTable_rYMM6 :: Int + , pc_OFFSET_StgRegTable_rZMM1 :: Int + , pc_OFFSET_StgRegTable_rZMM2 :: Int + , pc_OFFSET_StgRegTable_rZMM3 :: Int + , pc_OFFSET_StgRegTable_rZMM4 :: Int + , pc_OFFSET_StgRegTable_rZMM5 :: Int + , pc_OFFSET_StgRegTable_rZMM6 :: Int + , pc_OFFSET_StgRegTable_rL1 :: Int + , pc_OFFSET_StgRegTable_rSp :: Int + , pc_OFFSET_StgRegTable_rSpLim :: Int + , pc_OFFSET_StgRegTable_rHp :: Int + , pc_OFFSET_StgRegTable_rHpLim :: Int + , pc_OFFSET_StgRegTable_rCCCS :: Int + , pc_OFFSET_StgRegTable_rCurrentTSO :: Int + , pc_OFFSET_StgRegTable_rCurrentNursery :: Int + , pc_OFFSET_StgRegTable_rHpAlloc :: Int + , pc_OFFSET_stgEagerBlackholeInfo :: Int + , pc_OFFSET_stgGCEnter1 :: Int + , pc_OFFSET_stgGCFun :: Int + , pc_OFFSET_Capability_r :: Int + , pc_OFFSET_bdescr_start :: Int + , pc_OFFSET_bdescr_free :: Int + , pc_OFFSET_bdescr_blocks :: Int + , pc_OFFSET_bdescr_flags :: Int + , pc_SIZEOF_CostCentreStack :: Int + , pc_OFFSET_CostCentreStack_mem_alloc :: Int + , pc_REP_CostCentreStack_mem_alloc :: Int + , pc_OFFSET_CostCentreStack_scc_count :: Int + , pc_REP_CostCentreStack_scc_count :: Int + , pc_OFFSET_StgHeader_ccs :: Int + , pc_OFFSET_StgHeader_ldvw :: Int + , pc_SIZEOF_StgSMPThunkHeader :: Int + , pc_OFFSET_StgEntCounter_allocs :: Int + , pc_REP_StgEntCounter_allocs :: Int + , pc_OFFSET_StgEntCounter_allocd :: Int + , pc_REP_StgEntCounter_allocd :: Int + , pc_OFFSET_StgEntCounter_registeredp :: Int + , pc_OFFSET_StgEntCounter_link :: Int + , pc_OFFSET_StgEntCounter_entry_count :: Int + , pc_SIZEOF_StgUpdateFrame_NoHdr :: Int + , pc_SIZEOF_StgMutArrPtrs_NoHdr :: Int + , pc_OFFSET_StgMutArrPtrs_ptrs :: Int + , pc_OFFSET_StgMutArrPtrs_size :: Int + , pc_SIZEOF_StgSmallMutArrPtrs_NoHdr :: Int + , pc_OFFSET_StgSmallMutArrPtrs_ptrs :: Int + , pc_SIZEOF_StgArrBytes_NoHdr :: Int + , pc_OFFSET_StgArrBytes_bytes :: Int + , pc_OFFSET_StgTSO_alloc_limit :: Int + , pc_OFFSET_StgTSO_cccs :: Int + , pc_OFFSET_StgTSO_stackobj :: Int + , pc_OFFSET_StgStack_sp :: Int + , pc_OFFSET_StgStack_stack :: Int + , pc_OFFSET_StgUpdateFrame_updatee :: Int + , pc_OFFSET_StgFunInfoExtraFwd_arity :: Int + , pc_REP_StgFunInfoExtraFwd_arity :: Int + , pc_SIZEOF_StgFunInfoExtraRev :: Int + , pc_OFFSET_StgFunInfoExtraRev_arity :: Int + , pc_REP_StgFunInfoExtraRev_arity :: Int + , pc_MAX_SPEC_SELECTEE_SIZE :: Int + , pc_MAX_SPEC_AP_SIZE :: Int + , pc_MIN_PAYLOAD_SIZE :: Int + , pc_MIN_INTLIKE :: Int + , pc_MAX_INTLIKE :: Int + , pc_MIN_CHARLIKE :: Int + , pc_MAX_CHARLIKE :: Int + , pc_MUT_ARR_PTRS_CARD_BITS :: Int + , pc_MAX_Vanilla_REG :: Int + , pc_MAX_Float_REG :: Int + , pc_MAX_Double_REG :: Int + , pc_MAX_Long_REG :: Int + , pc_MAX_XMM_REG :: Int + , pc_MAX_Real_Vanilla_REG :: Int + , pc_MAX_Real_Float_REG :: Int + , pc_MAX_Real_Double_REG :: Int + , pc_MAX_Real_XMM_REG :: Int + , pc_MAX_Real_Long_REG :: Int + , pc_RESERVED_C_STACK_BYTES :: Int + , pc_RESERVED_STACK_WORDS :: Int + , pc_AP_STACK_SPLIM :: Int + , pc_WORD_SIZE :: Int + , pc_DOUBLE_SIZE :: Int + , pc_CINT_SIZE :: Int + , pc_CLONG_SIZE :: Int + , pc_CLONG_LONG_SIZE :: Int + , pc_BITMAP_BITS_SHIFT :: Int + , pc_TAG_BITS :: Int + , pc_WORDS_BIGENDIAN :: Bool + , pc_DYNAMIC_BY_DEFAULT :: Bool + , pc_LDV_SHIFT :: Int + , pc_ILDV_CREATE_MASK :: Integer + , pc_ILDV_STATE_CREATE :: Integer + , pc_ILDV_STATE_USE :: Integer + } deriving Read diff --git a/ghc-lib/generated/GHCConstantsHaskellWrappers.hs b/ghc-lib/generated/GHCConstantsHaskellWrappers.hs new file mode 100644 --- /dev/null +++ b/ghc-lib/generated/GHCConstantsHaskellWrappers.hs @@ -0,0 +1,250 @@ +cONTROL_GROUP_CONST_291 :: DynFlags -> Int +cONTROL_GROUP_CONST_291 dflags = pc_CONTROL_GROUP_CONST_291 (sPlatformConstants (settings dflags)) +sTD_HDR_SIZE :: DynFlags -> Int +sTD_HDR_SIZE dflags = pc_STD_HDR_SIZE (sPlatformConstants (settings dflags)) +pROF_HDR_SIZE :: DynFlags -> Int +pROF_HDR_SIZE dflags = pc_PROF_HDR_SIZE (sPlatformConstants (settings dflags)) +bLOCK_SIZE :: DynFlags -> Int +bLOCK_SIZE dflags = pc_BLOCK_SIZE (sPlatformConstants (settings dflags)) +bLOCKS_PER_MBLOCK :: DynFlags -> Int +bLOCKS_PER_MBLOCK dflags = pc_BLOCKS_PER_MBLOCK (sPlatformConstants (settings dflags)) +tICKY_BIN_COUNT :: DynFlags -> Int +tICKY_BIN_COUNT dflags = pc_TICKY_BIN_COUNT (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rR1 :: DynFlags -> Int +oFFSET_StgRegTable_rR1 dflags = pc_OFFSET_StgRegTable_rR1 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rR2 :: DynFlags -> Int +oFFSET_StgRegTable_rR2 dflags = pc_OFFSET_StgRegTable_rR2 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rR3 :: DynFlags -> Int +oFFSET_StgRegTable_rR3 dflags = pc_OFFSET_StgRegTable_rR3 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rR4 :: DynFlags -> Int +oFFSET_StgRegTable_rR4 dflags = pc_OFFSET_StgRegTable_rR4 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rR5 :: DynFlags -> Int +oFFSET_StgRegTable_rR5 dflags = pc_OFFSET_StgRegTable_rR5 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rR6 :: DynFlags -> Int +oFFSET_StgRegTable_rR6 dflags = pc_OFFSET_StgRegTable_rR6 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rR7 :: DynFlags -> Int +oFFSET_StgRegTable_rR7 dflags = pc_OFFSET_StgRegTable_rR7 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rR8 :: DynFlags -> Int +oFFSET_StgRegTable_rR8 dflags = pc_OFFSET_StgRegTable_rR8 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rR9 :: DynFlags -> Int +oFFSET_StgRegTable_rR9 dflags = pc_OFFSET_StgRegTable_rR9 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rR10 :: DynFlags -> Int +oFFSET_StgRegTable_rR10 dflags = pc_OFFSET_StgRegTable_rR10 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rF1 :: DynFlags -> Int +oFFSET_StgRegTable_rF1 dflags = pc_OFFSET_StgRegTable_rF1 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rF2 :: DynFlags -> Int +oFFSET_StgRegTable_rF2 dflags = pc_OFFSET_StgRegTable_rF2 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rF3 :: DynFlags -> Int +oFFSET_StgRegTable_rF3 dflags = pc_OFFSET_StgRegTable_rF3 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rF4 :: DynFlags -> Int +oFFSET_StgRegTable_rF4 dflags = pc_OFFSET_StgRegTable_rF4 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rF5 :: DynFlags -> Int +oFFSET_StgRegTable_rF5 dflags = pc_OFFSET_StgRegTable_rF5 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rF6 :: DynFlags -> Int +oFFSET_StgRegTable_rF6 dflags = pc_OFFSET_StgRegTable_rF6 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rD1 :: DynFlags -> Int +oFFSET_StgRegTable_rD1 dflags = pc_OFFSET_StgRegTable_rD1 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rD2 :: DynFlags -> Int +oFFSET_StgRegTable_rD2 dflags = pc_OFFSET_StgRegTable_rD2 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rD3 :: DynFlags -> Int +oFFSET_StgRegTable_rD3 dflags = pc_OFFSET_StgRegTable_rD3 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rD4 :: DynFlags -> Int +oFFSET_StgRegTable_rD4 dflags = pc_OFFSET_StgRegTable_rD4 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rD5 :: DynFlags -> Int +oFFSET_StgRegTable_rD5 dflags = pc_OFFSET_StgRegTable_rD5 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rD6 :: DynFlags -> Int +oFFSET_StgRegTable_rD6 dflags = pc_OFFSET_StgRegTable_rD6 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rXMM1 :: DynFlags -> Int +oFFSET_StgRegTable_rXMM1 dflags = pc_OFFSET_StgRegTable_rXMM1 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rXMM2 :: DynFlags -> Int +oFFSET_StgRegTable_rXMM2 dflags = pc_OFFSET_StgRegTable_rXMM2 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rXMM3 :: DynFlags -> Int +oFFSET_StgRegTable_rXMM3 dflags = pc_OFFSET_StgRegTable_rXMM3 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rXMM4 :: DynFlags -> Int +oFFSET_StgRegTable_rXMM4 dflags = pc_OFFSET_StgRegTable_rXMM4 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rXMM5 :: DynFlags -> Int +oFFSET_StgRegTable_rXMM5 dflags = pc_OFFSET_StgRegTable_rXMM5 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rXMM6 :: DynFlags -> Int +oFFSET_StgRegTable_rXMM6 dflags = pc_OFFSET_StgRegTable_rXMM6 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rYMM1 :: DynFlags -> Int +oFFSET_StgRegTable_rYMM1 dflags = pc_OFFSET_StgRegTable_rYMM1 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rYMM2 :: DynFlags -> Int +oFFSET_StgRegTable_rYMM2 dflags = pc_OFFSET_StgRegTable_rYMM2 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rYMM3 :: DynFlags -> Int +oFFSET_StgRegTable_rYMM3 dflags = pc_OFFSET_StgRegTable_rYMM3 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rYMM4 :: DynFlags -> Int +oFFSET_StgRegTable_rYMM4 dflags = pc_OFFSET_StgRegTable_rYMM4 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rYMM5 :: DynFlags -> Int +oFFSET_StgRegTable_rYMM5 dflags = pc_OFFSET_StgRegTable_rYMM5 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rYMM6 :: DynFlags -> Int +oFFSET_StgRegTable_rYMM6 dflags = pc_OFFSET_StgRegTable_rYMM6 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rZMM1 :: DynFlags -> Int +oFFSET_StgRegTable_rZMM1 dflags = pc_OFFSET_StgRegTable_rZMM1 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rZMM2 :: DynFlags -> Int +oFFSET_StgRegTable_rZMM2 dflags = pc_OFFSET_StgRegTable_rZMM2 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rZMM3 :: DynFlags -> Int +oFFSET_StgRegTable_rZMM3 dflags = pc_OFFSET_StgRegTable_rZMM3 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rZMM4 :: DynFlags -> Int +oFFSET_StgRegTable_rZMM4 dflags = pc_OFFSET_StgRegTable_rZMM4 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rZMM5 :: DynFlags -> Int +oFFSET_StgRegTable_rZMM5 dflags = pc_OFFSET_StgRegTable_rZMM5 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rZMM6 :: DynFlags -> Int +oFFSET_StgRegTable_rZMM6 dflags = pc_OFFSET_StgRegTable_rZMM6 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rL1 :: DynFlags -> Int +oFFSET_StgRegTable_rL1 dflags = pc_OFFSET_StgRegTable_rL1 (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rSp :: DynFlags -> Int +oFFSET_StgRegTable_rSp dflags = pc_OFFSET_StgRegTable_rSp (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rSpLim :: DynFlags -> Int +oFFSET_StgRegTable_rSpLim dflags = pc_OFFSET_StgRegTable_rSpLim (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rHp :: DynFlags -> Int +oFFSET_StgRegTable_rHp dflags = pc_OFFSET_StgRegTable_rHp (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rHpLim :: DynFlags -> Int +oFFSET_StgRegTable_rHpLim dflags = pc_OFFSET_StgRegTable_rHpLim (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rCCCS :: DynFlags -> Int +oFFSET_StgRegTable_rCCCS dflags = pc_OFFSET_StgRegTable_rCCCS (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rCurrentTSO :: DynFlags -> Int +oFFSET_StgRegTable_rCurrentTSO dflags = pc_OFFSET_StgRegTable_rCurrentTSO (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rCurrentNursery :: DynFlags -> Int +oFFSET_StgRegTable_rCurrentNursery dflags = pc_OFFSET_StgRegTable_rCurrentNursery (sPlatformConstants (settings dflags)) +oFFSET_StgRegTable_rHpAlloc :: DynFlags -> Int +oFFSET_StgRegTable_rHpAlloc dflags = pc_OFFSET_StgRegTable_rHpAlloc (sPlatformConstants (settings dflags)) +oFFSET_stgEagerBlackholeInfo :: DynFlags -> Int +oFFSET_stgEagerBlackholeInfo dflags = pc_OFFSET_stgEagerBlackholeInfo (sPlatformConstants (settings dflags)) +oFFSET_stgGCEnter1 :: DynFlags -> Int +oFFSET_stgGCEnter1 dflags = pc_OFFSET_stgGCEnter1 (sPlatformConstants (settings dflags)) +oFFSET_stgGCFun :: DynFlags -> Int +oFFSET_stgGCFun dflags = pc_OFFSET_stgGCFun (sPlatformConstants (settings dflags)) +oFFSET_Capability_r :: DynFlags -> Int +oFFSET_Capability_r dflags = pc_OFFSET_Capability_r (sPlatformConstants (settings dflags)) +oFFSET_bdescr_start :: DynFlags -> Int +oFFSET_bdescr_start dflags = pc_OFFSET_bdescr_start (sPlatformConstants (settings dflags)) +oFFSET_bdescr_free :: DynFlags -> Int +oFFSET_bdescr_free dflags = pc_OFFSET_bdescr_free (sPlatformConstants (settings dflags)) +oFFSET_bdescr_blocks :: DynFlags -> Int +oFFSET_bdescr_blocks dflags = pc_OFFSET_bdescr_blocks (sPlatformConstants (settings dflags)) +oFFSET_bdescr_flags :: DynFlags -> Int +oFFSET_bdescr_flags dflags = pc_OFFSET_bdescr_flags (sPlatformConstants (settings dflags)) +sIZEOF_CostCentreStack :: DynFlags -> Int +sIZEOF_CostCentreStack dflags = pc_SIZEOF_CostCentreStack (sPlatformConstants (settings dflags)) +oFFSET_CostCentreStack_mem_alloc :: DynFlags -> Int +oFFSET_CostCentreStack_mem_alloc dflags = pc_OFFSET_CostCentreStack_mem_alloc (sPlatformConstants (settings dflags)) +oFFSET_CostCentreStack_scc_count :: DynFlags -> Int +oFFSET_CostCentreStack_scc_count dflags = pc_OFFSET_CostCentreStack_scc_count (sPlatformConstants (settings dflags)) +oFFSET_StgHeader_ccs :: DynFlags -> Int +oFFSET_StgHeader_ccs dflags = pc_OFFSET_StgHeader_ccs (sPlatformConstants (settings dflags)) +oFFSET_StgHeader_ldvw :: DynFlags -> Int +oFFSET_StgHeader_ldvw dflags = pc_OFFSET_StgHeader_ldvw (sPlatformConstants (settings dflags)) +sIZEOF_StgSMPThunkHeader :: DynFlags -> Int +sIZEOF_StgSMPThunkHeader dflags = pc_SIZEOF_StgSMPThunkHeader (sPlatformConstants (settings dflags)) +oFFSET_StgEntCounter_allocs :: DynFlags -> Int +oFFSET_StgEntCounter_allocs dflags = pc_OFFSET_StgEntCounter_allocs (sPlatformConstants (settings dflags)) +oFFSET_StgEntCounter_allocd :: DynFlags -> Int +oFFSET_StgEntCounter_allocd dflags = pc_OFFSET_StgEntCounter_allocd (sPlatformConstants (settings dflags)) +oFFSET_StgEntCounter_registeredp :: DynFlags -> Int +oFFSET_StgEntCounter_registeredp dflags = pc_OFFSET_StgEntCounter_registeredp (sPlatformConstants (settings dflags)) +oFFSET_StgEntCounter_link :: DynFlags -> Int +oFFSET_StgEntCounter_link dflags = pc_OFFSET_StgEntCounter_link (sPlatformConstants (settings dflags)) +oFFSET_StgEntCounter_entry_count :: DynFlags -> Int +oFFSET_StgEntCounter_entry_count dflags = pc_OFFSET_StgEntCounter_entry_count (sPlatformConstants (settings dflags)) +sIZEOF_StgUpdateFrame_NoHdr :: DynFlags -> Int +sIZEOF_StgUpdateFrame_NoHdr dflags = pc_SIZEOF_StgUpdateFrame_NoHdr (sPlatformConstants (settings dflags)) +sIZEOF_StgMutArrPtrs_NoHdr :: DynFlags -> Int +sIZEOF_StgMutArrPtrs_NoHdr dflags = pc_SIZEOF_StgMutArrPtrs_NoHdr (sPlatformConstants (settings dflags)) +oFFSET_StgMutArrPtrs_ptrs :: DynFlags -> Int +oFFSET_StgMutArrPtrs_ptrs dflags = pc_OFFSET_StgMutArrPtrs_ptrs (sPlatformConstants (settings dflags)) +oFFSET_StgMutArrPtrs_size :: DynFlags -> Int +oFFSET_StgMutArrPtrs_size dflags = pc_OFFSET_StgMutArrPtrs_size (sPlatformConstants (settings dflags)) +sIZEOF_StgSmallMutArrPtrs_NoHdr :: DynFlags -> Int +sIZEOF_StgSmallMutArrPtrs_NoHdr dflags = pc_SIZEOF_StgSmallMutArrPtrs_NoHdr (sPlatformConstants (settings dflags)) +oFFSET_StgSmallMutArrPtrs_ptrs :: DynFlags -> Int +oFFSET_StgSmallMutArrPtrs_ptrs dflags = pc_OFFSET_StgSmallMutArrPtrs_ptrs (sPlatformConstants (settings dflags)) +sIZEOF_StgArrBytes_NoHdr :: DynFlags -> Int +sIZEOF_StgArrBytes_NoHdr dflags = pc_SIZEOF_StgArrBytes_NoHdr (sPlatformConstants (settings dflags)) +oFFSET_StgArrBytes_bytes :: DynFlags -> Int +oFFSET_StgArrBytes_bytes dflags = pc_OFFSET_StgArrBytes_bytes (sPlatformConstants (settings dflags)) +oFFSET_StgTSO_alloc_limit :: DynFlags -> Int +oFFSET_StgTSO_alloc_limit dflags = pc_OFFSET_StgTSO_alloc_limit (sPlatformConstants (settings dflags)) +oFFSET_StgTSO_cccs :: DynFlags -> Int +oFFSET_StgTSO_cccs dflags = pc_OFFSET_StgTSO_cccs (sPlatformConstants (settings dflags)) +oFFSET_StgTSO_stackobj :: DynFlags -> Int +oFFSET_StgTSO_stackobj dflags = pc_OFFSET_StgTSO_stackobj (sPlatformConstants (settings dflags)) +oFFSET_StgStack_sp :: DynFlags -> Int +oFFSET_StgStack_sp dflags = pc_OFFSET_StgStack_sp (sPlatformConstants (settings dflags)) +oFFSET_StgStack_stack :: DynFlags -> Int +oFFSET_StgStack_stack dflags = pc_OFFSET_StgStack_stack (sPlatformConstants (settings dflags)) +oFFSET_StgUpdateFrame_updatee :: DynFlags -> Int +oFFSET_StgUpdateFrame_updatee dflags = pc_OFFSET_StgUpdateFrame_updatee (sPlatformConstants (settings dflags)) +oFFSET_StgFunInfoExtraFwd_arity :: DynFlags -> Int +oFFSET_StgFunInfoExtraFwd_arity dflags = pc_OFFSET_StgFunInfoExtraFwd_arity (sPlatformConstants (settings dflags)) +sIZEOF_StgFunInfoExtraRev :: DynFlags -> Int +sIZEOF_StgFunInfoExtraRev dflags = pc_SIZEOF_StgFunInfoExtraRev (sPlatformConstants (settings dflags)) +oFFSET_StgFunInfoExtraRev_arity :: DynFlags -> Int +oFFSET_StgFunInfoExtraRev_arity dflags = pc_OFFSET_StgFunInfoExtraRev_arity (sPlatformConstants (settings dflags)) +mAX_SPEC_SELECTEE_SIZE :: DynFlags -> Int +mAX_SPEC_SELECTEE_SIZE dflags = pc_MAX_SPEC_SELECTEE_SIZE (sPlatformConstants (settings dflags)) +mAX_SPEC_AP_SIZE :: DynFlags -> Int +mAX_SPEC_AP_SIZE dflags = pc_MAX_SPEC_AP_SIZE (sPlatformConstants (settings dflags)) +mIN_PAYLOAD_SIZE :: DynFlags -> Int +mIN_PAYLOAD_SIZE dflags = pc_MIN_PAYLOAD_SIZE (sPlatformConstants (settings dflags)) +mIN_INTLIKE :: DynFlags -> Int +mIN_INTLIKE dflags = pc_MIN_INTLIKE (sPlatformConstants (settings dflags)) +mAX_INTLIKE :: DynFlags -> Int +mAX_INTLIKE dflags = pc_MAX_INTLIKE (sPlatformConstants (settings dflags)) +mIN_CHARLIKE :: DynFlags -> Int +mIN_CHARLIKE dflags = pc_MIN_CHARLIKE (sPlatformConstants (settings dflags)) +mAX_CHARLIKE :: DynFlags -> Int +mAX_CHARLIKE dflags = pc_MAX_CHARLIKE (sPlatformConstants (settings dflags)) +mUT_ARR_PTRS_CARD_BITS :: DynFlags -> Int +mUT_ARR_PTRS_CARD_BITS dflags = pc_MUT_ARR_PTRS_CARD_BITS (sPlatformConstants (settings dflags)) +mAX_Vanilla_REG :: DynFlags -> Int +mAX_Vanilla_REG dflags = pc_MAX_Vanilla_REG (sPlatformConstants (settings dflags)) +mAX_Float_REG :: DynFlags -> Int +mAX_Float_REG dflags = pc_MAX_Float_REG (sPlatformConstants (settings dflags)) +mAX_Double_REG :: DynFlags -> Int +mAX_Double_REG dflags = pc_MAX_Double_REG (sPlatformConstants (settings dflags)) +mAX_Long_REG :: DynFlags -> Int +mAX_Long_REG dflags = pc_MAX_Long_REG (sPlatformConstants (settings dflags)) +mAX_XMM_REG :: DynFlags -> Int +mAX_XMM_REG dflags = pc_MAX_XMM_REG (sPlatformConstants (settings dflags)) +mAX_Real_Vanilla_REG :: DynFlags -> Int +mAX_Real_Vanilla_REG dflags = pc_MAX_Real_Vanilla_REG (sPlatformConstants (settings dflags)) +mAX_Real_Float_REG :: DynFlags -> Int +mAX_Real_Float_REG dflags = pc_MAX_Real_Float_REG (sPlatformConstants (settings dflags)) +mAX_Real_Double_REG :: DynFlags -> Int +mAX_Real_Double_REG dflags = pc_MAX_Real_Double_REG (sPlatformConstants (settings dflags)) +mAX_Real_XMM_REG :: DynFlags -> Int +mAX_Real_XMM_REG dflags = pc_MAX_Real_XMM_REG (sPlatformConstants (settings dflags)) +mAX_Real_Long_REG :: DynFlags -> Int +mAX_Real_Long_REG dflags = pc_MAX_Real_Long_REG (sPlatformConstants (settings dflags)) +rESERVED_C_STACK_BYTES :: DynFlags -> Int +rESERVED_C_STACK_BYTES dflags = pc_RESERVED_C_STACK_BYTES (sPlatformConstants (settings dflags)) +rESERVED_STACK_WORDS :: DynFlags -> Int +rESERVED_STACK_WORDS dflags = pc_RESERVED_STACK_WORDS (sPlatformConstants (settings dflags)) +aP_STACK_SPLIM :: DynFlags -> Int +aP_STACK_SPLIM dflags = pc_AP_STACK_SPLIM (sPlatformConstants (settings dflags)) +wORD_SIZE :: DynFlags -> Int +wORD_SIZE dflags = pc_WORD_SIZE (sPlatformConstants (settings dflags)) +dOUBLE_SIZE :: DynFlags -> Int +dOUBLE_SIZE dflags = pc_DOUBLE_SIZE (sPlatformConstants (settings dflags)) +cINT_SIZE :: DynFlags -> Int +cINT_SIZE dflags = pc_CINT_SIZE (sPlatformConstants (settings dflags)) +cLONG_SIZE :: DynFlags -> Int +cLONG_SIZE dflags = pc_CLONG_SIZE (sPlatformConstants (settings dflags)) +cLONG_LONG_SIZE :: DynFlags -> Int +cLONG_LONG_SIZE dflags = pc_CLONG_LONG_SIZE (sPlatformConstants (settings dflags)) +bITMAP_BITS_SHIFT :: DynFlags -> Int +bITMAP_BITS_SHIFT dflags = pc_BITMAP_BITS_SHIFT (sPlatformConstants (settings dflags)) +tAG_BITS :: DynFlags -> Int +tAG_BITS dflags = pc_TAG_BITS (sPlatformConstants (settings dflags)) +wORDS_BIGENDIAN :: DynFlags -> Bool +wORDS_BIGENDIAN dflags = pc_WORDS_BIGENDIAN (sPlatformConstants (settings dflags)) +dYNAMIC_BY_DEFAULT :: DynFlags -> Bool +dYNAMIC_BY_DEFAULT dflags = pc_DYNAMIC_BY_DEFAULT (sPlatformConstants (settings dflags)) +lDV_SHIFT :: DynFlags -> Int +lDV_SHIFT dflags = pc_LDV_SHIFT (sPlatformConstants (settings dflags)) +iLDV_CREATE_MASK :: DynFlags -> Integer +iLDV_CREATE_MASK dflags = pc_ILDV_CREATE_MASK (sPlatformConstants (settings dflags)) +iLDV_STATE_CREATE :: DynFlags -> Integer +iLDV_STATE_CREATE dflags = pc_ILDV_STATE_CREATE (sPlatformConstants (settings dflags)) +iLDV_STATE_USE :: DynFlags -> Integer +iLDV_STATE_USE dflags = pc_ILDV_STATE_USE (sPlatformConstants (settings dflags)) diff --git a/ghc-lib/generated/ghcautoconf.h b/ghc-lib/generated/ghcautoconf.h new file mode 100644 --- /dev/null +++ b/ghc-lib/generated/ghcautoconf.h @@ -0,0 +1,542 @@ +#ifndef __GHCAUTOCONF_H__ +#define __GHCAUTOCONF_H__ +/* mk/config.h. Generated from config.h.in by configure. */ +/* mk/config.h.in. Generated from configure.ac by autoheader. */ + +/* Define if building universal (internal helper macro) */ +/* #undef AC_APPLE_UNIVERSAL_BUILD */ + +/* The alignment of a `char'. */ +#define ALIGNMENT_CHAR 1 + +/* The alignment of a `double'. */ +#define ALIGNMENT_DOUBLE 8 + +/* The alignment of a `float'. */ +#define ALIGNMENT_FLOAT 4 + +/* The alignment of a `int'. */ +#define ALIGNMENT_INT 4 + +/* The alignment of a `int16_t'. */ +#define ALIGNMENT_INT16_T 2 + +/* The alignment of a `int32_t'. */ +#define ALIGNMENT_INT32_T 4 + +/* The alignment of a `int64_t'. */ +#define ALIGNMENT_INT64_T 8 + +/* The alignment of a `int8_t'. */ +#define ALIGNMENT_INT8_T 1 + +/* The alignment of a `long'. */ +#define ALIGNMENT_LONG 8 + +/* The alignment of a `long long'. */ +#define ALIGNMENT_LONG_LONG 8 + +/* The alignment of a `short'. */ +#define ALIGNMENT_SHORT 2 + +/* The alignment of a `uint16_t'. */ +#define ALIGNMENT_UINT16_T 2 + +/* The alignment of a `uint32_t'. */ +#define ALIGNMENT_UINT32_T 4 + +/* The alignment of a `uint64_t'. */ +#define ALIGNMENT_UINT64_T 8 + +/* The alignment of a `uint8_t'. */ +#define ALIGNMENT_UINT8_T 1 + +/* The alignment of a `unsigned char'. */ +#define ALIGNMENT_UNSIGNED_CHAR 1 + +/* The alignment of a `unsigned int'. */ +#define ALIGNMENT_UNSIGNED_INT 4 + +/* The alignment of a `unsigned long'. */ +#define ALIGNMENT_UNSIGNED_LONG 8 + +/* The alignment of a `unsigned long long'. */ +#define ALIGNMENT_UNSIGNED_LONG_LONG 8 + +/* The alignment of a `unsigned short'. */ +#define ALIGNMENT_UNSIGNED_SHORT 2 + +/* The alignment of a `void *'. */ +#define ALIGNMENT_VOID_P 8 + +/* Define to 1 if __thread is supported */ +#define CC_SUPPORTS_TLS 1 + +/* Define to one of `_getb67', `GETB67', `getb67' for Cray-2 and Cray-YMP + systems. This function is required for `alloca.c' support on those systems. + */ +/* #undef CRAY_STACKSEG_END */ + +/* Define to 1 if using `alloca.c'. */ +/* #undef C_ALLOCA */ + +/* Define to 1 if your processor stores words of floats with the most + significant byte first */ +/* #undef FLOAT_WORDS_BIGENDIAN */ + +/* Has visibility hidden */ +#define HAS_VISIBILITY_HIDDEN 1 + +/* Define to 1 if you have `alloca', as a function or macro. */ +#define HAVE_ALLOCA 1 + +/* Define to 1 if you have and it should be used (not on Ultrix). + */ +#define HAVE_ALLOCA_H 1 + +/* Define to 1 if you have the header file. */ +/* #undef HAVE_BFD_H */ + +/* Does GCC support __atomic primitives? */ +#define HAVE_C11_ATOMICS $CONF_GCC_SUPPORTS__ATOMICS + +/* Define to 1 if you have the `clock_gettime' function. */ +#define HAVE_CLOCK_GETTIME 1 + +/* Define to 1 if you have the `ctime_r' function. */ +#define HAVE_CTIME_R 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_CTYPE_H 1 + +/* Define to 1 if you have the declaration of `ctime_r', and to 0 if you + don't. */ +#define HAVE_DECL_CTIME_R 1 + +/* Define to 1 if you have the declaration of `MADV_DONTNEED', and to 0 if you + don't. */ +/* #undef HAVE_DECL_MADV_DONTNEED */ + +/* Define to 1 if you have the declaration of `MADV_FREE', and to 0 if you + don't. */ +/* #undef HAVE_DECL_MADV_FREE */ + +/* Define to 1 if you have the declaration of `MAP_NORESERVE', and to 0 if you + don't. */ +/* #undef HAVE_DECL_MAP_NORESERVE */ + +/* Define to 1 if you have the header file. */ +#define HAVE_DIRENT_H 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_DLFCN_H 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_ERRNO_H 1 + +/* Define to 1 if you have the `eventfd' function. */ +/* #undef HAVE_EVENTFD */ + +/* Define to 1 if you have the header file. */ +#define HAVE_FCNTL_H 1 + +/* Define to 1 if you have the header file. */ +/* #undef HAVE_FFI_H */ + +/* Define to 1 if you have the `fork' function. */ +#define HAVE_FORK 1 + +/* Define to 1 if you have the `getclock' function. */ +/* #undef HAVE_GETCLOCK */ + +/* Define to 1 if you have the `GetModuleFileName' function. */ +/* #undef HAVE_GETMODULEFILENAME */ + +/* Define to 1 if you have the `getrusage' function. */ +#define HAVE_GETRUSAGE 1 + +/* Define to 1 if you have the `gettimeofday' function. */ +#define HAVE_GETTIMEOFDAY 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_GRP_H 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_INTTYPES_H 1 + +/* Define to 1 if you have the `bfd' library (-lbfd). */ +/* #undef HAVE_LIBBFD */ + +/* Define to 1 if you have the `dl' library (-ldl). */ +#define HAVE_LIBDL 1 + +/* Define to 1 if you have libffi. */ +/* #undef HAVE_LIBFFI */ + +/* Define to 1 if you have the `iberty' library (-liberty). */ +/* #undef HAVE_LIBIBERTY */ + +/* Define to 1 if you need to link with libm */ +#define HAVE_LIBM 1 + +/* Define to 1 if you have libnuma */ +#define HAVE_LIBNUMA 0 + +/* Define to 1 if you have the `pthread' library (-lpthread). */ +#define HAVE_LIBPTHREAD 1 + +/* Define to 1 if you have the `rt' library (-lrt). */ +/* #undef HAVE_LIBRT */ + +/* Define to 1 if you have the header file. */ +#define HAVE_LIMITS_H 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_LOCALE_H 1 + +/* Define to 1 if the system has the type `long long'. */ +#define HAVE_LONG_LONG 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_MEMORY_H 1 + +/* Define to 1 if you have the mingwex library. */ +/* #undef HAVE_MINGWEX */ + +/* Define to 1 if you have the header file. */ +#define HAVE_NLIST_H 1 + +/* Define to 1 if you have the header file. */ +/* #undef HAVE_NUMAIF_H */ + +/* Define to 1 if you have the header file. */ +/* #undef HAVE_NUMA_H */ + +/* Define to 1 if we have printf$LDBLStub (Apple Mac OS >= 10.4, PPC). */ +#define HAVE_PRINTF_LDBLSTUB 0 + +/* Define to 1 if you have the header file. */ +#define HAVE_PTHREAD_H 1 + +/* Define to 1 if you have the glibc version of pthread_setname_np */ +/* #undef HAVE_PTHREAD_SETNAME_NP */ + +/* Define to 1 if you have the header file. */ +#define HAVE_PWD_H 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_SCHED_H 1 + +/* Define to 1 if you have the `sched_setaffinity' function. */ +/* #undef HAVE_SCHED_SETAFFINITY */ + +/* Define to 1 if you have the `setitimer' function. */ +#define HAVE_SETITIMER 1 + +/* Define to 1 if you have the `setlocale' function. */ +#define HAVE_SETLOCALE 1 + +/* Define to 1 if you have the `siginterrupt' function. */ +#define HAVE_SIGINTERRUPT 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_SIGNAL_H 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_STDINT_H 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_STDLIB_H 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_STRINGS_H 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_STRING_H 1 + +/* Define to 1 if Apple-style dead-stripping is supported. */ +#define HAVE_SUBSECTIONS_VIA_SYMBOLS 1 + +/* Define to 1 if you have the `sysconf' function. */ +#define HAVE_SYSCONF 1 + +/* Define to 1 if you have the header file. */ +/* #undef HAVE_SYS_CPUSET_H */ + +/* Define to 1 if you have the header file. */ +/* #undef HAVE_SYS_EVENTFD_H */ + +/* Define to 1 if you have the header file. */ +#define HAVE_SYS_MMAN_H 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_SYS_PARAM_H 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_SYS_RESOURCE_H 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_SYS_SELECT_H 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_SYS_STAT_H 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_SYS_TIMEB_H 1 + +/* Define to 1 if you have the header file. */ +/* #undef HAVE_SYS_TIMERFD_H */ + +/* Define to 1 if you have the header file. */ +/* #undef HAVE_SYS_TIMERS_H */ + +/* Define to 1 if you have the header file. */ +#define HAVE_SYS_TIMES_H 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_SYS_TIME_H 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_SYS_TYPES_H 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_SYS_UTSNAME_H 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_SYS_WAIT_H 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_TERMIOS_H 1 + +/* Define to 1 if you have the `timer_settime' function. */ +/* #undef HAVE_TIMER_SETTIME */ + +/* Define to 1 if you have the `times' function. */ +#define HAVE_TIMES 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_TIME_H 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_UNISTD_H 1 + +/* Define to 1 if you have the header file. */ +#define HAVE_UTIME_H 1 + +/* Define to 1 if you have the `vfork' function. */ +#define HAVE_VFORK 1 + +/* Define to 1 if you have the header file. */ +/* #undef HAVE_VFORK_H */ + +/* Define to 1 if you have the header file. */ +/* #undef HAVE_WINDOWS_H */ + +/* Define to 1 if you have the `WinExec' function. */ +/* #undef HAVE_WINEXEC */ + +/* Define to 1 if you have the header file. */ +/* #undef HAVE_WINSOCK_H */ + +/* Define to 1 if `fork' works. */ +#define HAVE_WORKING_FORK 1 + +/* Define to 1 if `vfork' works. */ +#define HAVE_WORKING_VFORK 1 + +/* Define to 1 if C symbols have a leading underscore added by the compiler. + */ +#define LEADING_UNDERSCORE 1 + +/* Define 1 if we need to link code using pthreads with -lpthread */ +#define NEED_PTHREAD_LIB 0 + +/* Define to the address where bug reports for this package should be sent. */ +/* #undef PACKAGE_BUGREPORT */ + +/* Define to the full name of this package. */ +/* #undef PACKAGE_NAME */ + +/* Define to the full name and version of this package. */ +/* #undef PACKAGE_STRING */ + +/* Define to the one symbol short name of this package. */ +/* #undef PACKAGE_TARNAME */ + +/* Define to the home page for this package. */ +/* #undef PACKAGE_URL */ + +/* Define to the version of this package. */ +/* #undef PACKAGE_VERSION */ + +/* Use mmap in the runtime linker */ +#define RTS_LINKER_USE_MMAP 1 + +/* The size of `char', as computed by sizeof. */ +#define SIZEOF_CHAR 1 + +/* The size of `double', as computed by sizeof. */ +#define SIZEOF_DOUBLE 8 + +/* The size of `float', as computed by sizeof. */ +#define SIZEOF_FLOAT 4 + +/* The size of `int', as computed by sizeof. */ +#define SIZEOF_INT 4 + +/* The size of `int16_t', as computed by sizeof. */ +#define SIZEOF_INT16_T 2 + +/* The size of `int32_t', as computed by sizeof. */ +#define SIZEOF_INT32_T 4 + +/* The size of `int64_t', as computed by sizeof. */ +#define SIZEOF_INT64_T 8 + +/* The size of `int8_t', as computed by sizeof. */ +#define SIZEOF_INT8_T 1 + +/* The size of `long', as computed by sizeof. */ +#define SIZEOF_LONG 8 + +/* The size of `long long', as computed by sizeof. */ +#define SIZEOF_LONG_LONG 8 + +/* The size of `short', as computed by sizeof. */ +#define SIZEOF_SHORT 2 + +/* The size of `uint16_t', as computed by sizeof. */ +#define SIZEOF_UINT16_T 2 + +/* The size of `uint32_t', as computed by sizeof. */ +#define SIZEOF_UINT32_T 4 + +/* The size of `uint64_t', as computed by sizeof. */ +#define SIZEOF_UINT64_T 8 + +/* The size of `uint8_t', as computed by sizeof. */ +#define SIZEOF_UINT8_T 1 + +/* The size of `unsigned char', as computed by sizeof. */ +#define SIZEOF_UNSIGNED_CHAR 1 + +/* The size of `unsigned int', as computed by sizeof. */ +#define SIZEOF_UNSIGNED_INT 4 + +/* The size of `unsigned long', as computed by sizeof. */ +#define SIZEOF_UNSIGNED_LONG 8 + +/* The size of `unsigned long long', as computed by sizeof. */ +#define SIZEOF_UNSIGNED_LONG_LONG 8 + +/* The size of `unsigned short', as computed by sizeof. */ +#define SIZEOF_UNSIGNED_SHORT 2 + +/* The size of `void *', as computed by sizeof. */ +#define SIZEOF_VOID_P 8 + +/* If using the C implementation of alloca, define if you know the + direction of stack growth for your system; otherwise it will be + automatically deduced at runtime. + STACK_DIRECTION > 0 => grows toward higher addresses + STACK_DIRECTION < 0 => grows toward lower addresses + STACK_DIRECTION = 0 => direction of growth unknown */ +/* #undef STACK_DIRECTION */ + +/* Define to 1 if you have the ANSI C header files. */ +#define STDC_HEADERS 1 + +/* Define to 1 if you can safely include both and . */ +#define TIME_WITH_SYS_TIME 1 + +/* Enable single heap address space support */ +#define USE_LARGE_ADDRESS_SPACE 1 + +/* Set to 1 to use libdw */ +#define USE_LIBDW 0 + +/* Enable extensions on AIX 3, Interix. */ +#ifndef _ALL_SOURCE +# define _ALL_SOURCE 1 +#endif +/* Enable GNU extensions on systems that have them. */ +#ifndef _GNU_SOURCE +# define _GNU_SOURCE 1 +#endif +/* Enable threading extensions on Solaris. */ +#ifndef _POSIX_PTHREAD_SEMANTICS +# define _POSIX_PTHREAD_SEMANTICS 1 +#endif +/* Enable extensions on HP NonStop. */ +#ifndef _TANDEM_SOURCE +# define _TANDEM_SOURCE 1 +#endif +/* Enable general extensions on Solaris. */ +#ifndef __EXTENSIONS__ +# define __EXTENSIONS__ 1 +#endif + + +/* Define to 1 if we can use timer_create(CLOCK_REALTIME,...) */ +/* #undef USE_TIMER_CREATE */ + +/* Define WORDS_BIGENDIAN to 1 if your processor stores words with the most + significant byte first (like Motorola and SPARC, unlike Intel). */ +#if defined AC_APPLE_UNIVERSAL_BUILD +# if defined __BIG_ENDIAN__ +# define WORDS_BIGENDIAN 1 +# endif +#else +# ifndef WORDS_BIGENDIAN +/* # undef WORDS_BIGENDIAN */ +# endif +#endif + +/* Enable large inode numbers on Mac OS X 10.5. */ +#ifndef _DARWIN_USE_64_BIT_INODE +# define _DARWIN_USE_64_BIT_INODE 1 +#endif + +/* Number of bits in a file offset, on hosts where this is settable. */ +/* #undef _FILE_OFFSET_BITS */ + +/* Define for large files, on AIX-style hosts. */ +/* #undef _LARGE_FILES */ + +/* Define to 1 if on MINIX. */ +/* #undef _MINIX */ + +/* Define to 2 if the system does not provide POSIX.1 features except with + this defined. */ +/* #undef _POSIX_1_SOURCE */ + +/* Define to 1 if you need to in order for `stat' and other things to work. */ +/* #undef _POSIX_SOURCE */ + +/* ARM pre v6 */ +/* #undef arm_HOST_ARCH_PRE_ARMv6 */ + +/* ARM pre v7 */ +/* #undef arm_HOST_ARCH_PRE_ARMv7 */ + +/* Define to empty if `const' does not conform to ANSI C. */ +/* #undef const */ + +/* Define to `int' if does not define. */ +/* #undef pid_t */ + +/* The supported LLVM version number */ +#define sUPPORTED_LLVM_VERSION (7,0) + +/* Define to `unsigned int' if does not define. */ +/* #undef size_t */ + +/* Define as `fork' if `vfork' does not work. */ +/* #undef vfork */ + +#define TABLES_NEXT_TO_CODE 1 + +#define llvm_CC_FLAVOR 1 + +#define clang_CC_FLAVOR 1 +#endif /* __GHCAUTOCONF_H__ */ diff --git a/ghc-lib/generated/ghcplatform.h b/ghc-lib/generated/ghcplatform.h new file mode 100644 --- /dev/null +++ b/ghc-lib/generated/ghcplatform.h @@ -0,0 +1,34 @@ +#ifndef __GHCPLATFORM_H__ +#define __GHCPLATFORM_H__ + +#define BuildPlatform_TYPE x86_64_apple_darwin +#define HostPlatform_TYPE 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" + +/* These TARGET macros are for backwards compatibility... DO NOT USE! */ +#define TargetPlatform_TYPE x86_64_apple_darwin +#define x86_64_apple_darwin_TARGET 1 +#define x86_64_TARGET_ARCH 1 +#define TARGET_ARCH "x86_64" +#define darwin_TARGET_OS 1 +#define TARGET_OS "darwin" +#define apple_TARGET_VENDOR 1 + +#endif /* __GHCPLATFORM_H__ */ diff --git a/ghc-lib/generated/ghcversion.h b/ghc-lib/generated/ghcversion.h new file mode 100644 --- /dev/null +++ b/ghc-lib/generated/ghcversion.h @@ -0,0 +1,18 @@ +#ifndef __GHCVERSION_H__ +#define __GHCVERSION_H__ + +#ifndef __GLASGOW_HASKELL__ +# define __GLASGOW_HASKELL__ 809 +#endif + +#define __GLASGOW_HASKELL_PATCHLEVEL1__ 20190402 + +#define MIN_VERSION_GLASGOW_HASKELL(ma,mi,pl1,pl2) (\ + ((ma)*100+(mi)) < __GLASGOW_HASKELL__ || \ + ((ma)*100+(mi)) == __GLASGOW_HASKELL__ \ + && (pl1) < __GLASGOW_HASKELL_PATCHLEVEL1__ || \ + ((ma)*100+(mi)) == __GLASGOW_HASKELL__ \ + && (pl1) == __GLASGOW_HASKELL_PATCHLEVEL1__ \ + && (pl2) <= __GLASGOW_HASKELL_PATCHLEVEL2__ ) + +#endif /* __GHCVERSION_H__ */ diff --git a/ghc-lib/stage0/compiler/build/Lexer.hs b/ghc-lib/stage0/compiler/build/Lexer.hs new file mode 100644 --- /dev/null +++ b/ghc-lib/stage0/compiler/build/Lexer.hs @@ -0,0 +1,3465 @@ +{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} +{-# LANGUAGE CPP,MagicHash #-} +{-# LINE 43 "compiler/parser/Lexer.x" #-} + +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} + +{-# OPTIONS_GHC -funbox-strict-fields #-} + +module Lexer ( + Token(..), lexer, pragState, mkPState, mkPStatePure, PState(..), + P(..), ParseResult(..), mkParserFlags, mkParserFlags', ParserFlags, + getRealSrcLoc, getPState, withThisPackage, + failLocMsgP, srcParseFail, + getErrorMessages, getMessages, + popContext, pushModuleContext, setLastToken, setSrcLoc, + activeContext, nextIsEOF, + getLexState, popLexState, pushLexState, + ExtBits(..), getBit, + addWarning, addError, addFatalError, + lexTokenStream, + addAnnotation,AddAnn,addAnnsAt,mkParensApiAnn, + commentToAnnotation + ) where + +import GhcPrelude + +-- base +import Control.Monad +import Control.Monad.Fail as MonadFail +import Data.Bits +import Data.Char +import Data.List +import Data.Maybe +import Data.Word + +import EnumSet (EnumSet) +import qualified EnumSet + +-- ghc-boot +import qualified GHC.LanguageExtensions as LangExt + +-- bytestring +import Data.ByteString (ByteString) + +-- containers +import Data.Map (Map) +import qualified Data.Map as Map + +-- compiler/utils +import Bag +import Outputable +import StringBuffer +import FastString +import UniqFM +import Util ( readRational, readHexRational ) + +-- compiler/main +import ErrUtils +import DynFlags + +-- compiler/basicTypes +import SrcLoc +import Module +import BasicTypes ( InlineSpec(..), RuleMatchInfo(..), + IntegralLit(..), FractionalLit(..), + SourceText(..) ) + +-- compiler/parser +import Ctype + +import ApiAnnotation + +#if __GLASGOW_HASKELL__ >= 603 +#include "ghcconfig.h" +#elif defined(__GLASGOW_HASKELL__) +#include "config.h" +#endif +#if __GLASGOW_HASKELL__ >= 503 +import Data.Array +import Data.Array.Base (unsafeAt) +#else +import Array +#endif +#if __GLASGOW_HASKELL__ >= 503 +import GHC.Exts +#else +import GlaExts +#endif +alex_tab_size :: Int +alex_tab_size = 8 +alex_base :: AlexAddr +alex_base = AlexA# + "\x01\x00\x00\x00\x7b\x00\x00\x00\x84\x00\x00\x00\xa0\x00\x00\x00\xbc\x00\x00\x00\xc5\x00\x00\x00\xce\x00\x00\x00\xec\x00\x00\x00\x06\x01\x00\x00\x22\x01\x00\x00\x3f\x01\x00\x00\x7b\x01\x00\x00\xd4\xff\xff\xff\x61\x00\x00\x00\xd7\xff\xff\xff\xdb\xff\xff\xff\xa4\xff\xff\xff\xaa\xff\xff\xff\xf8\x01\x00\x00\x72\x02\x00\x00\xec\x02\x00\x00\x93\xff\xff\xff\x94\xff\xff\xff\x66\x03\x00\x00\x95\xff\xff\xff\xb2\xff\xff\xff\xe7\xff\xff\xff\xe8\xff\xff\xff\xe9\xff\xff\xff\xd1\x00\x00\x00\xae\xff\xff\xff\xab\xff\xff\xff\xb0\xff\xff\xff\x59\x01\x00\x00\xdc\x03\x00\x00\xfc\x01\x00\x00\xe6\x03\x00\x00\xb3\xff\xff\xff\xba\xff\xff\xff\xac\xff\xff\xff\x3d\x01\x00\x00\x7a\x01\x00\x00\x50\x02\x00\x00\xca\x02\x00\x00\x1f\x04\x00\x00\xfa\x03\x00\x00\x59\x04\x00\x00\x95\x01\x00\x00\x05\x02\x00\x00\xaf\xff\xff\xff\xb1\xff\xff\xff\xa4\x04\x00\x00\xe5\x04\x00\x00\x63\x02\x00\x00\x44\x03\x00\x00\xdd\x02\x00\x00\xfc\x04\x00\x00\x3d\x05\x00\x00\x57\x03\x00\x00\xc5\x04\x00\x00\x1d\x05\x00\x00\x59\x05\x00\x00\x63\x05\x00\x00\x79\x05\x00\x00\x83\x05\x00\x00\x99\x05\x00\x00\xa9\x05\x00\x00\xb3\x05\x00\x00\xbd\x05\x00\x00\xc9\x05\x00\x00\xd3\x05\x00\x00\xed\x05\x00\x00\x04\x06\x00\x00\x63\x00\x00\x00\x51\x00\x00\x00\x26\x06\x00\x00\x4b\x06\x00\x00\x62\x06\x00\x00\xc4\x03\x00\x00\x6c\x00\x00\x00\x84\x06\x00\x00\xbd\x06\x00\x00\x17\x07\x00\x00\x95\x07\x00\x00\x11\x08\x00\x00\x8d\x08\x00\x00\x09\x09\x00\x00\x85\x09\x00\x00\x01\x0a\x00\x00\xb9\x00\x00\x00\x7d\x0a\x00\x00\xfb\x0a\x00\x00\x12\x00\x00\x00\x16\x00\x00\x00\x2d\x01\x00\x00\x5e\x01\x00\x00\x00\x00\x00\x00\x79\x00\x00\x00\xfa\x01\x00\x00\xe0\x03\x00\x00\x67\x00\x00\x00\x9c\x00\x00\x00\x81\x00\x00\x00\x82\x00\x00\x00\x88\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x00\x00\x76\x0b\x00\x00\x9e\x0b\x00\x00\xe1\x0b\x00\x00\x09\x0c\x00\x00\x4c\x0c\x00\x00\x74\x0c\x00\x00\xb7\x0c\x00\x00\xe7\x04\x00\x00\x94\x07\x00\x00\x10\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf7\x0c\x00\x00\x71\x0d\x00\x00\xeb\x0d\x00\x00\x65\x0e\x00\x00\xdf\x0e\x00\x00\xa8\x00\x00\x00\xa9\x00\x00\x00\x5d\x0f\x00\x00\x9d\x00\x00\x00\xd7\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x10\x00\x00\x00\x00\x00\x00\xcf\x10\x00\x00\x49\x11\x00\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x11\x00\x00\x3d\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\x12\x00\x00\x51\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8b\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x07\x14\x00\x00\x81\x14\x00\x00\xfb\x14\x00\x00\x75\x15\x00\x00\xef\x15\x00\x00\x69\x16\x00\x00\xe3\x16\x00\x00\x5d\x17\x00\x00\xd7\x17\x00\x00\x51\x18\x00\x00\xcb\x18\x00\x00\x45\x19\x00\x00\xbf\x19\x00\x00\x39\x1a\x00\x00\xa1\x00\x00\x00\xbd\x00\x00\x00\xbe\x00\x00\x00\xbf\x00\x00\x00\xc1\x00\x00\x00\xc3\x00\x00\x00\x93\x1a\x00\x00\xb6\x1a\x00\x00\x12\x1b\x00\x00\x3a\x1b\x00\x00\x5d\x1b\x00\x00\x85\x1b\x00\x00\xc8\x1b\x00\x00\xed\x1b\x00\x00\x66\x1c\x00\x00\xdf\x1c\x00\x00\x58\x1d\x00\x00\xb4\x1d\x00\x00\x58\x0b\x00\x00\xc7\x1d\x00\x00\xdd\x00\x00\x00\xbb\x06\x00\x00\x10\x1e\x00\x00\xc9\x1a\x00\x00\x35\x1e\x00\x00\x20\x01\x00\x00\x71\x07\x00\x00\x7e\x1e\x00\x00\x49\x1c\x00\x00\xf2\x07\x00\x00\xc3\x1c\x00\x00\x6e\x08\x00\x00\xbf\x1e\x00\x00\xe4\x08\x00\x00\x00\x1f\x00\x00\x60\x09\x00\x00\xc4\x00\x00\x00\xc7\x00\x00\x00\xc8\x00\x00\x00\xc9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xca\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +alex_table :: AlexAddr +alex_table = AlexA# + "\x00\x00\x64\x00\xc1\x00\xba\x00\x6d\x00\xcf\x00\x5e\x00\xa1\x00\x6e\x00\x77\x00\x60\x00\x80\x00\x5e\x00\x5e\x00\x5e\x00\x7d\x00\x8b\x00\x8c\x00\x8e\x00\x5d\x00\x15\x00\x16\x00\x18\x00\x32\x00\x19\x00\x31\x00\x1f\x00\x25\x00\x7a\x00\x11\x00\x26\x00\x10\x00\x79\x00\x5e\x00\xcf\x00\xf6\x00\xd0\x00\xd3\x00\xcf\x00\xcf\x00\xf5\x00\xaa\x00\xab\x00\xcf\x00\xcf\x00\xaf\x00\xcb\x00\xcf\x00\xcf\x00\xd6\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd4\x00\xb0\x00\xcf\x00\xcf\x00\xcf\x00\xd1\x00\xa2\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xad\x00\xcf\x00\xae\x00\xcf\x00\xbb\x00\xb1\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xb3\x00\xcd\x00\xb4\x00\xcf\x00\x5e\x00\xdc\x00\xdc\x00\xff\xff\x60\x00\x76\x00\x5e\x00\x5e\x00\x5e\x00\x5e\x00\x12\x00\xff\xff\xff\xff\x60\x00\x6e\x00\x5e\x00\x5e\x00\x5e\x00\xff\xff\xdd\x00\xdd\x00\xdd\x00\xdd\x00\xdd\x00\xdd\x00\xdd\x00\xdd\x00\x5e\x00\xd7\x00\xd7\x00\x78\x00\xff\xff\xff\xff\xff\xff\x64\x00\x20\x00\x5e\x00\x5e\x00\xff\xff\xff\xff\x0f\x00\x60\x00\x7c\x00\x5e\x00\x5e\x00\x5e\x00\x93\x00\x5c\x00\x4a\x00\x0f\x00\xff\xff\xff\xff\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x95\x00\x88\x00\x5e\x00\x5e\x00\x49\x00\x7e\x00\xc3\x00\x60\x00\x7c\x00\x5e\x00\x5e\x00\x5e\x00\x5e\x00\x4f\x00\x62\x00\x0f\x00\x60\x00\x7c\x00\x5e\x00\x5e\x00\x5e\x00\x5e\x00\x63\x00\x65\x00\x70\x00\x60\x00\xa7\x00\x5e\x00\x5e\x00\x5e\x00\x5e\x00\x91\x00\x8b\x00\x7e\x00\xc4\x00\xc5\x00\xc7\x00\x91\x00\xc5\x00\x5e\x00\xc8\x00\xef\x00\x7e\x00\x0f\x00\xf0\x00\xf1\x00\xf2\x00\xf4\x00\x5e\x00\x00\x00\x00\x00\x5e\x00\x0f\x00\x00\x00\x00\x00\x60\x00\x0c\x00\x5e\x00\x5e\x00\x5e\x00\x1e\x00\x0f\x00\x00\x00\x00\x00\x27\x00\x0c\x00\xe8\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x5f\x00\x5e\x00\xd7\x00\xd7\x00\x61\x00\xff\xff\x5f\x00\x5f\x00\x5f\x00\x00\x00\x00\x00\x3d\x00\x91\x00\x00\x00\x0f\x00\x00\x00\x7b\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x5f\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x60\x00\x00\x00\x5e\x00\x5e\x00\x5e\x00\x1d\x00\xa3\x00\x5e\x00\x87\x00\x00\x00\x91\x00\x3d\x00\x7b\x00\x5e\x00\x5e\x00\x5e\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x7b\x00\x7f\x00\x5e\x00\xec\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x60\x00\x0c\x00\x5e\x00\x5e\x00\x5e\x00\x5e\x00\x00\x00\x0f\x00\xdc\x00\xdc\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x00\x00\x00\x00\x30\x00\x5e\x00\x00\x00\x00\x00\x1a\x00\x5f\x00\x30\x00\x30\x00\x30\x00\x0c\x00\xff\xff\x5f\x00\x5f\x00\x5f\x00\x0d\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x00\x00\x00\x00\x30\x00\x00\x00\x00\x00\xc2\x00\xc0\x00\x5f\x00\x4a\x00\x5e\x00\x86\x00\x00\x00\x00\x00\x60\x00\x80\x00\x5e\x00\x5e\x00\x5e\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2f\x00\x5e\x00\x28\x00\x0c\x00\x1c\x00\x00\x00\x2f\x00\x2f\x00\x2f\x00\xa9\x00\xab\x00\x00\x00\x00\x00\xaf\x00\x0e\x00\x00\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x00\x00\x2f\x00\xb0\x00\x5a\x00\x2a\x00\x00\x00\x0c\x00\x00\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xac\x00\x00\x00\xae\x00\x29\x00\xc0\x00\xb1\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xb2\x00\x00\x00\xb4\x00\x81\x00\x81\x00\x81\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x23\x00\x12\x00\x12\x00\x12\x00\x12\x00\x23\x00\x23\x00\x23\x00\x23\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x30\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x59\x00\x00\x00\x23\x00\x8f\x00\x91\x00\x1b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x00\x30\x00\x00\x00\x5b\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x91\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x83\x00\x83\x00\x83\x00\x91\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x13\x00\x13\x00\x13\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x21\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x00\x00\x37\x00\x00\x00\x13\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x00\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x84\x00\x84\x00\x84\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x14\x00\x14\x00\x14\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x8d\x00\x8d\x00\x8d\x00\x00\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x17\x00\x17\x00\x17\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x3c\x00\x00\x00\x17\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x00\x00\x00\x00\x00\x00\x36\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x00\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2f\x00\x2f\x00\x2f\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x23\x00\x23\x00\x23\x00\x23\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x00\x00\x90\x00\x91\x00\x00\x00\x23\x00\x00\x00\x00\x00\x1b\x00\x91\x00\x00\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x22\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x24\x00\x2c\x00\x2c\x00\x2c\x00\x4e\x00\x00\x00\x00\x00\x2c\x00\x00\x00\x41\x00\x00\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x29\x00\x00\x00\x00\x00\x91\x00\x3d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\x00\x2c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x1d\x00\x2c\x00\x53\x00\x91\x00\x00\x00\x00\x00\x3d\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x00\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x00\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x35\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x33\x00\x00\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x00\x00\x00\x00\x00\x35\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x00\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\x00\x00\x00\x00\x6a\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\x3a\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\x40\x00\x00\x00\x40\x00\x00\x00\x00\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\x00\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\x00\x00\x45\x00\x00\x00\x45\x00\x00\x00\x3f\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xdf\x00\xdf\x00\xdf\x00\xdf\x00\xdf\x00\xdf\x00\xdf\x00\xdf\x00\xdf\x00\xdf\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\x00\x00\x42\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xdf\x00\xdf\x00\xdf\x00\xdf\x00\xdf\x00\xdf\x00\xdf\x00\xdf\x00\xdf\x00\xdf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x44\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\x00\x00\x47\x00\x00\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\x35\x00\x00\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\x00\x00\x00\x00\x00\x00\x48\x00\x00\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\x3d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\x00\x00\x4c\x00\x00\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\x3a\x00\x00\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xb8\x00\xb6\x00\x00\x00\x4d\x00\x00\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\xd8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb7\x00\xb5\x00\x4e\x00\xc9\x00\xb6\x00\x00\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xc9\x00\x00\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\x00\x00\x00\x00\x00\x00\xc9\x00\xc9\x00\x00\x00\xc9\x00\xc9\x00\xc9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xca\x00\x00\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\x00\x00\xc9\x00\x00\x00\xc9\x00\xb5\x00\x00\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\x00\x00\xc9\x00\xed\x00\xc9\x00\x53\x00\x53\x00\x53\x00\x00\x00\x00\x00\x00\x00\x53\x00\x00\x00\xff\xff\x00\x00\x00\x00\xdd\x00\xdd\x00\xdd\x00\xdd\x00\xdd\x00\xdd\x00\xdd\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x68\x00\x00\x00\x00\x00\x00\x00\x53\x00\x00\x00\x68\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x00\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x00\x00\x00\x00\x68\x00\x00\x00\x53\x00\x00\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x68\x00\xa0\x00\x54\x00\x54\x00\x54\x00\xf3\x00\x00\x00\x00\x00\x54\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x69\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x69\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x00\x00\x00\x00\x69\x00\x00\x00\x54\x00\x00\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x69\x00\x9f\x00\x54\x00\x54\x00\x54\x00\xf3\x00\x00\x00\x00\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x00\x00\x98\x00\x54\x00\x54\x00\x54\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x00\x00\x00\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\xe4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x00\x00\x97\x00\x54\x00\x54\x00\x54\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x00\x00\x00\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\xe6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x00\x00\x96\x00\x54\x00\x54\x00\x54\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x00\x00\x94\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x00\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5a\x00\x5a\x00\x8a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x00\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5b\x00\x85\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\xff\xff\xe7\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x46\x00\x00\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x42\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\x6c\x00\xff\xff\xff\xff\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x73\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\x00\x00\x6c\x00\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x74\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\x89\x00\x6c\x00\xff\xff\xff\xff\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x00\x00\x00\x89\x00\x89\x00\x89\x00\x89\x00\x00\x00\x00\x00\x00\x00\x89\x00\x89\x00\x00\x00\x6f\x00\x89\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x89\x00\x00\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x89\x00\x00\x00\x89\x00\x89\x00\x89\x00\x89\x00\x00\x00\x00\x00\x00\x00\x89\x00\x89\x00\xcf\x00\x6f\x00\x89\x00\x89\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\xcf\x00\xcf\x00\x00\x00\x71\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x73\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\xcf\x00\xcf\x00\x00\x00\x71\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x81\x00\x81\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\x00\x00\x00\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x00\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x81\x00\x82\x00\x82\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x00\x00\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x83\x00\x83\x00\x83\x00\x00\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x17\x00\x17\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x00\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x84\x00\x84\x00\x84\x00\x00\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x17\x00\x17\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x00\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5b\x00\x85\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x82\x00\x82\x00\x82\x00\x00\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x00\x88\x00\x88\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x00\x00\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x82\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x00\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5a\x00\x5a\x00\x8a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x8d\x00\x8d\x00\x8d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x00\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x83\x00\x83\x00\x83\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x13\x00\x13\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x00\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x83\x00\x84\x00\x84\x00\x84\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x14\x00\x14\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x9b\x00\x9b\x00\x9b\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9c\x00\x9c\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x9c\x00\x00\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\xcf\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xa5\x00\xa5\x00\xa5\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\x00\x00\x00\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x00\x00\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa6\x00\xa6\x00\xa6\x00\x00\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\x00\x00\x2c\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa6\x00\x00\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x2c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x54\x00\x54\x00\x54\x00\x56\x00\x58\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x57\x00\x54\x00\x54\x00\x54\x00\x55\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x54\x00\x00\x00\x92\x00\xb5\x00\xb5\x00\xb5\x00\x00\x00\x00\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\x00\x00\x00\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\x00\x00\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb6\x00\xb6\x00\xb6\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x00\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb7\x00\xb7\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x52\x00\x00\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb8\x00\xb8\x00\xb8\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x51\x00\x00\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xba\x00\xba\x00\xba\x00\x00\x00\x00\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc5\x00\x00\x00\x00\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xba\x00\xba\x00\xba\x00\xba\x00\xbd\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb9\x00\x00\x00\xba\x00\xba\x00\xba\x00\xba\x00\xbd\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\x00\x00\x00\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc5\x00\x00\x00\x00\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xba\x00\x00\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\x00\x00\x00\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc5\x00\x00\x00\x00\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x00\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\x00\x00\x00\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc5\x00\x00\x00\x00\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x46\x00\x00\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xba\x00\xba\x00\xba\x00\xba\x00\xbd\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb9\x00\x00\x00\xba\x00\xba\x00\xba\x00\xba\x00\xbd\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\x00\x00\x00\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc5\x00\x00\x00\x00\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x45\x00\x00\x00\x45\x00\x00\x00\x00\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xba\x00\x00\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\x00\x00\x00\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc5\x00\x00\x00\x00\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbe\x00\x00\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\x00\x00\x00\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc6\x00\x00\x00\x00\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\xbf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbe\x00\x00\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xba\x00\xc0\x00\xc0\x00\xc0\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x00\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc1\x00\xc1\x00\xc1\x00\x00\x00\x00\x00\x00\x00\xc1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc8\x00\x00\x00\x00\x00\x00\x00\xc1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x52\x00\x00\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc1\x00\x00\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc2\x00\xc2\x00\xc2\x00\x00\x00\x00\x00\x00\x00\xc2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x51\x00\x00\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\x00\x00\x00\x00\x00\x00\xc9\x00\xc2\x00\x00\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc9\x00\x00\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\xca\x00\x00\x00\x00\x00\xc9\x00\xc9\x00\x00\x00\xc9\x00\xc9\x00\xc9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc9\x00\x00\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\x00\x00\x00\x00\x00\x00\xca\x00\x00\x00\xca\x00\xca\x00\xca\x00\xca\x00\x00\x00\x00\x00\x00\x00\xca\x00\xca\x00\x00\x00\xca\x00\xca\x00\xca\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xeb\x00\x00\x00\x00\x00\xc9\x00\xca\x00\xc9\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\x41\x00\x00\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x00\xc9\x00\x00\x00\xc9\x00\xca\x00\x00\x00\xca\x00\x00\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x00\x00\x00\x00\x00\x00\x00\xca\x00\xcf\x00\xca\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\x72\x00\xcf\x00\xcf\x00\xdb\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\xcf\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\x2b\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\xa4\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\xcf\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\xcf\x00\x8e\x00\xcf\x00\xcf\x00\x99\x00\xcf\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\x00\x00\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x9a\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xa6\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\xa8\x00\xcf\x00\xcf\x00\x00\x00\xcc\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\xa6\x00\x00\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa5\x00\xcf\x00\xcf\x00\xcf\x00\xf3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdf\x00\xdf\x00\xdf\x00\xdf\x00\xdf\x00\xdf\x00\xdf\x00\xdf\x00\xdf\x00\xdf\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x42\x00\x00\x00\xcf\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\xa5\x00\x00\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\x9c\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\xf3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x9e\x00\x3d\x00\xcf\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\x9c\x00\x00\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9c\x00\x9b\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\xd2\x00\xcf\x00\xcf\x00\x00\x00\x9d\x00\x00\x00\xcf\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\x9b\x00\xd4\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x9b\x00\x00\x00\xcf\x00\xd4\x00\xcf\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\x00\x00\x00\x00\x00\x00\xd4\x00\xd4\x00\x00\x00\xd4\x00\xd4\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe7\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\xd4\x00\x46\x00\x00\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\xd4\x00\xea\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x4c\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\x00\x00\xeb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x41\x00\x00\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\x4d\x00\x00\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\xd9\x00\x4a\x00\x00\x00\x00\x00\x3d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x47\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4b\x00\x00\x00\x00\x00\x4a\x00\x00\x00\x00\x00\x3d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xee\x00\x00\x00\x00\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x34\x00\x47\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x48\x00\x00\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x33\x00\x00\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\xe5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +alex_check :: AlexAddr +alex_check = AlexA# + "\xff\xff\x2d\x00\x01\x00\x02\x00\x2d\x00\x04\x00\x05\x00\x06\x00\x2d\x00\x65\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x65\x00\x7d\x00\x7d\x00\x7d\x00\x61\x00\x2d\x00\x2d\x00\x2d\x00\x69\x00\x6d\x00\x69\x00\x67\x00\x61\x00\x0a\x00\x6e\x00\x72\x00\x6e\x00\x0a\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x05\x00\x30\x00\x31\x00\x0a\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x05\x00\x23\x00\x0a\x00\x0a\x00\x09\x00\x2d\x00\x0b\x00\x0c\x00\x0d\x00\x0a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x20\x00\x30\x00\x31\x00\x23\x00\x0a\x00\x0a\x00\x0a\x00\x2d\x00\x6c\x00\x20\x00\x05\x00\x0a\x00\x0a\x00\x2d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x7c\x00\x21\x00\x5f\x00\x2d\x00\x0a\x00\x0a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x7c\x00\x23\x00\x20\x00\x05\x00\x5f\x00\x23\x00\x23\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x05\x00\x5f\x00\x2d\x00\x2d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x05\x00\x2d\x00\x2d\x00\x2d\x00\x09\x00\x23\x00\x0b\x00\x0c\x00\x0d\x00\x20\x00\x24\x00\x7d\x00\x23\x00\x23\x00\x23\x00\x23\x00\x2a\x00\x23\x00\x20\x00\x23\x00\x23\x00\x23\x00\x2d\x00\x23\x00\x23\x00\x23\x00\x23\x00\x20\x00\xff\xff\xff\xff\x05\x00\x2d\x00\xff\xff\xff\xff\x09\x00\x7b\x00\x0b\x00\x0c\x00\x0d\x00\x6c\x00\x2d\x00\xff\xff\xff\xff\x70\x00\x7b\x00\x23\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x05\x00\x20\x00\x30\x00\x31\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\x45\x00\x5e\x00\xff\xff\x2d\x00\xff\xff\x7b\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x20\x00\x05\x00\xff\xff\xff\xff\xff\xff\x09\x00\xff\xff\x0b\x00\x0c\x00\x0d\x00\x5f\x00\x7c\x00\x05\x00\x2d\x00\xff\xff\x7c\x00\x65\x00\x7b\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x20\x00\x23\x00\x05\x00\xff\xff\xff\xff\xff\xff\x09\x00\x7b\x00\x0b\x00\x0c\x00\x0d\x00\x20\x00\xff\xff\x2d\x00\x30\x00\x31\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x05\x00\x20\x00\xff\xff\xff\xff\x23\x00\x05\x00\x0b\x00\x0c\x00\x0d\x00\x7b\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x2d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\x01\x00\x02\x00\x20\x00\x5f\x00\x05\x00\x7b\x00\xff\xff\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x05\x00\x20\x00\x5f\x00\x7b\x00\x23\x00\xff\xff\x0b\x00\x0c\x00\x0d\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\x2d\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x20\x00\x3b\x00\x22\x00\x5f\x00\xff\xff\x7b\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\x5d\x00\x5f\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\x7d\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\x05\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\x20\x00\xff\xff\x20\x00\x23\x00\x24\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2a\x00\x20\x00\xff\xff\x22\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x5e\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\x7c\x00\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2b\x00\xff\xff\x2d\x00\xff\xff\x20\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2b\x00\xff\xff\x2d\x00\xff\xff\x20\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0b\x00\x0c\x00\x0d\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x20\x00\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\x23\x00\x24\x00\xff\xff\x20\x00\xff\xff\xff\xff\x23\x00\x2a\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x01\x00\x02\x00\x03\x00\x5f\x00\xff\xff\xff\xff\x07\x00\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\x5e\x00\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x5f\x00\x01\x00\x02\x00\x7c\x00\xff\xff\xff\xff\x65\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\x50\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\x70\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\x5e\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x50\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x7c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x2b\x00\xff\xff\x2d\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x2b\x00\xff\xff\x2d\x00\xff\xff\x5f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x45\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x5f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x50\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x50\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x01\x00\x02\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\x5f\x00\x04\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x23\x00\x7e\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\x0a\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\x5e\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7c\x00\x7c\x00\x01\x00\x02\x00\x03\x00\x23\x00\xff\xff\xff\xff\x07\x00\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\x5e\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7c\x00\x7c\x00\x01\x00\x02\x00\x03\x00\x23\x00\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x06\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x06\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x04\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x45\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x04\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\x04\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x3a\x00\x7e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\x04\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x3a\x00\x7e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x3a\x00\x7e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x06\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x06\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\x04\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\x2b\x00\xff\xff\x2d\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\x07\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\x04\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x04\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x5c\x00\x3a\x00\x5e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\x7c\x00\xff\xff\x7e\x00\x5c\x00\xff\xff\x5e\x00\xff\xff\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\x04\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x04\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\x29\x00\x2a\x00\x2b\x00\x04\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x3a\x00\x5e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x5d\x00\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x02\x00\xff\xff\x04\x00\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x3a\x00\x7e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\x29\x00\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x02\x00\x7c\x00\x04\x00\x7e\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\x45\x00\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x02\x00\x7c\x00\x04\x00\x7e\x00\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\x28\x00\x45\x00\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x02\x00\x7c\x00\x04\x00\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\x28\x00\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\x04\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\x7e\x00\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x42\x00\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\x62\x00\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\x23\x00\xff\xff\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\x78\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x42\x00\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\x62\x00\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\x78\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +alex_deflt :: AlexAddr +alex_deflt = AlexA# + "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x89\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x5d\x00\xff\xff\x89\x00\xff\xff\x89\x00\xff\xff\xff\xff\xff\xff\x89\x00\x66\x00\x67\x00\x68\x00\x69\x00\x68\x00\x6b\x00\x6b\x00\x67\x00\x67\x00\x6b\x00\x67\x00\x6b\x00\x67\x00\x66\x00\x66\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x89\x00\xff\xff\xff\xff\xff\xff\x89\x00\x89\x00\x89\x00\x89\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +alex_accept = listArray (0 :: Int, 246) + [ AlexAccNone + , AlexAcc 178 + , AlexAccNone + , AlexAcc 177 + , AlexAcc 176 + , AlexAcc 175 + , AlexAcc 174 + , AlexAcc 173 + , AlexAcc 172 + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccNone + , AlexAccSkip + , AlexAccSkip + , AlexAcc 171 + , AlexAcc 170 + , AlexAccPred 169 ( isNormalComment )(AlexAccNone) + , AlexAccPred 168 ( isNormalComment )(AlexAccNone) + , AlexAccPred 167 ( isNormalComment )(AlexAccNone) + , AlexAccPred 166 ( isNormalComment )(AlexAcc 165) + , AlexAcc 164 + , AlexAcc 163 + , AlexAccPred 162 ( alexNotPred (ifExtension HaddockBit) )(AlexAccNone) + , AlexAccPred 161 ( alexNotPred (ifExtension HaddockBit) )(AlexAcc 160) + , AlexAccPred 159 ( alexNotPred (ifExtension HaddockBit) )(AlexAccPred 158 ( ifExtension HaddockBit )(AlexAccNone)) + , AlexAcc 157 + , AlexAccPred 156 ( atEOL )(AlexAccNone) + , AlexAccPred 155 ( atEOL )(AlexAccNone) + , AlexAccPred 154 ( atEOL )(AlexAccNone) + , AlexAccPred 153 ( atEOL )(AlexAcc 152) + , AlexAccPred 151 ( atEOL )(AlexAcc 150) + , AlexAccPred 149 ( atEOL )(AlexAcc 148) + , AlexAccPred 147 ( atEOL )(AlexAcc 146) + , AlexAccPred 145 ( atEOL )(AlexAccNone) + , AlexAccPred 144 ( atEOL )(AlexAccNone) + , AlexAccPred 143 ( atEOL )(AlexAcc 142) + , AlexAccSkip + , AlexAccPred 141 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) + , AlexAccPred 140 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False) `alexAndPred` followedByDigit )(AlexAccNone) + , AlexAccSkipPred (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) + , AlexAccSkipPred (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) + , AlexAccPred 139 ( notFollowedBy '-' )(AlexAccNone) + , AlexAccSkip + , AlexAccPred 138 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) + , AlexAccPred 137 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone) + , AlexAccPred 136 ( notFollowedBySymbol )(AlexAccNone) + , AlexAcc 135 + , AlexAccPred 134 ( known_pragma linePrags )(AlexAccNone) + , AlexAccPred 133 ( known_pragma linePrags )(AlexAcc 132) + , AlexAccPred 131 ( known_pragma linePrags )(AlexAccPred 130 ( known_pragma oneWordPrags )(AlexAccPred 129 ( known_pragma ignoredPrags )(AlexAccPred 128 ( known_pragma fileHeaderPrags )(AlexAccNone)))) + , AlexAccPred 127 ( known_pragma linePrags )(AlexAccPred 126 ( known_pragma oneWordPrags )(AlexAccPred 125 ( known_pragma ignoredPrags )(AlexAccPred 124 ( known_pragma fileHeaderPrags )(AlexAccNone)))) + , AlexAcc 123 + , AlexAcc 122 + , AlexAcc 121 + , AlexAcc 120 + , AlexAcc 119 + , AlexAcc 118 + , AlexAcc 117 + , AlexAcc 116 + , AlexAccPred 115 ( known_pragma twoWordPrags )(AlexAccNone) + , AlexAcc 114 + , AlexAcc 113 + , AlexAcc 112 + , AlexAccPred 111 ( ifExtension HaddockBit )(AlexAccNone) + , AlexAccPred 110 ( ifExtension ThQuotesBit )(AlexAccNone) + , AlexAccPred 109 ( ifExtension ThQuotesBit )(AlexAccNone) + , AlexAccPred 108 ( ifExtension ThQuotesBit )(AlexAccPred 107 ( ifExtension QqBit )(AlexAccNone)) + , AlexAccPred 106 ( ifExtension ThQuotesBit )(AlexAccNone) + , AlexAccPred 105 ( ifExtension ThQuotesBit )(AlexAccPred 104 ( ifExtension QqBit )(AlexAccNone)) + , AlexAccPred 103 ( ifExtension ThQuotesBit )(AlexAccPred 102 ( ifExtension QqBit )(AlexAccNone)) + , AlexAccPred 101 ( ifExtension ThQuotesBit )(AlexAccPred 100 ( ifExtension QqBit )(AlexAccNone)) + , AlexAccPred 99 ( ifExtension ThQuotesBit )(AlexAccNone) + , AlexAccPred 98 ( ifExtension ThQuotesBit )(AlexAccNone) + , AlexAccPred 97 ( ifExtension ThBit )(AlexAccNone) + , AlexAccPred 96 ( ifExtension ThBit )(AlexAccNone) + , AlexAccPred 95 ( ifExtension ThBit )(AlexAccNone) + , AlexAccPred 94 ( ifExtension ThBit )(AlexAccNone) + , AlexAccPred 93 ( ifExtension QqBit )(AlexAccNone) + , AlexAccPred 92 ( ifExtension QqBit )(AlexAccNone) + , AlexAccPred 91 ( ifCurrentChar '⟦' `alexAndPred` + ifExtension UnicodeSyntaxBit `alexAndPred` + ifExtension ThQuotesBit )(AlexAccPred 90 ( ifCurrentChar '⟧' `alexAndPred` + ifExtension UnicodeSyntaxBit `alexAndPred` + ifExtension ThQuotesBit )(AlexAccPred 89 ( ifCurrentChar '⦇' `alexAndPred` + ifExtension UnicodeSyntaxBit `alexAndPred` + ifExtension ArrowsBit )(AlexAccPred 88 ( ifCurrentChar '⦈' `alexAndPred` + ifExtension UnicodeSyntaxBit `alexAndPred` + ifExtension ArrowsBit )(AlexAccNone)))) + , AlexAccPred 87 (alexPrevCharMatches(\c -> True && c < '\SOH' || c > '\ETX' && c < '\a' || c > '\a' && c < '\n' || c > '\n' && c < '\'' || c > '\'' && c < ')' || c > ')' && c < '0' || c > '9' && c < 'A' || c > 'Z' && c < '_' || c > '_' && c < 'a' || c > 'z' && True || False) `alexAndPred` ifExtension TypeApplicationsBit `alexAndPred` notFollowedBySymbol )(AlexAcc 86) + , AlexAccPred 85 ( ifExtension ArrowsBit `alexAndPred` + notFollowedBySymbol )(AlexAccNone) + , AlexAccPred 84 ( ifExtension ArrowsBit )(AlexAccNone) + , AlexAccPred 83 ( ifExtension IpBit )(AlexAccNone) + , AlexAccPred 82 ( ifExtension OverloadedLabelsBit )(AlexAccNone) + , AlexAccPred 81 ( ifExtension UnboxedTuplesBit `alexOrPred` + ifExtension UnboxedSumsBit )(AlexAccNone) + , AlexAccPred 80 ( ifExtension UnboxedTuplesBit `alexOrPred` + ifExtension UnboxedSumsBit )(AlexAccNone) + , AlexAcc 79 + , AlexAcc 78 + , AlexAcc 77 + , AlexAcc 76 + , AlexAcc 75 + , AlexAcc 74 + , AlexAcc 73 + , AlexAcc 72 + , AlexAcc 71 + , AlexAcc 70 + , AlexAcc 69 + , AlexAcc 68 + , AlexAcc 67 + , AlexAcc 66 + , AlexAcc 65 + , AlexAcc 64 + , AlexAcc 63 + , AlexAcc 62 + , AlexAcc 61 + , AlexAcc 60 + , AlexAcc 59 + , AlexAcc 58 + , AlexAcc 57 + , AlexAcc 56 + , AlexAcc 55 + , AlexAcc 54 + , AlexAccPred 53 ( ifExtension MagicHashBit )(AlexAccNone) + , AlexAccPred 52 ( ifExtension MagicHashBit )(AlexAccNone) + , AlexAccPred 51 ( ifExtension MagicHashBit )(AlexAccNone) + , AlexAccPred 50 ( ifExtension MagicHashBit )(AlexAccPred 49 ( ifExtension MagicHashBit )(AlexAccNone)) + , AlexAccPred 48 ( ifExtension MagicHashBit )(AlexAccPred 47 ( ifExtension MagicHashBit )(AlexAccNone)) + , AlexAccPred 46 ( ifExtension MagicHashBit )(AlexAccNone) + , AlexAcc 45 + , AlexAcc 44 + , AlexAcc 43 + , AlexAcc 42 + , AlexAcc 41 + , AlexAcc 40 + , AlexAcc 39 + , AlexAcc 38 + , AlexAcc 37 + , AlexAcc 36 + , AlexAcc 35 + , AlexAcc 34 + , AlexAcc 33 + , AlexAcc 32 + , AlexAccPred 31 ( ifExtension BinaryLiteralsBit )(AlexAccNone) + , AlexAcc 30 + , AlexAcc 29 + , AlexAccPred 28 ( ifExtension NegativeLiteralsBit )(AlexAccNone) + , AlexAccPred 27 ( ifExtension NegativeLiteralsBit )(AlexAccNone) + , AlexAccPred 26 ( ifExtension NegativeLiteralsBit `alexAndPred` + ifExtension BinaryLiteralsBit )(AlexAccNone) + , AlexAccPred 25 ( ifExtension NegativeLiteralsBit )(AlexAccNone) + , AlexAccPred 24 ( ifExtension NegativeLiteralsBit )(AlexAccNone) + , AlexAcc 23 + , AlexAcc 22 + , AlexAccPred 21 ( ifExtension NegativeLiteralsBit )(AlexAccNone) + , AlexAccPred 20 ( ifExtension NegativeLiteralsBit )(AlexAccNone) + , AlexAccPred 19 ( ifExtension HexFloatLiteralsBit )(AlexAccNone) + , AlexAccPred 18 ( ifExtension HexFloatLiteralsBit )(AlexAccNone) + , AlexAccPred 17 ( ifExtension HexFloatLiteralsBit `alexAndPred` + ifExtension NegativeLiteralsBit )(AlexAccNone) + , AlexAccPred 16 ( ifExtension HexFloatLiteralsBit `alexAndPred` + ifExtension NegativeLiteralsBit )(AlexAccNone) + , AlexAccPred 15 ( ifExtension MagicHashBit )(AlexAccNone) + , AlexAccPred 14 ( ifExtension MagicHashBit `alexAndPred` + ifExtension BinaryLiteralsBit )(AlexAccNone) + , AlexAccPred 13 ( ifExtension MagicHashBit )(AlexAccNone) + , AlexAccPred 12 ( ifExtension MagicHashBit )(AlexAccNone) + , AlexAccPred 11 ( ifExtension MagicHashBit )(AlexAccNone) + , AlexAccPred 10 ( ifExtension MagicHashBit `alexAndPred` + ifExtension BinaryLiteralsBit )(AlexAccNone) + , AlexAccPred 9 ( ifExtension MagicHashBit )(AlexAccNone) + , AlexAccPred 8 ( ifExtension MagicHashBit )(AlexAccNone) + , AlexAccPred 7 ( ifExtension MagicHashBit )(AlexAccNone) + , AlexAccPred 6 ( ifExtension MagicHashBit `alexAndPred` + ifExtension BinaryLiteralsBit )(AlexAccNone) + , AlexAccPred 5 ( ifExtension MagicHashBit )(AlexAccNone) + , AlexAccPred 4 ( ifExtension MagicHashBit )(AlexAccNone) + , AlexAccPred 3 ( ifExtension MagicHashBit )(AlexAccNone) + , AlexAccPred 2 ( ifExtension MagicHashBit )(AlexAccNone) + , AlexAcc 1 + , AlexAcc 0 + ] + +alex_actions = array (0 :: Int, 179) + [ (178,alex_action_14) + , (177,alex_action_20) + , (176,alex_action_21) + , (175,alex_action_19) + , (174,alex_action_22) + , (173,alex_action_26) + , (172,alex_action_27) + , (171,alex_action_1) + , (170,alex_action_1) + , (169,alex_action_2) + , (168,alex_action_2) + , (167,alex_action_2) + , (166,alex_action_2) + , (165,alex_action_27) + , (164,alex_action_3) + , (163,alex_action_4) + , (162,alex_action_5) + , (161,alex_action_5) + , (160,alex_action_27) + , (159,alex_action_5) + , (158,alex_action_38) + , (157,alex_action_6) + , (156,alex_action_7) + , (155,alex_action_7) + , (154,alex_action_7) + , (153,alex_action_7) + , (152,alex_action_27) + , (151,alex_action_7) + , (150,alex_action_27) + , (149,alex_action_7) + , (148,alex_action_85) + , (147,alex_action_7) + , (146,alex_action_85) + , (145,alex_action_8) + , (144,alex_action_8) + , (143,alex_action_8) + , (142,alex_action_27) + , (141,alex_action_10) + , (140,alex_action_11) + , (139,alex_action_15) + , (138,alex_action_17) + , (137,alex_action_17) + , (136,alex_action_18) + , (135,alex_action_23) + , (134,alex_action_24) + , (133,alex_action_24) + , (132,alex_action_27) + , (131,alex_action_24) + , (130,alex_action_32) + , (129,alex_action_33) + , (128,alex_action_35) + , (127,alex_action_24) + , (126,alex_action_32) + , (125,alex_action_33) + , (124,alex_action_36) + , (123,alex_action_25) + , (122,alex_action_27) + , (121,alex_action_27) + , (120,alex_action_27) + , (119,alex_action_27) + , (118,alex_action_28) + , (117,alex_action_29) + , (116,alex_action_30) + , (115,alex_action_31) + , (114,alex_action_34) + , (113,alex_action_37) + , (112,alex_action_37) + , (111,alex_action_39) + , (110,alex_action_40) + , (109,alex_action_41) + , (108,alex_action_42) + , (107,alex_action_53) + , (106,alex_action_43) + , (105,alex_action_44) + , (104,alex_action_53) + , (103,alex_action_45) + , (102,alex_action_53) + , (101,alex_action_46) + , (100,alex_action_53) + , (99,alex_action_47) + , (98,alex_action_48) + , (97,alex_action_49) + , (96,alex_action_50) + , (95,alex_action_51) + , (94,alex_action_52) + , (93,alex_action_53) + , (92,alex_action_54) + , (91,alex_action_55) + , (90,alex_action_56) + , (89,alex_action_60) + , (88,alex_action_61) + , (87,alex_action_57) + , (86,alex_action_85) + , (85,alex_action_58) + , (84,alex_action_59) + , (83,alex_action_62) + , (82,alex_action_63) + , (81,alex_action_64) + , (80,alex_action_65) + , (79,alex_action_66) + , (78,alex_action_66) + , (77,alex_action_67) + , (76,alex_action_68) + , (75,alex_action_68) + , (74,alex_action_69) + , (73,alex_action_70) + , (72,alex_action_71) + , (71,alex_action_72) + , (70,alex_action_73) + , (69,alex_action_73) + , (68,alex_action_74) + , (67,alex_action_75) + , (66,alex_action_75) + , (65,alex_action_76) + , (64,alex_action_76) + , (63,alex_action_77) + , (62,alex_action_77) + , (61,alex_action_77) + , (60,alex_action_77) + , (59,alex_action_77) + , (58,alex_action_77) + , (57,alex_action_77) + , (56,alex_action_77) + , (55,alex_action_78) + , (54,alex_action_78) + , (53,alex_action_79) + , (52,alex_action_80) + , (51,alex_action_81) + , (50,alex_action_81) + , (49,alex_action_111) + , (48,alex_action_81) + , (47,alex_action_112) + , (46,alex_action_82) + , (45,alex_action_83) + , (44,alex_action_84) + , (43,alex_action_85) + , (42,alex_action_85) + , (41,alex_action_85) + , (40,alex_action_85) + , (39,alex_action_85) + , (38,alex_action_85) + , (37,alex_action_85) + , (36,alex_action_85) + , (35,alex_action_85) + , (34,alex_action_86) + , (33,alex_action_87) + , (32,alex_action_87) + , (31,alex_action_88) + , (30,alex_action_89) + , (29,alex_action_90) + , (28,alex_action_91) + , (27,alex_action_91) + , (26,alex_action_92) + , (25,alex_action_93) + , (24,alex_action_94) + , (23,alex_action_95) + , (22,alex_action_95) + , (21,alex_action_96) + , (20,alex_action_96) + , (19,alex_action_97) + , (18,alex_action_97) + , (17,alex_action_98) + , (16,alex_action_98) + , (15,alex_action_99) + , (14,alex_action_100) + , (13,alex_action_101) + , (12,alex_action_102) + , (11,alex_action_103) + , (10,alex_action_104) + , (9,alex_action_105) + , (8,alex_action_106) + , (7,alex_action_107) + , (6,alex_action_108) + , (5,alex_action_109) + , (4,alex_action_110) + , (3,alex_action_111) + , (2,alex_action_112) + , (1,alex_action_113) + , (0,alex_action_114) + ] + +{-# LINE 578 "compiler/parser/Lexer.x" #-} + + +-- ----------------------------------------------------------------------------- +-- The token type + +data Token + = ITas -- Haskell keywords + | ITcase + | ITclass + | ITdata + | ITdefault + | ITderiving + | ITdo + | ITelse + | IThiding + | ITforeign + | ITif + | ITimport + | ITin + | ITinfix + | ITinfixl + | ITinfixr + | ITinstance + | ITlet + | ITmodule + | ITnewtype + | ITof + | ITqualified + | ITthen + | ITtype + | ITwhere + + | ITforall IsUnicodeSyntax -- GHC extension keywords + | ITexport + | ITlabel + | ITdynamic + | ITsafe + | ITinterruptible + | ITunsafe + | ITstdcallconv + | ITccallconv + | ITcapiconv + | ITprimcallconv + | ITjavascriptcallconv + | ITmdo + | ITfamily + | ITrole + | ITgroup + | ITby + | ITusing + | ITpattern + | ITstatic + | ITstock + | ITanyclass + | ITvia + + -- Backpack tokens + | ITunit + | ITsignature + | ITdependency + | ITrequires + + -- Pragmas, see note [Pragma source text] in BasicTypes + | ITinline_prag SourceText InlineSpec RuleMatchInfo + | ITspec_prag SourceText -- SPECIALISE + | ITspec_inline_prag SourceText Bool -- SPECIALISE INLINE (or NOINLINE) + | ITsource_prag SourceText + | ITrules_prag SourceText + | ITwarning_prag SourceText + | ITdeprecated_prag SourceText + | ITline_prag SourceText -- not usually produced, see 'UsePosPragsBit' + | ITcolumn_prag SourceText -- not usually produced, see 'UsePosPragsBit' + | ITscc_prag SourceText + | ITgenerated_prag SourceText + | ITcore_prag SourceText -- hdaume: core annotations + | ITunpack_prag SourceText + | ITnounpack_prag SourceText + | ITann_prag SourceText + | ITcomplete_prag SourceText + | ITclose_prag + | IToptions_prag String + | ITinclude_prag String + | ITlanguage_prag + | ITminimal_prag SourceText + | IToverlappable_prag SourceText -- instance overlap mode + | IToverlapping_prag SourceText -- instance overlap mode + | IToverlaps_prag SourceText -- instance overlap mode + | ITincoherent_prag SourceText -- instance overlap mode + | ITctype SourceText + | ITcomment_line_prag -- See Note [Nested comment line pragmas] + + | ITdotdot -- reserved symbols + | ITcolon + | ITdcolon IsUnicodeSyntax + | ITequal + | ITlam + | ITlcase + | ITvbar + | ITlarrow IsUnicodeSyntax + | ITrarrow IsUnicodeSyntax + | ITat + | ITtilde + | ITdarrow IsUnicodeSyntax + | ITminus + | ITbang + | ITstar IsUnicodeSyntax + | ITdot + + | ITbiglam -- GHC-extension symbols + + | ITocurly -- special symbols + | ITccurly + | ITvocurly + | ITvccurly + | ITobrack + | ITopabrack -- [:, for parallel arrays with -XParallelArrays + | ITcpabrack -- :], for parallel arrays with -XParallelArrays + | ITcbrack + | IToparen + | ITcparen + | IToubxparen + | ITcubxparen + | ITsemi + | ITcomma + | ITunderscore + | ITbackquote + | ITsimpleQuote -- ' + + | ITvarid FastString -- identifiers + | ITconid FastString + | ITvarsym FastString + | ITconsym FastString + | ITqvarid (FastString,FastString) + | ITqconid (FastString,FastString) + | ITqvarsym (FastString,FastString) + | ITqconsym (FastString,FastString) + + | ITdupipvarid FastString -- GHC extension: implicit param: ?x + | ITlabelvarid FastString -- Overloaded label: #x + + | ITchar SourceText Char -- Note [Literal source text] in BasicTypes + | ITstring SourceText FastString -- Note [Literal source text] in BasicTypes + | ITinteger IntegralLit -- Note [Literal source text] in BasicTypes + | ITrational FractionalLit + + | ITprimchar SourceText Char -- Note [Literal source text] in BasicTypes + | ITprimstring SourceText ByteString -- Note [Literal source text] @BasicTypes + | ITprimint SourceText Integer -- Note [Literal source text] in BasicTypes + | ITprimword SourceText Integer -- Note [Literal source text] in BasicTypes + | ITprimfloat FractionalLit + | ITprimdouble FractionalLit + + -- Template Haskell extension tokens + | ITopenExpQuote HasE IsUnicodeSyntax -- [| or [e| + | ITopenPatQuote -- [p| + | ITopenDecQuote -- [d| + | ITopenTypQuote -- [t| + | ITcloseQuote IsUnicodeSyntax -- |] + | ITopenTExpQuote HasE -- [|| or [e|| + | ITcloseTExpQuote -- ||] + | ITidEscape FastString -- $x + | ITparenEscape -- $( + | ITidTyEscape FastString -- $$x + | ITparenTyEscape -- $$( + | ITtyQuote -- '' + | ITquasiQuote (FastString,FastString,RealSrcSpan) + -- ITquasiQuote(quoter, quote, loc) + -- represents a quasi-quote of the form + -- [quoter| quote |] + | ITqQuasiQuote (FastString,FastString,FastString,RealSrcSpan) + -- ITqQuasiQuote(Qual, quoter, quote, loc) + -- represents a qualified quasi-quote of the form + -- [Qual.quoter| quote |] + + -- Arrow notation extension + | ITproc + | ITrec + | IToparenbar IsUnicodeSyntax -- ^ @(|@ + | ITcparenbar IsUnicodeSyntax -- ^ @|)@ + | ITlarrowtail IsUnicodeSyntax -- ^ @-<@ + | ITrarrowtail IsUnicodeSyntax -- ^ @>-@ + | ITLarrowtail IsUnicodeSyntax -- ^ @-<<@ + | ITRarrowtail IsUnicodeSyntax -- ^ @>>-@ + + -- | Type application '@' (lexed differently than as-pattern '@', + -- due to checking for preceding whitespace) + | ITtypeApp + + + | ITunknown String -- ^ Used when the lexer can't make sense of it + | ITeof -- ^ end of file token + + -- Documentation annotations + | ITdocCommentNext String -- ^ something beginning @-- |@ + | ITdocCommentPrev String -- ^ something beginning @-- ^@ + | ITdocCommentNamed String -- ^ something beginning @-- $@ + | ITdocSection Int String -- ^ a section heading + | ITdocOptions String -- ^ doc options (prune, ignore-exports, etc) + | ITlineComment String -- ^ comment starting by "--" + | ITblockComment String -- ^ comment in {- -} + + deriving Show + +instance Outputable Token where + ppr x = text (show x) + + +-- the bitmap provided as the third component indicates whether the +-- corresponding extension keyword is valid under the extension options +-- provided to the compiler; if the extension corresponding to *any* of the +-- bits set in the bitmap is enabled, the keyword is valid (this setup +-- facilitates using a keyword in two different extensions that can be +-- activated independently) +-- +reservedWordsFM :: UniqFM (Token, ExtsBitmap) +reservedWordsFM = listToUFM $ + map (\(x, y, z) -> (mkFastString x, (y, z))) + [( "_", ITunderscore, 0 ), + ( "as", ITas, 0 ), + ( "case", ITcase, 0 ), + ( "class", ITclass, 0 ), + ( "data", ITdata, 0 ), + ( "default", ITdefault, 0 ), + ( "deriving", ITderiving, 0 ), + ( "do", ITdo, 0 ), + ( "else", ITelse, 0 ), + ( "hiding", IThiding, 0 ), + ( "if", ITif, 0 ), + ( "import", ITimport, 0 ), + ( "in", ITin, 0 ), + ( "infix", ITinfix, 0 ), + ( "infixl", ITinfixl, 0 ), + ( "infixr", ITinfixr, 0 ), + ( "instance", ITinstance, 0 ), + ( "let", ITlet, 0 ), + ( "module", ITmodule, 0 ), + ( "newtype", ITnewtype, 0 ), + ( "of", ITof, 0 ), + ( "qualified", ITqualified, 0 ), + ( "then", ITthen, 0 ), + ( "type", ITtype, 0 ), + ( "where", ITwhere, 0 ), + + ( "forall", ITforall NormalSyntax, 0), + ( "mdo", ITmdo, xbit RecursiveDoBit), + -- See Note [Lexing type pseudo-keywords] + ( "family", ITfamily, 0 ), + ( "role", ITrole, 0 ), + ( "pattern", ITpattern, xbit PatternSynonymsBit), + ( "static", ITstatic, xbit StaticPointersBit ), + ( "stock", ITstock, 0 ), + ( "anyclass", ITanyclass, 0 ), + ( "via", ITvia, 0 ), + ( "group", ITgroup, xbit TransformComprehensionsBit), + ( "by", ITby, xbit TransformComprehensionsBit), + ( "using", ITusing, xbit TransformComprehensionsBit), + + ( "foreign", ITforeign, xbit FfiBit), + ( "export", ITexport, xbit FfiBit), + ( "label", ITlabel, xbit FfiBit), + ( "dynamic", ITdynamic, xbit FfiBit), + ( "safe", ITsafe, xbit FfiBit .|. + xbit SafeHaskellBit), + ( "interruptible", ITinterruptible, xbit InterruptibleFfiBit), + ( "unsafe", ITunsafe, xbit FfiBit), + ( "stdcall", ITstdcallconv, xbit FfiBit), + ( "ccall", ITccallconv, xbit FfiBit), + ( "capi", ITcapiconv, xbit CApiFfiBit), + ( "prim", ITprimcallconv, xbit FfiBit), + ( "javascript", ITjavascriptcallconv, xbit FfiBit), + + ( "unit", ITunit, 0 ), + ( "dependency", ITdependency, 0 ), + ( "signature", ITsignature, 0 ), + + ( "rec", ITrec, xbit ArrowsBit .|. + xbit RecursiveDoBit), + ( "proc", ITproc, xbit ArrowsBit) + ] + +{----------------------------------- +Note [Lexing type pseudo-keywords] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +One might think that we wish to treat 'family' and 'role' as regular old +varids whenever -XTypeFamilies and -XRoleAnnotations are off, respectively. +But, there is no need to do so. These pseudo-keywords are not stolen syntax: +they are only used after the keyword 'type' at the top-level, where varids are +not allowed. Furthermore, checks further downstream (TcTyClsDecls) ensure that +type families and role annotations are never declared without their extensions +on. In fact, by unconditionally lexing these pseudo-keywords as special, we +can get better error messages. + +Also, note that these are included in the `varid` production in the parser -- +a key detail to make all this work. +-------------------------------------} + +reservedSymsFM :: UniqFM (Token, IsUnicodeSyntax, ExtsBitmap) +reservedSymsFM = listToUFM $ + map (\ (x,w,y,z) -> (mkFastString x,(w,y,z))) + [ ("..", ITdotdot, NormalSyntax, 0 ) + -- (:) is a reserved op, meaning only list cons + ,(":", ITcolon, NormalSyntax, 0 ) + ,("::", ITdcolon NormalSyntax, NormalSyntax, 0 ) + ,("=", ITequal, NormalSyntax, 0 ) + ,("\\", ITlam, NormalSyntax, 0 ) + ,("|", ITvbar, NormalSyntax, 0 ) + ,("<-", ITlarrow NormalSyntax, NormalSyntax, 0 ) + ,("->", ITrarrow NormalSyntax, NormalSyntax, 0 ) + ,("@", ITat, NormalSyntax, 0 ) + ,("~", ITtilde, NormalSyntax, 0 ) + ,("=>", ITdarrow NormalSyntax, NormalSyntax, 0 ) + ,("-", ITminus, NormalSyntax, 0 ) + ,("!", ITbang, NormalSyntax, 0 ) + + ,("*", ITstar NormalSyntax, NormalSyntax, xbit StarIsTypeBit) + + -- For 'forall a . t' + ,(".", ITdot, NormalSyntax, 0 ) + + ,("-<", ITlarrowtail NormalSyntax, NormalSyntax, xbit ArrowsBit) + ,(">-", ITrarrowtail NormalSyntax, NormalSyntax, xbit ArrowsBit) + ,("-<<", ITLarrowtail NormalSyntax, NormalSyntax, xbit ArrowsBit) + ,(">>-", ITRarrowtail NormalSyntax, NormalSyntax, xbit ArrowsBit) + + ,("∷", ITdcolon UnicodeSyntax, UnicodeSyntax, 0 ) + ,("⇒", ITdarrow UnicodeSyntax, UnicodeSyntax, 0 ) + ,("∀", ITforall UnicodeSyntax, UnicodeSyntax, 0 ) + ,("→", ITrarrow UnicodeSyntax, UnicodeSyntax, 0 ) + ,("←", ITlarrow UnicodeSyntax, UnicodeSyntax, 0 ) + + ,("⤙", ITlarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit) + ,("⤚", ITrarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit) + ,("⤛", ITLarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit) + ,("⤜", ITRarrowtail UnicodeSyntax, UnicodeSyntax, xbit ArrowsBit) + + ,("★", ITstar UnicodeSyntax, UnicodeSyntax, xbit StarIsTypeBit) + + -- ToDo: ideally, → and ∷ should be "specials", so that they cannot + -- form part of a large operator. This would let us have a better + -- syntax for kinds: ɑ∷*→* would be a legal kind signature. (maybe). + ] + +-- ----------------------------------------------------------------------------- +-- Lexer actions + +type Action = RealSrcSpan -> StringBuffer -> Int -> P (RealLocated Token) + +special :: Token -> Action +special tok span _buf _len = return (L span tok) + +token, layout_token :: Token -> Action +token t span _buf _len = return (L span t) +layout_token t span _buf _len = pushLexState layout >> return (L span t) + +idtoken :: (StringBuffer -> Int -> Token) -> Action +idtoken f span buf len = return (L span $! (f buf len)) + +skip_one_varid :: (FastString -> Token) -> Action +skip_one_varid f span buf len + = return (L span $! f (lexemeToFastString (stepOn buf) (len-1))) + +skip_two_varid :: (FastString -> Token) -> Action +skip_two_varid f span buf len + = return (L span $! f (lexemeToFastString (stepOn (stepOn buf)) (len-2))) + +strtoken :: (String -> Token) -> Action +strtoken f span buf len = + return (L span $! (f $! lexemeToString buf len)) + +begin :: Int -> Action +begin code _span _str _len = do pushLexState code; lexToken + +pop :: Action +pop _span _buf _len = do _ <- popLexState + lexToken +-- See Note [Nested comment line pragmas] +failLinePrag1 :: Action +failLinePrag1 span _buf _len = do + b <- getBit InNestedCommentBit + if b then return (L span ITcomment_line_prag) + else lexError "lexical error in pragma" + +-- See Note [Nested comment line pragmas] +popLinePrag1 :: Action +popLinePrag1 span _buf _len = do + b <- getBit InNestedCommentBit + if b then return (L span ITcomment_line_prag) else do + _ <- popLexState + lexToken + +hopefully_open_brace :: Action +hopefully_open_brace span buf len + = do relaxed <- getBit RelaxedLayoutBit + ctx <- getContext + (AI l _) <- getInput + let offset = srcLocCol l + isOK = relaxed || + case ctx of + Layout prev_off _ : _ -> prev_off < offset + _ -> True + if isOK then pop_and open_brace span buf len + else addFatalError (RealSrcSpan span) (text "Missing block") + +pop_and :: Action -> Action +pop_and act span buf len = do _ <- popLexState + act span buf len + +{-# INLINE nextCharIs #-} +nextCharIs :: StringBuffer -> (Char -> Bool) -> Bool +nextCharIs buf p = not (atEnd buf) && p (currentChar buf) + +{-# INLINE nextCharIsNot #-} +nextCharIsNot :: StringBuffer -> (Char -> Bool) -> Bool +nextCharIsNot buf p = not (nextCharIs buf p) + +notFollowedBy :: Char -> AlexAccPred ExtsBitmap +notFollowedBy char _ _ _ (AI _ buf) + = nextCharIsNot buf (== char) + +notFollowedBySymbol :: AlexAccPred ExtsBitmap +notFollowedBySymbol _ _ _ (AI _ buf) + = nextCharIsNot buf (`elem` "!#$%&*+./<=>?@\\^|-~") + +followedByDigit :: AlexAccPred ExtsBitmap +followedByDigit _ _ _ (AI _ buf) + = afterOptionalSpace buf (\b -> nextCharIs b (`elem` ['0'..'9'])) + +ifCurrentChar :: Char -> AlexAccPred ExtsBitmap +ifCurrentChar char _ (AI _ buf) _ _ + = nextCharIs buf (== char) + +-- We must reject doc comments as being ordinary comments everywhere. +-- In some cases the doc comment will be selected as the lexeme due to +-- maximal munch, but not always, because the nested comment rule is +-- valid in all states, but the doc-comment rules are only valid in +-- the non-layout states. +isNormalComment :: AlexAccPred ExtsBitmap +isNormalComment bits _ _ (AI _ buf) + | HaddockBit `xtest` bits = notFollowedByDocOrPragma + | otherwise = nextCharIsNot buf (== '#') + where + notFollowedByDocOrPragma + = afterOptionalSpace buf (\b -> nextCharIsNot b (`elem` "|^*$#")) + +afterOptionalSpace :: StringBuffer -> (StringBuffer -> Bool) -> Bool +afterOptionalSpace buf p + = if nextCharIs buf (== ' ') + then p (snd (nextChar buf)) + else p buf + +atEOL :: AlexAccPred ExtsBitmap +atEOL _ _ _ (AI _ buf) = atEnd buf || currentChar buf == '\n' + +ifExtension :: ExtBits -> AlexAccPred ExtsBitmap +ifExtension extBits bits _ _ _ = extBits `xtest` bits + +alexNotPred p userState in1 len in2 + = not (p userState in1 len in2) + +alexOrPred p1 p2 userState in1 len in2 + = p1 userState in1 len in2 || p2 userState in1 len in2 + +multiline_doc_comment :: Action +multiline_doc_comment span buf _len = withLexedDocType (worker "") + where + worker commentAcc input docType checkNextLine = case alexGetChar' input of + Just ('\n', input') + | checkNextLine -> case checkIfCommentLine input' of + Just input -> worker ('\n':commentAcc) input docType checkNextLine + Nothing -> docCommentEnd input commentAcc docType buf span + | otherwise -> docCommentEnd input commentAcc docType buf span + Just (c, input) -> worker (c:commentAcc) input docType checkNextLine + Nothing -> docCommentEnd input commentAcc docType buf span + + -- Check if the next line of input belongs to this doc comment as well. + -- A doc comment continues onto the next line when the following + -- conditions are met: + -- * The line starts with "--" + -- * The line doesn't start with "---". + -- * The line doesn't start with "-- $", because that would be the + -- start of a /new/ named haddock chunk (#10398). + checkIfCommentLine :: AlexInput -> Maybe AlexInput + checkIfCommentLine input = check (dropNonNewlineSpace input) + where + check input = do + ('-', input) <- alexGetChar' input + ('-', input) <- alexGetChar' input + (c, after_c) <- alexGetChar' input + case c of + '-' -> Nothing + ' ' -> case alexGetChar' after_c of + Just ('$', _) -> Nothing + _ -> Just input + _ -> Just input + + dropNonNewlineSpace input = case alexGetChar' input of + Just (c, input') + | isSpace c && c /= '\n' -> dropNonNewlineSpace input' + | otherwise -> input + Nothing -> input + +lineCommentToken :: Action +lineCommentToken span buf len = do + b <- getBit RawTokenStreamBit + if b then strtoken ITlineComment span buf len else lexToken + +{- + nested comments require traversing by hand, they can't be parsed + using regular expressions. +-} +nested_comment :: P (RealLocated Token) -> Action +nested_comment cont span buf len = do + input <- getInput + go (reverse $ lexemeToString buf len) (1::Int) input + where + go commentAcc 0 input = do + setInput input + b <- getBit RawTokenStreamBit + if b + then docCommentEnd input commentAcc ITblockComment buf span + else cont + go commentAcc n input = case alexGetChar' input of + Nothing -> errBrace input span + Just ('-',input) -> case alexGetChar' input of + Nothing -> errBrace input span + Just ('\125',input) -> go ('\125':'-':commentAcc) (n-1) input -- '}' + Just (_,_) -> go ('-':commentAcc) n input + Just ('\123',input) -> case alexGetChar' input of -- '{' char + Nothing -> errBrace input span + Just ('-',input) -> go ('-':'\123':commentAcc) (n+1) input + Just (_,_) -> go ('\123':commentAcc) n input + -- See Note [Nested comment line pragmas] + Just ('\n',input) -> case alexGetChar' input of + Nothing -> errBrace input span + Just ('#',_) -> do (parsedAcc,input) <- parseNestedPragma input + go (parsedAcc ++ '\n':commentAcc) n input + Just (_,_) -> go ('\n':commentAcc) n input + Just (c,input) -> go (c:commentAcc) n input + +nested_doc_comment :: Action +nested_doc_comment span buf _len = withLexedDocType (go "") + where + go commentAcc input docType _ = case alexGetChar' input of + Nothing -> errBrace input span + Just ('-',input) -> case alexGetChar' input of + Nothing -> errBrace input span + Just ('\125',input) -> + docCommentEnd input commentAcc docType buf span + Just (_,_) -> go ('-':commentAcc) input docType False + Just ('\123', input) -> case alexGetChar' input of + Nothing -> errBrace input span + Just ('-',input) -> do + setInput input + let cont = do input <- getInput; go commentAcc input docType False + nested_comment cont span buf _len + Just (_,_) -> go ('\123':commentAcc) input docType False + -- See Note [Nested comment line pragmas] + Just ('\n',input) -> case alexGetChar' input of + Nothing -> errBrace input span + Just ('#',_) -> do (parsedAcc,input) <- parseNestedPragma input + go (parsedAcc ++ '\n':commentAcc) input docType False + Just (_,_) -> go ('\n':commentAcc) input docType False + Just (c,input) -> go (c:commentAcc) input docType False + +-- See Note [Nested comment line pragmas] +parseNestedPragma :: AlexInput -> P (String,AlexInput) +parseNestedPragma input@(AI _ buf) = do + origInput <- getInput + setInput input + setExts (.|. xbit InNestedCommentBit) + pushLexState bol + lt <- lexToken + _ <- popLexState + setExts (.&. complement (xbit InNestedCommentBit)) + postInput@(AI _ postBuf) <- getInput + setInput origInput + case unRealSrcSpan lt of + ITcomment_line_prag -> do + let bytes = byteDiff buf postBuf + diff = lexemeToString buf bytes + return (reverse diff, postInput) + lt' -> panic ("parseNestedPragma: unexpected token" ++ (show lt')) + +{- +Note [Nested comment line pragmas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to ignore cpp-preprocessor-generated #line pragmas if they were inside +nested comments. + +Now, when parsing a nested comment, if we encounter a line starting with '#' we +call parseNestedPragma, which executes the following: +1. Save the current lexer input (loc, buf) for later +2. Set the current lexer input to the beginning of the line starting with '#' +3. Turn the 'InNestedComment' extension on +4. Push the 'bol' lexer state +5. Lex a token. Due to (2), (3), and (4), this should always lex a single line + or less and return the ITcomment_line_prag token. This may set source line + and file location if a #line pragma is successfully parsed +6. Restore lexer input and state to what they were before we did all this +7. Return control to the function parsing a nested comment, informing it of + what the lexer parsed + +Regarding (5) above: +Every exit from the 'bol' lexer state (do_bol, popLinePrag1, failLinePrag1) +checks if the 'InNestedComment' extension is set. If it is, that function will +return control to parseNestedPragma by returning the ITcomment_line_prag token. + +See #314 for more background on the bug this fixes. +-} + +withLexedDocType :: (AlexInput -> (String -> Token) -> Bool -> P (RealLocated Token)) + -> P (RealLocated Token) +withLexedDocType lexDocComment = do + input@(AI _ buf) <- getInput + case prevChar buf ' ' of + -- The `Bool` argument to lexDocComment signals whether or not the next + -- line of input might also belong to this doc comment. + '|' -> lexDocComment input ITdocCommentNext True + '^' -> lexDocComment input ITdocCommentPrev True + '$' -> lexDocComment input ITdocCommentNamed True + '*' -> lexDocSection 1 input + _ -> panic "withLexedDocType: Bad doc type" + where + lexDocSection n input = case alexGetChar' input of + Just ('*', input) -> lexDocSection (n+1) input + Just (_, _) -> lexDocComment input (ITdocSection n) False + Nothing -> do setInput input; lexToken -- eof reached, lex it normally + +-- RULES pragmas turn on the forall and '.' keywords, and we turn them +-- off again at the end of the pragma. +rulePrag :: Action +rulePrag span buf len = do + setExts (.|. xbit InRulePragBit) + let !src = lexemeToString buf len + return (L span (ITrules_prag (SourceText src))) + +-- When 'UsePosPragsBit' is not set, it is expected that we emit a token instead +-- of updating the position in 'PState' +linePrag :: Action +linePrag span buf len = do + usePosPrags <- getBit UsePosPragsBit + if usePosPrags + then begin line_prag2 span buf len + else let !src = lexemeToString buf len + in return (L span (ITline_prag (SourceText src))) + +-- When 'UsePosPragsBit' is not set, it is expected that we emit a token instead +-- of updating the position in 'PState' +columnPrag :: Action +columnPrag span buf len = do + usePosPrags <- getBit UsePosPragsBit + let !src = lexemeToString buf len + if usePosPrags + then begin column_prag span buf len + else let !src = lexemeToString buf len + in return (L span (ITcolumn_prag (SourceText src))) + +endPrag :: Action +endPrag span _buf _len = do + setExts (.&. complement (xbit InRulePragBit)) + return (L span ITclose_prag) + +-- docCommentEnd +------------------------------------------------------------------------------- +-- This function is quite tricky. We can't just return a new token, we also +-- need to update the state of the parser. Why? Because the token is longer +-- than what was lexed by Alex, and the lexToken function doesn't know this, so +-- it writes the wrong token length to the parser state. This function is +-- called afterwards, so it can just update the state. + +docCommentEnd :: AlexInput -> String -> (String -> Token) -> StringBuffer -> + RealSrcSpan -> P (RealLocated Token) +docCommentEnd input commentAcc docType buf span = do + setInput input + let (AI loc nextBuf) = input + comment = reverse commentAcc + span' = mkRealSrcSpan (realSrcSpanStart span) loc + last_len = byteDiff buf nextBuf + + span `seq` setLastToken span' last_len + return (L span' (docType comment)) + +errBrace :: AlexInput -> RealSrcSpan -> P a +errBrace (AI end _) span = failLocMsgP (realSrcSpanStart span) end "unterminated `{-'" + +open_brace, close_brace :: Action +open_brace span _str _len = do + ctx <- getContext + setContext (NoLayout:ctx) + return (L span ITocurly) +close_brace span _str _len = do + popContext + return (L span ITccurly) + +qvarid, qconid :: StringBuffer -> Int -> Token +qvarid buf len = ITqvarid $! splitQualName buf len False +qconid buf len = ITqconid $! splitQualName buf len False + +splitQualName :: StringBuffer -> Int -> Bool -> (FastString,FastString) +-- takes a StringBuffer and a length, and returns the module name +-- and identifier parts of a qualified name. Splits at the *last* dot, +-- because of hierarchical module names. +splitQualName orig_buf len parens = split orig_buf orig_buf + where + split buf dot_buf + | orig_buf `byteDiff` buf >= len = done dot_buf + | c == '.' = found_dot buf' + | otherwise = split buf' dot_buf + where + (c,buf') = nextChar buf + + -- careful, we might get names like M.... + -- so, if the character after the dot is not upper-case, this is + -- the end of the qualifier part. + found_dot buf -- buf points after the '.' + | isUpper c = split buf' buf + | otherwise = done buf + where + (c,buf') = nextChar buf + + done dot_buf = + (lexemeToFastString orig_buf (qual_size - 1), + if parens -- Prelude.(+) + then lexemeToFastString (stepOn dot_buf) (len - qual_size - 2) + else lexemeToFastString dot_buf (len - qual_size)) + where + qual_size = orig_buf `byteDiff` dot_buf + +varid :: Action +varid span buf len = + case lookupUFM reservedWordsFM fs of + Just (ITcase, _) -> do + lastTk <- getLastTk + keyword <- case lastTk of + Just ITlam -> do + lambdaCase <- getBit LambdaCaseBit + unless lambdaCase $ do + pState <- getPState + addError (RealSrcSpan (last_loc pState)) $ text + "Illegal lambda-case (use LambdaCase)" + return ITlcase + _ -> return ITcase + maybe_layout keyword + return $ L span keyword + Just (keyword, 0) -> do + maybe_layout keyword + return $ L span keyword + Just (keyword, i) -> do + exts <- getExts + if exts .&. i /= 0 + then do + maybe_layout keyword + return $ L span keyword + else + return $ L span $ ITvarid fs + Nothing -> + return $ L span $ ITvarid fs + where + !fs = lexemeToFastString buf len + +conid :: StringBuffer -> Int -> Token +conid buf len = ITconid $! lexemeToFastString buf len + +qvarsym, qconsym :: StringBuffer -> Int -> Token +qvarsym buf len = ITqvarsym $! splitQualName buf len False +qconsym buf len = ITqconsym $! splitQualName buf len False + +varsym, consym :: Action +varsym = sym ITvarsym +consym = sym ITconsym + +sym :: (FastString -> Token) -> Action +sym con span buf len = + case lookupUFM reservedSymsFM fs of + Just (keyword, NormalSyntax, 0) -> + return $ L span keyword + Just (keyword, NormalSyntax, i) -> do + exts <- getExts + if exts .&. i /= 0 + then return $ L span keyword + else return $ L span (con fs) + Just (keyword, UnicodeSyntax, 0) -> do + exts <- getExts + if xtest UnicodeSyntaxBit exts + then return $ L span keyword + else return $ L span (con fs) + Just (keyword, UnicodeSyntax, i) -> do + exts <- getExts + if exts .&. i /= 0 && xtest UnicodeSyntaxBit exts + then return $ L span keyword + else return $ L span (con fs) + Nothing -> + return $ L span $! con fs + where + !fs = lexemeToFastString buf len + +-- Variations on the integral numeric literal. +tok_integral :: (SourceText -> Integer -> Token) + -> (Integer -> Integer) + -> Int -> Int + -> (Integer, (Char -> Int)) + -> Action +tok_integral itint transint transbuf translen (radix,char_to_int) span buf len = do + numericUnderscores <- getBit NumericUnderscoresBit -- #14473 + let src = lexemeToString buf len + when ((not numericUnderscores) && ('_' `elem` src)) $ do + pState <- getPState + addError (RealSrcSpan (last_loc pState)) $ text + "Use NumericUnderscores to allow underscores in integer literals" + return $ L span $ itint (SourceText src) + $! transint $ parseUnsignedInteger + (offsetBytes transbuf buf) (subtract translen len) radix char_to_int + +tok_num :: (Integer -> Integer) + -> Int -> Int + -> (Integer, (Char->Int)) -> Action +tok_num = tok_integral $ \case + st@(SourceText ('-':_)) -> itint st (const True) + st@(SourceText _) -> itint st (const False) + st@NoSourceText -> itint st (< 0) + where + itint :: SourceText -> (Integer -> Bool) -> Integer -> Token + itint !st is_negative !val = ITinteger ((IL st $! is_negative val) val) + +tok_primint :: (Integer -> Integer) + -> Int -> Int + -> (Integer, (Char->Int)) -> Action +tok_primint = tok_integral ITprimint + + +tok_primword :: Int -> Int + -> (Integer, (Char->Int)) -> Action +tok_primword = tok_integral ITprimword positive +positive, negative :: (Integer -> Integer) +positive = id +negative = negate +decimal, octal, hexadecimal :: (Integer, Char -> Int) +decimal = (10,octDecDigit) +binary = (2,octDecDigit) +octal = (8,octDecDigit) +hexadecimal = (16,hexDigit) + +-- readRational can understand negative rationals, exponents, everything. +tok_frac :: Int -> (String -> Token) -> Action +tok_frac drop f span buf len = do + numericUnderscores <- getBit NumericUnderscoresBit -- #14473 + let src = lexemeToString buf (len-drop) + when ((not numericUnderscores) && ('_' `elem` src)) $ do + pState <- getPState + addError (RealSrcSpan (last_loc pState)) $ text + "Use NumericUnderscores to allow underscores in floating literals" + return (L span $! (f $! src)) + +tok_float, tok_primfloat, tok_primdouble :: String -> Token +tok_float str = ITrational $! readFractionalLit str +tok_hex_float str = ITrational $! readHexFractionalLit str +tok_primfloat str = ITprimfloat $! readFractionalLit str +tok_primdouble str = ITprimdouble $! readFractionalLit str + +readFractionalLit :: String -> FractionalLit +readFractionalLit str = ((FL $! (SourceText str)) $! is_neg) $! readRational str + where is_neg = case str of ('-':_) -> True + _ -> False +readHexFractionalLit :: String -> FractionalLit +readHexFractionalLit str = + FL { fl_text = SourceText str + , fl_neg = case str of + '-' : _ -> True + _ -> False + , fl_value = readHexRational str + } + +-- ----------------------------------------------------------------------------- +-- Layout processing + +-- we're at the first token on a line, insert layout tokens if necessary +do_bol :: Action +do_bol span _str _len = do + -- See Note [Nested comment line pragmas] + b <- getBit InNestedCommentBit + if b then return (L span ITcomment_line_prag) else do + (pos, gen_semic) <- getOffside + case pos of + LT -> do + --trace "layout: inserting '}'" $ do + popContext + -- do NOT pop the lex state, we might have a ';' to insert + return (L span ITvccurly) + EQ | gen_semic -> do + --trace "layout: inserting ';'" $ do + _ <- popLexState + return (L span ITsemi) + _ -> do + _ <- popLexState + lexToken + +-- certain keywords put us in the "layout" state, where we might +-- add an opening curly brace. +maybe_layout :: Token -> P () +maybe_layout t = do -- If the alternative layout rule is enabled then + -- we never create an implicit layout context here. + -- Layout is handled XXX instead. + -- The code for closing implicit contexts, or + -- inserting implicit semi-colons, is therefore + -- irrelevant as it only applies in an implicit + -- context. + alr <- getBit AlternativeLayoutRuleBit + unless alr $ f t + where f ITdo = pushLexState layout_do + f ITmdo = pushLexState layout_do + f ITof = pushLexState layout + f ITlcase = pushLexState layout + f ITlet = pushLexState layout + f ITwhere = pushLexState layout + f ITrec = pushLexState layout + f ITif = pushLexState layout_if + f _ = return () + +-- Pushing a new implicit layout context. If the indentation of the +-- next token is not greater than the previous layout context, then +-- Haskell 98 says that the new layout context should be empty; that is +-- the lexer must generate {}. +-- +-- We are slightly more lenient than this: when the new context is started +-- by a 'do', then we allow the new context to be at the same indentation as +-- the previous context. This is what the 'strict' argument is for. +new_layout_context :: Bool -> Bool -> Token -> Action +new_layout_context strict gen_semic tok span _buf len = do + _ <- popLexState + (AI l _) <- getInput + let offset = srcLocCol l - len + ctx <- getContext + nondecreasing <- getBit NondecreasingIndentationBit + let strict' = strict || not nondecreasing + case ctx of + Layout prev_off _ : _ | + (strict' && prev_off >= offset || + not strict' && prev_off > offset) -> do + -- token is indented to the left of the previous context. + -- we must generate a {} sequence now. + pushLexState layout_left + return (L span tok) + _ -> do setContext (Layout offset gen_semic : ctx) + return (L span tok) + +do_layout_left :: Action +do_layout_left span _buf _len = do + _ <- popLexState + pushLexState bol -- we must be at the start of a line + return (L span ITvccurly) + +-- ----------------------------------------------------------------------------- +-- LINE pragmas + +setLineAndFile :: Int -> Action +setLineAndFile code span buf len = do + let src = lexemeToString buf (len - 1) -- drop trailing quotation mark + linenumLen = length $ head $ words src + linenum = parseUnsignedInteger buf linenumLen 10 octDecDigit + file = mkFastString $ go $ drop 1 $ dropWhile (/= '"') src + -- skip everything through first quotation mark to get to the filename + where go ('\\':c:cs) = c : go cs + go (c:cs) = c : go cs + go [] = [] + -- decode escapes in the filename. e.g. on Windows + -- when our filenames have backslashes in, gcc seems to + -- escape the backslashes. One symptom of not doing this + -- is that filenames in error messages look a bit strange: + -- C:\\foo\bar.hs + -- only the first backslash is doubled, because we apply + -- System.FilePath.normalise before printing out + -- filenames and it does not remove duplicate + -- backslashes after the drive letter (should it?). + setAlrLastLoc $ alrInitialLoc file + setSrcLoc (mkRealSrcLoc file (fromIntegral linenum - 1) (srcSpanEndCol span)) + -- subtract one: the line number refers to the *following* line + addSrcFile file + _ <- popLexState + pushLexState code + lexToken + +setColumn :: Action +setColumn span buf len = do + let column = + case reads (lexemeToString buf len) of + [(column, _)] -> column + _ -> error "setColumn: expected integer" -- shouldn't happen + setSrcLoc (mkRealSrcLoc (srcSpanFile span) (srcSpanEndLine span) + (fromIntegral (column :: Integer))) + _ <- popLexState + lexToken + +alrInitialLoc :: FastString -> RealSrcSpan +alrInitialLoc file = mkRealSrcSpan loc loc + where -- This is a hack to ensure that the first line in a file + -- looks like it is after the initial location: + loc = mkRealSrcLoc file (-1) (-1) + +-- ----------------------------------------------------------------------------- +-- Options, includes and language pragmas. + +lex_string_prag :: (String -> Token) -> Action +lex_string_prag mkTok span _buf _len + = do input <- getInput + start <- getRealSrcLoc + tok <- go [] input + end <- getRealSrcLoc + return (L (mkRealSrcSpan start end) tok) + where go acc input + = if isString input "#-}" + then do setInput input + return (mkTok (reverse acc)) + else case alexGetChar input of + Just (c,i) -> go (c:acc) i + Nothing -> err input + isString _ [] = True + isString i (x:xs) + = case alexGetChar i of + Just (c,i') | c == x -> isString i' xs + _other -> False + err (AI end _) = failLocMsgP (realSrcSpanStart span) end "unterminated options pragma" + + +-- ----------------------------------------------------------------------------- +-- Strings & Chars + +-- This stuff is horrible. I hates it. + +lex_string_tok :: Action +lex_string_tok span buf _len = do + tok <- lex_string "" + (AI end bufEnd) <- getInput + let + tok' = case tok of + ITprimstring _ bs -> ITprimstring (SourceText src) bs + ITstring _ s -> ITstring (SourceText src) s + _ -> panic "lex_string_tok" + src = lexemeToString buf (cur bufEnd - cur buf) + return (L (mkRealSrcSpan (realSrcSpanStart span) end) tok') + +lex_string :: String -> P Token +lex_string s = do + i <- getInput + case alexGetChar' i of + Nothing -> lit_error i + + Just ('"',i) -> do + setInput i + let s' = reverse s + magicHash <- getBit MagicHashBit + if magicHash + then do + i <- getInput + case alexGetChar' i of + Just ('#',i) -> do + setInput i + when (any (> '\xFF') s') $ do + pState <- getPState + addError (RealSrcSpan (last_loc pState)) $ text + "primitive string literal must contain only characters <= \'\\xFF\'" + return (ITprimstring (SourceText s') (unsafeMkByteString s')) + _other -> + return (ITstring (SourceText s') (mkFastString s')) + else + return (ITstring (SourceText s') (mkFastString s')) + + Just ('\\',i) + | Just ('&',i) <- next -> do + setInput i; lex_string s + | Just (c,i) <- next, c <= '\x7f' && is_space c -> do + -- is_space only works for <= '\x7f' (#3751, #5425) + setInput i; lex_stringgap s + where next = alexGetChar' i + + Just (c, i1) -> do + case c of + '\\' -> do setInput i1; c' <- lex_escape; lex_string (c':s) + c | isAny c -> do setInput i1; lex_string (c:s) + _other -> lit_error i + +lex_stringgap :: String -> P Token +lex_stringgap s = do + i <- getInput + c <- getCharOrFail i + case c of + '\\' -> lex_string s + c | c <= '\x7f' && is_space c -> lex_stringgap s + -- is_space only works for <= '\x7f' (#3751, #5425) + _other -> lit_error i + + +lex_char_tok :: Action +-- Here we are basically parsing character literals, such as 'x' or '\n' +-- but we additionally spot 'x and ''T, returning ITsimpleQuote and +-- ITtyQuote respectively, but WITHOUT CONSUMING the x or T part +-- (the parser does that). +-- So we have to do two characters of lookahead: when we see 'x we need to +-- see if there's a trailing quote +lex_char_tok span buf _len = do -- We've seen ' + i1 <- getInput -- Look ahead to first character + let loc = realSrcSpanStart span + case alexGetChar' i1 of + Nothing -> lit_error i1 + + Just ('\'', i2@(AI end2 _)) -> do -- We've seen '' + setInput i2 + return (L (mkRealSrcSpan loc end2) ITtyQuote) + + Just ('\\', i2@(AI _end2 _)) -> do -- We've seen 'backslash + setInput i2 + lit_ch <- lex_escape + i3 <- getInput + mc <- getCharOrFail i3 -- Trailing quote + if mc == '\'' then finish_char_tok buf loc lit_ch + else lit_error i3 + + Just (c, i2@(AI _end2 _)) + | not (isAny c) -> lit_error i1 + | otherwise -> + + -- We've seen 'x, where x is a valid character + -- (i.e. not newline etc) but not a quote or backslash + case alexGetChar' i2 of -- Look ahead one more character + Just ('\'', i3) -> do -- We've seen 'x' + setInput i3 + finish_char_tok buf loc c + _other -> do -- We've seen 'x not followed by quote + -- (including the possibility of EOF) + -- Just parse the quote only + let (AI end _) = i1 + return (L (mkRealSrcSpan loc end) ITsimpleQuote) + +finish_char_tok :: StringBuffer -> RealSrcLoc -> Char -> P (RealLocated Token) +finish_char_tok buf loc ch -- We've already seen the closing quote + -- Just need to check for trailing # + = do magicHash <- getBit MagicHashBit + i@(AI end bufEnd) <- getInput + let src = lexemeToString buf (cur bufEnd - cur buf) + if magicHash then do + case alexGetChar' i of + Just ('#',i@(AI end _)) -> do + setInput i + return (L (mkRealSrcSpan loc end) + (ITprimchar (SourceText src) ch)) + _other -> + return (L (mkRealSrcSpan loc end) + (ITchar (SourceText src) ch)) + else do + return (L (mkRealSrcSpan loc end) (ITchar (SourceText src) ch)) + +isAny :: Char -> Bool +isAny c | c > '\x7f' = isPrint c + | otherwise = is_any c + +lex_escape :: P Char +lex_escape = do + i0 <- getInput + c <- getCharOrFail i0 + case c of + 'a' -> return '\a' + 'b' -> return '\b' + 'f' -> return '\f' + 'n' -> return '\n' + 'r' -> return '\r' + 't' -> return '\t' + 'v' -> return '\v' + '\\' -> return '\\' + '"' -> return '\"' + '\'' -> return '\'' + '^' -> do i1 <- getInput + c <- getCharOrFail i1 + if c >= '@' && c <= '_' + then return (chr (ord c - ord '@')) + else lit_error i1 + + 'x' -> readNum is_hexdigit 16 hexDigit + 'o' -> readNum is_octdigit 8 octDecDigit + x | is_decdigit x -> readNum2 is_decdigit 10 octDecDigit (octDecDigit x) + + c1 -> do + i <- getInput + case alexGetChar' i of + Nothing -> lit_error i0 + Just (c2,i2) -> + case alexGetChar' i2 of + Nothing -> do lit_error i0 + Just (c3,i3) -> + let str = [c1,c2,c3] in + case [ (c,rest) | (p,c) <- silly_escape_chars, + Just rest <- [stripPrefix p str] ] of + (escape_char,[]):_ -> do + setInput i3 + return escape_char + (escape_char,_:_):_ -> do + setInput i2 + return escape_char + [] -> lit_error i0 + +readNum :: (Char -> Bool) -> Int -> (Char -> Int) -> P Char +readNum is_digit base conv = do + i <- getInput + c <- getCharOrFail i + if is_digit c + then readNum2 is_digit base conv (conv c) + else lit_error i + +readNum2 :: (Char -> Bool) -> Int -> (Char -> Int) -> Int -> P Char +readNum2 is_digit base conv i = do + input <- getInput + read i input + where read i input = do + case alexGetChar' input of + Just (c,input') | is_digit c -> do + let i' = i*base + conv c + if i' > 0x10ffff + then setInput input >> lexError "numeric escape sequence out of range" + else read i' input' + _other -> do + setInput input; return (chr i) + + +silly_escape_chars :: [(String, Char)] +silly_escape_chars = [ + ("NUL", '\NUL'), + ("SOH", '\SOH'), + ("STX", '\STX'), + ("ETX", '\ETX'), + ("EOT", '\EOT'), + ("ENQ", '\ENQ'), + ("ACK", '\ACK'), + ("BEL", '\BEL'), + ("BS", '\BS'), + ("HT", '\HT'), + ("LF", '\LF'), + ("VT", '\VT'), + ("FF", '\FF'), + ("CR", '\CR'), + ("SO", '\SO'), + ("SI", '\SI'), + ("DLE", '\DLE'), + ("DC1", '\DC1'), + ("DC2", '\DC2'), + ("DC3", '\DC3'), + ("DC4", '\DC4'), + ("NAK", '\NAK'), + ("SYN", '\SYN'), + ("ETB", '\ETB'), + ("CAN", '\CAN'), + ("EM", '\EM'), + ("SUB", '\SUB'), + ("ESC", '\ESC'), + ("FS", '\FS'), + ("GS", '\GS'), + ("RS", '\RS'), + ("US", '\US'), + ("SP", '\SP'), + ("DEL", '\DEL') + ] + +-- before calling lit_error, ensure that the current input is pointing to +-- the position of the error in the buffer. This is so that we can report +-- a correct location to the user, but also so we can detect UTF-8 decoding +-- errors if they occur. +lit_error :: AlexInput -> P a +lit_error i = do setInput i; lexError "lexical error in string/character literal" + +getCharOrFail :: AlexInput -> P Char +getCharOrFail i = do + case alexGetChar' i of + Nothing -> lexError "unexpected end-of-file in string/character literal" + Just (c,i) -> do setInput i; return c + +-- ----------------------------------------------------------------------------- +-- QuasiQuote + +lex_qquasiquote_tok :: Action +lex_qquasiquote_tok span buf len = do + let (qual, quoter) = splitQualName (stepOn buf) (len - 2) False + quoteStart <- getRealSrcLoc + quote <- lex_quasiquote quoteStart "" + end <- getRealSrcLoc + return (L (mkRealSrcSpan (realSrcSpanStart span) end) + (ITqQuasiQuote (qual, + quoter, + mkFastString (reverse quote), + mkRealSrcSpan quoteStart end))) + +lex_quasiquote_tok :: Action +lex_quasiquote_tok span buf len = do + let quoter = tail (lexemeToString buf (len - 1)) + -- 'tail' drops the initial '[', + -- while the -1 drops the trailing '|' + quoteStart <- getRealSrcLoc + quote <- lex_quasiquote quoteStart "" + end <- getRealSrcLoc + return (L (mkRealSrcSpan (realSrcSpanStart span) end) + (ITquasiQuote (mkFastString quoter, + mkFastString (reverse quote), + mkRealSrcSpan quoteStart end))) + +lex_quasiquote :: RealSrcLoc -> String -> P String +lex_quasiquote start s = do + i <- getInput + case alexGetChar' i of + Nothing -> quasiquote_error start + + -- NB: The string "|]" terminates the quasiquote, + -- with absolutely no escaping. See the extensive + -- discussion on #5348 for why there is no + -- escape handling. + Just ('|',i) + | Just (']',i) <- alexGetChar' i + -> do { setInput i; return s } + + Just (c, i) -> do + setInput i; lex_quasiquote start (c : s) + +quasiquote_error :: RealSrcLoc -> P a +quasiquote_error start = do + (AI end buf) <- getInput + reportLexError start end buf "unterminated quasiquotation" + +-- ----------------------------------------------------------------------------- +-- Warnings + +warnTab :: Action +warnTab srcspan _buf _len = do + addTabWarning srcspan + lexToken + +warnThen :: WarningFlag -> SDoc -> Action -> Action +warnThen option warning action srcspan buf len = do + addWarning option (RealSrcSpan srcspan) warning + action srcspan buf len + +-- ----------------------------------------------------------------------------- +-- The Parse Monad + +-- | Do we want to generate ';' layout tokens? In some cases we just want to +-- generate '}', e.g. in MultiWayIf we don't need ';'s because '|' separates +-- alternatives (unlike a `case` expression where we need ';' to as a separator +-- between alternatives). +type GenSemic = Bool + +generateSemic, dontGenerateSemic :: GenSemic +generateSemic = True +dontGenerateSemic = False + +data LayoutContext + = NoLayout + | Layout !Int !GenSemic + deriving Show + +-- | The result of running a parser. +data ParseResult a + = POk -- ^ The parser has consumed a (possibly empty) prefix + -- of the input and produced a result. Use 'getMessages' + -- to check for accumulated warnings and non-fatal errors. + PState -- ^ The resulting parsing state. Can be used to resume parsing. + a -- ^ The resulting value. + | PFailed -- ^ The parser has consumed a (possibly empty) prefix + -- of the input and failed. + PState -- ^ The parsing state right before failure, including the fatal + -- parse error. 'getMessages' and 'getErrorMessages' must return + -- a non-empty bag of errors. + +-- | Test whether a 'WarningFlag' is set +warnopt :: WarningFlag -> ParserFlags -> Bool +warnopt f options = f `EnumSet.member` pWarningFlags options + +-- | The subset of the 'DynFlags' used by the parser. +-- See 'mkParserFlags' or 'mkParserFlags'' for ways to construct this. +data ParserFlags = ParserFlags { + pWarningFlags :: EnumSet WarningFlag + , pThisPackage :: UnitId -- ^ key of package currently being compiled + , pExtsBitmap :: !ExtsBitmap -- ^ bitmap of permitted extensions + } + +data PState = PState { + buffer :: StringBuffer, + options :: ParserFlags, + -- This needs to take DynFlags as an argument until + -- we have a fix for #10143 + messages :: DynFlags -> Messages, + tab_first :: Maybe RealSrcSpan, -- pos of first tab warning in the file + tab_count :: !Int, -- number of tab warnings in the file + last_tk :: Maybe Token, + last_loc :: RealSrcSpan, -- pos of previous token + last_len :: !Int, -- len of previous token + loc :: RealSrcLoc, -- current loc (end of prev token + 1) + context :: [LayoutContext], + lex_state :: [Int], + srcfiles :: [FastString], + -- Used in the alternative layout rule: + -- These tokens are the next ones to be sent out. They are + -- just blindly emitted, without the rule looking at them again: + alr_pending_implicit_tokens :: [RealLocated Token], + -- This is the next token to be considered or, if it is Nothing, + -- we need to get the next token from the input stream: + alr_next_token :: Maybe (RealLocated Token), + -- This is what we consider to be the location of the last token + -- emitted: + alr_last_loc :: RealSrcSpan, + -- The stack of layout contexts: + alr_context :: [ALRContext], + -- Are we expecting a '{'? If it's Just, then the ALRLayout tells + -- us what sort of layout the '{' will open: + alr_expecting_ocurly :: Maybe ALRLayout, + -- Have we just had the '}' for a let block? If so, than an 'in' + -- token doesn't need to close anything: + alr_justClosedExplicitLetBlock :: Bool, + + -- The next three are used to implement Annotations giving the + -- locations of 'noise' tokens in the source, so that users of + -- the GHC API can do source to source conversions. + -- See note [Api annotations] in ApiAnnotation.hs + annotations :: [(ApiAnnKey,[SrcSpan])], + comment_q :: [Located AnnotationComment], + annotations_comments :: [(SrcSpan,[Located AnnotationComment])] + } + -- last_loc and last_len are used when generating error messages, + -- and in pushCurrentContext only. Sigh, if only Happy passed the + -- current token to happyError, we could at least get rid of last_len. + -- Getting rid of last_loc would require finding another way to + -- implement pushCurrentContext (which is only called from one place). + +data ALRContext = ALRNoLayout Bool{- does it contain commas? -} + Bool{- is it a 'let' block? -} + | ALRLayout ALRLayout Int +data ALRLayout = ALRLayoutLet + | ALRLayoutWhere + | ALRLayoutOf + | ALRLayoutDo + +-- | The parsing monad, isomorphic to @StateT PState Maybe@. +newtype P a = P { unP :: PState -> ParseResult a } + +instance Functor P where + fmap = liftM + +instance Applicative P where + pure = returnP + (<*>) = ap + +instance Monad P where + (>>=) = thenP +#if !MIN_VERSION_base(4,13,0) + fail = MonadFail.fail +#endif + +instance MonadFail.MonadFail P where + fail = failMsgP + +returnP :: a -> P a +returnP a = a `seq` (P $ \s -> POk s a) + +thenP :: P a -> (a -> P b) -> P b +(P m) `thenP` k = P $ \ s -> + case m s of + POk s1 a -> (unP (k a)) s1 + PFailed s1 -> PFailed s1 + +failMsgP :: String -> P a +failMsgP msg = do + pState <- getPState + addFatalError (RealSrcSpan (last_loc pState)) (text msg) + +failLocMsgP :: RealSrcLoc -> RealSrcLoc -> String -> P a +failLocMsgP loc1 loc2 str = + addFatalError (RealSrcSpan (mkRealSrcSpan loc1 loc2)) (text str) + +getPState :: P PState +getPState = P $ \s -> POk s s + +withThisPackage :: (UnitId -> a) -> P a +withThisPackage f = P $ \s@(PState{options = o}) -> POk s (f (pThisPackage o)) + +getExts :: P ExtsBitmap +getExts = P $ \s -> POk s (pExtsBitmap . options $ s) + +setExts :: (ExtsBitmap -> ExtsBitmap) -> P () +setExts f = P $ \s -> POk s { + options = + let p = options s + in p { pExtsBitmap = f (pExtsBitmap p) } + } () + +setSrcLoc :: RealSrcLoc -> P () +setSrcLoc new_loc = P $ \s -> POk s{loc=new_loc} () + +getRealSrcLoc :: P RealSrcLoc +getRealSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc + +addSrcFile :: FastString -> P () +addSrcFile f = P $ \s -> POk s{ srcfiles = f : srcfiles s } () + +setLastToken :: RealSrcSpan -> Int -> P () +setLastToken loc len = P $ \s -> POk s { + last_loc=loc, + last_len=len + } () + +setLastTk :: Token -> P () +setLastTk tk = P $ \s -> POk s { last_tk = Just tk } () + +getLastTk :: P (Maybe Token) +getLastTk = P $ \s@(PState { last_tk = last_tk }) -> POk s last_tk + +data AlexInput = AI RealSrcLoc StringBuffer + +{- +Note [Unicode in Alex] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Although newer versions of Alex support unicode, this grammar is processed with +the old style '--latin1' behaviour. This means that when implementing the +functions + + alexGetByte :: AlexInput -> Maybe (Word8,AlexInput) + alexInputPrevChar :: AlexInput -> Char + +which Alex uses to take apart our 'AlexInput', we must + + * return a latin1 character in the 'Word8' that 'alexGetByte' expects + * return a latin1 character in 'alexInputPrevChar'. + +We handle this in 'adjustChar' by squishing entire classes of unicode +characters into single bytes. +-} + +{-# INLINE adjustChar #-} +adjustChar :: Char -> Word8 +adjustChar c = fromIntegral $ ord adj_c + where non_graphic = '\x00' + upper = '\x01' + lower = '\x02' + digit = '\x03' + symbol = '\x04' + space = '\x05' + other_graphic = '\x06' + uniidchar = '\x07' + + adj_c + | c <= '\x07' = non_graphic + | c <= '\x7f' = c + -- Alex doesn't handle Unicode, so when Unicode + -- character is encountered we output these values + -- with the actual character value hidden in the state. + | otherwise = + -- NB: The logic behind these definitions is also reflected + -- in basicTypes/Lexeme.hs + -- Any changes here should likely be reflected there. + + case generalCategory c of + UppercaseLetter -> upper + LowercaseLetter -> lower + TitlecaseLetter -> upper + ModifierLetter -> uniidchar -- see #10196 + OtherLetter -> lower -- see #1103 + NonSpacingMark -> uniidchar -- see #7650 + SpacingCombiningMark -> other_graphic + EnclosingMark -> other_graphic + DecimalNumber -> digit + LetterNumber -> other_graphic + OtherNumber -> digit -- see #4373 + ConnectorPunctuation -> symbol + DashPunctuation -> symbol + OpenPunctuation -> other_graphic + ClosePunctuation -> other_graphic + InitialQuote -> other_graphic + FinalQuote -> other_graphic + OtherPunctuation -> symbol + MathSymbol -> symbol + CurrencySymbol -> symbol + ModifierSymbol -> symbol + OtherSymbol -> symbol + Space -> space + _other -> non_graphic + +-- Getting the previous 'Char' isn't enough here - we need to convert it into +-- the same format that 'alexGetByte' would have produced. +-- +-- See Note [Unicode in Alex] and #13986. +alexInputPrevChar :: AlexInput -> Char +alexInputPrevChar (AI _ buf) = chr (fromIntegral (adjustChar pc)) + where pc = prevChar buf '\n' + +-- backwards compatibility for Alex 2.x +alexGetChar :: AlexInput -> Maybe (Char,AlexInput) +alexGetChar inp = case alexGetByte inp of + Nothing -> Nothing + Just (b,i) -> c `seq` Just (c,i) + where c = chr $ fromIntegral b + +-- See Note [Unicode in Alex] +alexGetByte :: AlexInput -> Maybe (Word8,AlexInput) +alexGetByte (AI loc s) + | atEnd s = Nothing + | otherwise = byte `seq` loc' `seq` s' `seq` + --trace (show (ord c)) $ + Just (byte, (AI loc' s')) + where (c,s') = nextChar s + loc' = advanceSrcLoc loc c + byte = adjustChar c + +-- This version does not squash unicode characters, it is used when +-- lexing strings. +alexGetChar' :: AlexInput -> Maybe (Char,AlexInput) +alexGetChar' (AI loc s) + | atEnd s = Nothing + | otherwise = c `seq` loc' `seq` s' `seq` + --trace (show (ord c)) $ + Just (c, (AI loc' s')) + where (c,s') = nextChar s + loc' = advanceSrcLoc loc c + +getInput :: P AlexInput +getInput = P $ \s@PState{ loc=l, buffer=b } -> POk s (AI l b) + +setInput :: AlexInput -> P () +setInput (AI l b) = P $ \s -> POk s{ loc=l, buffer=b } () + +nextIsEOF :: P Bool +nextIsEOF = do + AI _ s <- getInput + return $ atEnd s + +pushLexState :: Int -> P () +pushLexState ls = P $ \s@PState{ lex_state=l } -> POk s{lex_state=ls:l} () + +popLexState :: P Int +popLexState = P $ \s@PState{ lex_state=ls:l } -> POk s{ lex_state=l } ls + +getLexState :: P Int +getLexState = P $ \s@PState{ lex_state=ls:_ } -> POk s ls + +popNextToken :: P (Maybe (RealLocated Token)) +popNextToken + = P $ \s@PState{ alr_next_token = m } -> + POk (s {alr_next_token = Nothing}) m + +activeContext :: P Bool +activeContext = do + ctxt <- getALRContext + expc <- getAlrExpectingOCurly + impt <- implicitTokenPending + case (ctxt,expc) of + ([],Nothing) -> return impt + _other -> return True + +setAlrLastLoc :: RealSrcSpan -> P () +setAlrLastLoc l = P $ \s -> POk (s {alr_last_loc = l}) () + +getAlrLastLoc :: P RealSrcSpan +getAlrLastLoc = P $ \s@(PState {alr_last_loc = l}) -> POk s l + +getALRContext :: P [ALRContext] +getALRContext = P $ \s@(PState {alr_context = cs}) -> POk s cs + +setALRContext :: [ALRContext] -> P () +setALRContext cs = P $ \s -> POk (s {alr_context = cs}) () + +getJustClosedExplicitLetBlock :: P Bool +getJustClosedExplicitLetBlock + = P $ \s@(PState {alr_justClosedExplicitLetBlock = b}) -> POk s b + +setJustClosedExplicitLetBlock :: Bool -> P () +setJustClosedExplicitLetBlock b + = P $ \s -> POk (s {alr_justClosedExplicitLetBlock = b}) () + +setNextToken :: RealLocated Token -> P () +setNextToken t = P $ \s -> POk (s {alr_next_token = Just t}) () + +implicitTokenPending :: P Bool +implicitTokenPending + = P $ \s@PState{ alr_pending_implicit_tokens = ts } -> + case ts of + [] -> POk s False + _ -> POk s True + +popPendingImplicitToken :: P (Maybe (RealLocated Token)) +popPendingImplicitToken + = P $ \s@PState{ alr_pending_implicit_tokens = ts } -> + case ts of + [] -> POk s Nothing + (t : ts') -> POk (s {alr_pending_implicit_tokens = ts'}) (Just t) + +setPendingImplicitTokens :: [RealLocated Token] -> P () +setPendingImplicitTokens ts = P $ \s -> POk (s {alr_pending_implicit_tokens = ts}) () + +getAlrExpectingOCurly :: P (Maybe ALRLayout) +getAlrExpectingOCurly = P $ \s@(PState {alr_expecting_ocurly = b}) -> POk s b + +setAlrExpectingOCurly :: Maybe ALRLayout -> P () +setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) () + +-- | For reasons of efficiency, boolean parsing flags (eg, language extensions +-- or whether we are currently in a @RULE@ pragma) are represented by a bitmap +-- stored in a @Word64@. +type ExtsBitmap = Word64 + +-- | Check if a given flag is currently set in the bitmap. +getBit :: ExtBits -> P Bool +getBit ext = P $ \s -> let b = ext `xtest` pExtsBitmap (options s) + in b `seq` POk s b + +xbit :: ExtBits -> ExtsBitmap +xbit = bit . fromEnum + +xtest :: ExtBits -> ExtsBitmap -> Bool +xtest ext xmap = testBit xmap (fromEnum ext) + +-- | Various boolean flags, mostly language extensions, that impact lexing and +-- parsing. Note that a handful of these can change during lexing/parsing. +data ExtBits + -- Flags that are constant once parsing starts + = FfiBit + | InterruptibleFfiBit + | CApiFfiBit + | ArrowsBit + | ThBit + | ThQuotesBit + | IpBit + | OverloadedLabelsBit -- #x overloaded labels + | ExplicitForallBit -- the 'forall' keyword + | BangPatBit -- Tells the parser to understand bang-patterns + -- (doesn't affect the lexer) + | PatternSynonymsBit -- pattern synonyms + | HaddockBit-- Lex and parse Haddock comments + | MagicHashBit -- "#" in both functions and operators + | RecursiveDoBit -- mdo + | UnicodeSyntaxBit -- the forall symbol, arrow symbols, etc + | UnboxedTuplesBit -- (# and #) + | UnboxedSumsBit -- (# and #) + | DatatypeContextsBit + | MonadComprehensionsBit + | TransformComprehensionsBit + | QqBit -- enable quasiquoting + | RawTokenStreamBit -- producing a token stream with all comments included + | AlternativeLayoutRuleBit + | ALRTransitionalBit + | RelaxedLayoutBit + | NondecreasingIndentationBit + | SafeHaskellBit + | TraditionalRecordSyntaxBit + | ExplicitNamespacesBit + | LambdaCaseBit + | BinaryLiteralsBit + | NegativeLiteralsBit + | HexFloatLiteralsBit + | TypeApplicationsBit + | StaticPointersBit + | NumericUnderscoresBit + | StarIsTypeBit + | BlockArgumentsBit + | NPlusKPatternsBit + | DoAndIfThenElseBit + | MultiWayIfBit + | GadtSyntaxBit + + -- Flags that are updated once parsing starts + | InRulePragBit + | InNestedCommentBit -- See Note [Nested comment line pragmas] + | UsePosPragsBit + -- ^ If this is enabled, '{-# LINE ... -#}' and '{-# COLUMN ... #-}' + -- update the internal position. Otherwise, those pragmas are lexed as + -- tokens of their own. + deriving Enum + + + + + +-- PState for parsing options pragmas +-- +pragState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState +pragState dynflags buf loc = (mkPState dynflags buf loc) { + lex_state = [bol, option_prags, 0] + } + +{-# INLINE mkParserFlags' #-} +mkParserFlags' + :: EnumSet WarningFlag -- ^ warnings flags enabled + -> EnumSet LangExt.Extension -- ^ permitted language extensions enabled + -> UnitId -- ^ key of package currently being compiled + -> Bool -- ^ are safe imports on? + -> Bool -- ^ keeping Haddock comment tokens + -> Bool -- ^ keep regular comment tokens + + -> Bool + -- ^ If this is enabled, '{-# LINE ... -#}' and '{-# COLUMN ... #-}' update + -- the internal position kept by the parser. Otherwise, those pragmas are + -- lexed as 'ITline_prag' and 'ITcolumn_prag' tokens. + + -> ParserFlags +-- ^ Given exactly the information needed, set up the 'ParserFlags' +mkParserFlags' warningFlags extensionFlags thisPackage + safeImports isHaddock rawTokStream usePosPrags = + ParserFlags { + pWarningFlags = warningFlags + , pThisPackage = thisPackage + , pExtsBitmap = safeHaskellBit .|. langExtBits .|. optBits + } + where + safeHaskellBit = SafeHaskellBit `setBitIf` safeImports + langExtBits = + FfiBit `xoptBit` LangExt.ForeignFunctionInterface + .|. InterruptibleFfiBit `xoptBit` LangExt.InterruptibleFFI + .|. CApiFfiBit `xoptBit` LangExt.CApiFFI + .|. ArrowsBit `xoptBit` LangExt.Arrows + .|. ThBit `xoptBit` LangExt.TemplateHaskell + .|. ThQuotesBit `xoptBit` LangExt.TemplateHaskellQuotes + .|. QqBit `xoptBit` LangExt.QuasiQuotes + .|. IpBit `xoptBit` LangExt.ImplicitParams + .|. OverloadedLabelsBit `xoptBit` LangExt.OverloadedLabels + .|. ExplicitForallBit `xoptBit` LangExt.ExplicitForAll + .|. BangPatBit `xoptBit` LangExt.BangPatterns + .|. MagicHashBit `xoptBit` LangExt.MagicHash + .|. RecursiveDoBit `xoptBit` LangExt.RecursiveDo + .|. UnicodeSyntaxBit `xoptBit` LangExt.UnicodeSyntax + .|. UnboxedTuplesBit `xoptBit` LangExt.UnboxedTuples + .|. UnboxedSumsBit `xoptBit` LangExt.UnboxedSums + .|. DatatypeContextsBit `xoptBit` LangExt.DatatypeContexts + .|. TransformComprehensionsBit `xoptBit` LangExt.TransformListComp + .|. MonadComprehensionsBit `xoptBit` LangExt.MonadComprehensions + .|. AlternativeLayoutRuleBit `xoptBit` LangExt.AlternativeLayoutRule + .|. ALRTransitionalBit `xoptBit` LangExt.AlternativeLayoutRuleTransitional + .|. RelaxedLayoutBit `xoptBit` LangExt.RelaxedLayout + .|. NondecreasingIndentationBit `xoptBit` LangExt.NondecreasingIndentation + .|. TraditionalRecordSyntaxBit `xoptBit` LangExt.TraditionalRecordSyntax + .|. ExplicitNamespacesBit `xoptBit` LangExt.ExplicitNamespaces + .|. LambdaCaseBit `xoptBit` LangExt.LambdaCase + .|. BinaryLiteralsBit `xoptBit` LangExt.BinaryLiterals + .|. NegativeLiteralsBit `xoptBit` LangExt.NegativeLiterals + .|. HexFloatLiteralsBit `xoptBit` LangExt.HexFloatLiterals + .|. PatternSynonymsBit `xoptBit` LangExt.PatternSynonyms + .|. TypeApplicationsBit `xoptBit` LangExt.TypeApplications + .|. StaticPointersBit `xoptBit` LangExt.StaticPointers + .|. NumericUnderscoresBit `xoptBit` LangExt.NumericUnderscores + .|. StarIsTypeBit `xoptBit` LangExt.StarIsType + .|. BlockArgumentsBit `xoptBit` LangExt.BlockArguments + .|. NPlusKPatternsBit `xoptBit` LangExt.NPlusKPatterns + .|. DoAndIfThenElseBit `xoptBit` LangExt.DoAndIfThenElse + .|. MultiWayIfBit `xoptBit` LangExt.MultiWayIf + .|. GadtSyntaxBit `xoptBit` LangExt.GADTSyntax + optBits = + HaddockBit `setBitIf` isHaddock + .|. RawTokenStreamBit `setBitIf` rawTokStream + .|. UsePosPragsBit `setBitIf` usePosPrags + + xoptBit bit ext = bit `setBitIf` EnumSet.member ext extensionFlags + + setBitIf :: ExtBits -> Bool -> ExtsBitmap + b `setBitIf` cond | cond = xbit b + | otherwise = 0 + +-- | Extracts the flag information needed for parsing +mkParserFlags :: DynFlags -> ParserFlags +mkParserFlags = + mkParserFlags' + <$> DynFlags.warningFlags + <*> DynFlags.extensionFlags + <*> DynFlags.thisPackage + <*> safeImportsOn + <*> gopt Opt_Haddock + <*> gopt Opt_KeepRawTokenStream + <*> const True + +-- | Creates a parse state from a 'DynFlags' value +mkPState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState +mkPState flags = mkPStatePure (mkParserFlags flags) + +-- | Creates a parse state from a 'ParserFlags' value +mkPStatePure :: ParserFlags -> StringBuffer -> RealSrcLoc -> PState +mkPStatePure options buf loc = + PState { + buffer = buf, + options = options, + messages = const emptyMessages, + tab_first = Nothing, + tab_count = 0, + last_tk = Nothing, + last_loc = mkRealSrcSpan loc loc, + last_len = 0, + loc = loc, + context = [], + lex_state = [bol, 0], + srcfiles = [], + alr_pending_implicit_tokens = [], + alr_next_token = Nothing, + alr_last_loc = alrInitialLoc (fsLit ""), + alr_context = [], + alr_expecting_ocurly = Nothing, + alr_justClosedExplicitLetBlock = False, + annotations = [], + comment_q = [], + annotations_comments = [] + } + +-- | Add a non-fatal error. Use this when the parser can produce a result +-- despite the error. +-- +-- For example, when GHC encounters a @forall@ in a type, +-- but @-XExplicitForAll@ is disabled, the parser constructs @ForAllTy@ +-- as if @-XExplicitForAll@ was enabled, adding a non-fatal error to +-- the accumulator. +-- +-- Control flow wise, non-fatal errors act like warnings: they are added +-- to the accumulator and parsing continues. This allows GHC to report +-- more than one parse error per file. +-- +addError :: SrcSpan -> SDoc -> P () +addError srcspan msg + = P $ \s@PState{messages=m} -> + let + m' d = + let (ws, es) = m d + errormsg = mkErrMsg d srcspan alwaysQualify msg + es' = es `snocBag` errormsg + in (ws, es') + in POk s{messages=m'} () + +-- | Add a fatal error. This will be the last error reported by the parser, and +-- the parser will not produce any result, ending in a 'PFailed' state. +addFatalError :: SrcSpan -> SDoc -> P a +addFatalError span msg = + addError span msg >> P PFailed + +-- | Add a warning to the accumulator. +-- Use 'getMessages' to get the accumulated warnings. +addWarning :: WarningFlag -> SrcSpan -> SDoc -> P () +addWarning option srcspan warning + = P $ \s@PState{messages=m, options=o} -> + let + m' d = + let (ws, es) = m d + warning' = makeIntoWarning (Reason option) $ + mkWarnMsg d srcspan alwaysQualify warning + ws' = if warnopt option o then ws `snocBag` warning' else ws + in (ws', es) + in POk s{messages=m'} () + +addTabWarning :: RealSrcSpan -> P () +addTabWarning srcspan + = P $ \s@PState{tab_first=tf, tab_count=tc, options=o} -> + let tf' = if isJust tf then tf else Just srcspan + tc' = tc + 1 + s' = if warnopt Opt_WarnTabs o + then s{tab_first = tf', tab_count = tc'} + else s + in POk s' () + +mkTabWarning :: PState -> DynFlags -> Maybe ErrMsg +mkTabWarning PState{tab_first=tf, tab_count=tc} d = + let middle = if tc == 1 + then text "" + else text ", and in" <+> speakNOf (tc - 1) (text "further location") + message = text "Tab character found here" + <> middle + <> text "." + $+$ text "Please use spaces instead." + in fmap (\s -> makeIntoWarning (Reason Opt_WarnTabs) $ + mkWarnMsg d (RealSrcSpan s) alwaysQualify message) tf + +-- | Get a bag of the errors that have been accumulated so far. +-- Does not take -Werror into account. +getErrorMessages :: PState -> DynFlags -> ErrorMessages +getErrorMessages PState{messages=m} d = + let (_, es) = m d in es + +-- | Get the warnings and errors accumulated so far. +-- Does not take -Werror into account. +getMessages :: PState -> DynFlags -> Messages +getMessages p@PState{messages=m} d = + let (ws, es) = m d + tabwarning = mkTabWarning p d + ws' = maybe ws (`consBag` ws) tabwarning + in (ws', es) + +getContext :: P [LayoutContext] +getContext = P $ \s@PState{context=ctx} -> POk s ctx + +setContext :: [LayoutContext] -> P () +setContext ctx = P $ \s -> POk s{context=ctx} () + +popContext :: P () +popContext = P $ \ s@(PState{ buffer = buf, options = o, context = ctx, + last_len = len, last_loc = last_loc }) -> + case ctx of + (_:tl) -> + POk s{ context = tl } () + [] -> + unP (addFatalError (RealSrcSpan last_loc) (srcParseErr o buf len)) s + +-- Push a new layout context at the indentation of the last token read. +pushCurrentContext :: GenSemic -> P () +pushCurrentContext gen_semic = P $ \ s@PState{ last_loc=loc, context=ctx } -> + POk s{context = Layout (srcSpanStartCol loc) gen_semic : ctx} () + +-- This is only used at the outer level of a module when the 'module' keyword is +-- missing. +pushModuleContext :: P () +pushModuleContext = pushCurrentContext generateSemic + +getOffside :: P (Ordering, Bool) +getOffside = P $ \s@PState{last_loc=loc, context=stk} -> + let offs = srcSpanStartCol loc in + let ord = case stk of + Layout n gen_semic : _ -> + --trace ("layout: " ++ show n ++ ", offs: " ++ show offs) $ + (compare offs n, gen_semic) + _ -> + (GT, dontGenerateSemic) + in POk s ord + +-- --------------------------------------------------------------------------- +-- Construct a parse error + +srcParseErr + :: ParserFlags + -> StringBuffer -- current buffer (placed just after the last token) + -> Int -- length of the previous token + -> MsgDoc +srcParseErr options buf len + = if null token + then text "parse error (possibly incorrect indentation or mismatched brackets)" + else text "parse error on input" <+> quotes (text token) + $$ ppWhen (not th_enabled && token == "$") -- #7396 + (text "Perhaps you intended to use TemplateHaskell") + $$ ppWhen (token == "<-") + (if mdoInLast100 + then text "Perhaps you intended to use RecursiveDo" + else text "Perhaps this statement should be within a 'do' block?") + $$ ppWhen (token == "=" && doInLast100) -- #15849 + (text "Perhaps you need a 'let' in a 'do' block?" + $$ text "e.g. 'let x = 5' instead of 'x = 5'") + $$ ppWhen (not ps_enabled && pattern == "pattern ") -- #12429 + (text "Perhaps you intended to use PatternSynonyms") + where token = lexemeToString (offsetBytes (-len) buf) len + pattern = decodePrevNChars 8 buf + last100 = decodePrevNChars 100 buf + doInLast100 = "do" `isInfixOf` last100 + mdoInLast100 = "mdo" `isInfixOf` last100 + th_enabled = ThBit `xtest` pExtsBitmap options + ps_enabled = PatternSynonymsBit `xtest` pExtsBitmap options + +-- Report a parse failure, giving the span of the previous token as +-- the location of the error. This is the entry point for errors +-- detected during parsing. +srcParseFail :: P a +srcParseFail = P $ \s@PState{ buffer = buf, options = o, last_len = len, + last_loc = last_loc } -> + unP (addFatalError (RealSrcSpan last_loc) (srcParseErr o buf len)) s + +-- A lexical error is reported at a particular position in the source file, +-- not over a token range. +lexError :: String -> P a +lexError str = do + loc <- getRealSrcLoc + (AI end buf) <- getInput + reportLexError loc end buf str + +-- ----------------------------------------------------------------------------- +-- This is the top-level function: called from the parser each time a +-- new token is to be read from the input. + +lexer :: Bool -> (Located Token -> P a) -> P a +lexer queueComments cont = do + alr <- getBit AlternativeLayoutRuleBit + let lexTokenFun = if alr then lexTokenAlr else lexToken + (L span tok) <- lexTokenFun + --trace ("token: " ++ show tok) $ do + + case tok of + ITeof -> addAnnotationOnly noSrcSpan AnnEofPos (RealSrcSpan span) + _ -> return () + + if (queueComments && isDocComment tok) + then queueComment (L (RealSrcSpan span) tok) + else return () + + if (queueComments && isComment tok) + then queueComment (L (RealSrcSpan span) tok) >> lexer queueComments cont + else cont (L (RealSrcSpan span) tok) + +lexTokenAlr :: P (RealLocated Token) +lexTokenAlr = do mPending <- popPendingImplicitToken + t <- case mPending of + Nothing -> + do mNext <- popNextToken + t <- case mNext of + Nothing -> lexToken + Just next -> return next + alternativeLayoutRuleToken t + Just t -> + return t + setAlrLastLoc (getRealSrcSpan t) + case unRealSrcSpan t of + ITwhere -> setAlrExpectingOCurly (Just ALRLayoutWhere) + ITlet -> setAlrExpectingOCurly (Just ALRLayoutLet) + ITof -> setAlrExpectingOCurly (Just ALRLayoutOf) + ITlcase -> setAlrExpectingOCurly (Just ALRLayoutOf) + ITdo -> setAlrExpectingOCurly (Just ALRLayoutDo) + ITmdo -> setAlrExpectingOCurly (Just ALRLayoutDo) + ITrec -> setAlrExpectingOCurly (Just ALRLayoutDo) + _ -> return () + return t + +alternativeLayoutRuleToken :: RealLocated Token -> P (RealLocated Token) +alternativeLayoutRuleToken t + = do context <- getALRContext + lastLoc <- getAlrLastLoc + mExpectingOCurly <- getAlrExpectingOCurly + transitional <- getBit ALRTransitionalBit + justClosedExplicitLetBlock <- getJustClosedExplicitLetBlock + setJustClosedExplicitLetBlock False + let thisLoc = getRealSrcSpan t + thisCol = srcSpanStartCol thisLoc + newLine = srcSpanStartLine thisLoc > srcSpanEndLine lastLoc + case (unRealSrcSpan t, context, mExpectingOCurly) of + -- This case handles a GHC extension to the original H98 + -- layout rule... + (ITocurly, _, Just alrLayout) -> + do setAlrExpectingOCurly Nothing + let isLet = case alrLayout of + ALRLayoutLet -> True + _ -> False + setALRContext (ALRNoLayout (containsCommas ITocurly) isLet : context) + return t + -- ...and makes this case unnecessary + {- + -- I think our implicit open-curly handling is slightly + -- different to John's, in how it interacts with newlines + -- and "in" + (ITocurly, _, Just _) -> + do setAlrExpectingOCurly Nothing + setNextToken t + lexTokenAlr + -} + (_, ALRLayout _ col : _ls, Just expectingOCurly) + | (thisCol > col) || + (thisCol == col && + isNonDecreasingIndentation expectingOCurly) -> + do setAlrExpectingOCurly Nothing + setALRContext (ALRLayout expectingOCurly thisCol : context) + setNextToken t + return (L thisLoc ITvocurly) + | otherwise -> + do setAlrExpectingOCurly Nothing + setPendingImplicitTokens [L lastLoc ITvccurly] + setNextToken t + return (L lastLoc ITvocurly) + (_, _, Just expectingOCurly) -> + do setAlrExpectingOCurly Nothing + setALRContext (ALRLayout expectingOCurly thisCol : context) + setNextToken t + return (L thisLoc ITvocurly) + -- We do the [] cases earlier than in the spec, as we + -- have an actual EOF token + (ITeof, ALRLayout _ _ : ls, _) -> + do setALRContext ls + setNextToken t + return (L thisLoc ITvccurly) + (ITeof, _, _) -> + return t + -- the other ITeof case omitted; general case below covers it + (ITin, _, _) + | justClosedExplicitLetBlock -> + return t + (ITin, ALRLayout ALRLayoutLet _ : ls, _) + | newLine -> + do setPendingImplicitTokens [t] + setALRContext ls + return (L thisLoc ITvccurly) + -- This next case is to handle a transitional issue: + (ITwhere, ALRLayout _ col : ls, _) + | newLine && thisCol == col && transitional -> + do addWarning Opt_WarnAlternativeLayoutRuleTransitional + (RealSrcSpan thisLoc) + (transitionalAlternativeLayoutWarning + "`where' clause at the same depth as implicit layout block") + setALRContext ls + setNextToken t + -- Note that we use lastLoc, as we may need to close + -- more layouts, or give a semicolon + return (L lastLoc ITvccurly) + -- This next case is to handle a transitional issue: + (ITvbar, ALRLayout _ col : ls, _) + | newLine && thisCol == col && transitional -> + do addWarning Opt_WarnAlternativeLayoutRuleTransitional + (RealSrcSpan thisLoc) + (transitionalAlternativeLayoutWarning + "`|' at the same depth as implicit layout block") + setALRContext ls + setNextToken t + -- Note that we use lastLoc, as we may need to close + -- more layouts, or give a semicolon + return (L lastLoc ITvccurly) + (_, ALRLayout _ col : ls, _) + | newLine && thisCol == col -> + do setNextToken t + let loc = realSrcSpanStart thisLoc + zeroWidthLoc = mkRealSrcSpan loc loc + return (L zeroWidthLoc ITsemi) + | newLine && thisCol < col -> + do setALRContext ls + setNextToken t + -- Note that we use lastLoc, as we may need to close + -- more layouts, or give a semicolon + return (L lastLoc ITvccurly) + -- We need to handle close before open, as 'then' is both + -- an open and a close + (u, _, _) + | isALRclose u -> + case context of + ALRLayout _ _ : ls -> + do setALRContext ls + setNextToken t + return (L thisLoc ITvccurly) + ALRNoLayout _ isLet : ls -> + do let ls' = if isALRopen u + then ALRNoLayout (containsCommas u) False : ls + else ls + setALRContext ls' + when isLet $ setJustClosedExplicitLetBlock True + return t + [] -> + do let ls = if isALRopen u + then [ALRNoLayout (containsCommas u) False] + else [] + setALRContext ls + -- XXX This is an error in John's code, but + -- it looks reachable to me at first glance + return t + (u, _, _) + | isALRopen u -> + do setALRContext (ALRNoLayout (containsCommas u) False : context) + return t + (ITin, ALRLayout ALRLayoutLet _ : ls, _) -> + do setALRContext ls + setPendingImplicitTokens [t] + return (L thisLoc ITvccurly) + (ITin, ALRLayout _ _ : ls, _) -> + do setALRContext ls + setNextToken t + return (L thisLoc ITvccurly) + -- the other ITin case omitted; general case below covers it + (ITcomma, ALRLayout _ _ : ls, _) + | topNoLayoutContainsCommas ls -> + do setALRContext ls + setNextToken t + return (L thisLoc ITvccurly) + (ITwhere, ALRLayout ALRLayoutDo _ : ls, _) -> + do setALRContext ls + setPendingImplicitTokens [t] + return (L thisLoc ITvccurly) + -- the other ITwhere case omitted; general case below covers it + (_, _, _) -> return t + +transitionalAlternativeLayoutWarning :: String -> SDoc +transitionalAlternativeLayoutWarning msg + = text "transitional layout will not be accepted in the future:" + $$ text msg + +isALRopen :: Token -> Bool +isALRopen ITcase = True +isALRopen ITif = True +isALRopen ITthen = True +isALRopen IToparen = True +isALRopen ITobrack = True +isALRopen ITocurly = True +-- GHC Extensions: +isALRopen IToubxparen = True +isALRopen ITparenEscape = True +isALRopen ITparenTyEscape = True +isALRopen _ = False + +isALRclose :: Token -> Bool +isALRclose ITof = True +isALRclose ITthen = True +isALRclose ITelse = True +isALRclose ITcparen = True +isALRclose ITcbrack = True +isALRclose ITccurly = True +-- GHC Extensions: +isALRclose ITcubxparen = True +isALRclose _ = False + +isNonDecreasingIndentation :: ALRLayout -> Bool +isNonDecreasingIndentation ALRLayoutDo = True +isNonDecreasingIndentation _ = False + +containsCommas :: Token -> Bool +containsCommas IToparen = True +containsCommas ITobrack = True +-- John doesn't have {} as containing commas, but records contain them, +-- which caused a problem parsing Cabal's Distribution.Simple.InstallDirs +-- (defaultInstallDirs). +containsCommas ITocurly = True +-- GHC Extensions: +containsCommas IToubxparen = True +containsCommas _ = False + +topNoLayoutContainsCommas :: [ALRContext] -> Bool +topNoLayoutContainsCommas [] = False +topNoLayoutContainsCommas (ALRLayout _ _ : ls) = topNoLayoutContainsCommas ls +topNoLayoutContainsCommas (ALRNoLayout b _ : _) = b + +lexToken :: P (RealLocated Token) +lexToken = do + inp@(AI loc1 buf) <- getInput + sc <- getLexState + exts <- getExts + case alexScanUser exts inp sc of + AlexEOF -> do + let span = mkRealSrcSpan loc1 loc1 + setLastToken span 0 + return (L span ITeof) + AlexError (AI loc2 buf) -> + reportLexError loc1 loc2 buf "lexical error" + AlexSkip inp2 _ -> do + setInput inp2 + lexToken + AlexToken inp2@(AI end buf2) _ t -> do + setInput inp2 + let span = mkRealSrcSpan loc1 end + let bytes = byteDiff buf buf2 + span `seq` setLastToken span bytes + lt <- t span buf bytes + case unRealSrcSpan lt of + ITlineComment _ -> return lt + ITblockComment _ -> return lt + lt' -> do + setLastTk lt' + return lt + +reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> [Char] -> P a +reportLexError loc1 loc2 buf str + | atEnd buf = failLocMsgP loc1 loc2 (str ++ " at end of input") + | otherwise = + let c = fst (nextChar buf) + in if c == '\0' -- decoding errors are mapped to '\0', see utf8DecodeChar# + then failLocMsgP loc2 loc2 (str ++ " (UTF-8 decoding error)") + else failLocMsgP loc1 loc2 (str ++ " at character " ++ show c) + +lexTokenStream :: StringBuffer -> RealSrcLoc -> DynFlags -> ParseResult [Located Token] +lexTokenStream buf loc dflags = unP go initState{ options = opts' } + where dflags' = gopt_set (gopt_unset dflags Opt_Haddock) Opt_KeepRawTokenStream + initState@PState{ options = opts } = mkPState dflags' buf loc + opts' = opts{ pExtsBitmap = complement (xbit UsePosPragsBit) .&. pExtsBitmap opts } + go = do + ltok <- lexer False return + case ltok of + L _ ITeof -> return [] + _ -> liftM (ltok:) go + +linePrags = Map.singleton "line" linePrag + +fileHeaderPrags = Map.fromList([("options", lex_string_prag IToptions_prag), + ("options_ghc", lex_string_prag IToptions_prag), + ("options_haddock", lex_string_prag ITdocOptions), + ("language", token ITlanguage_prag), + ("include", lex_string_prag ITinclude_prag)]) + +ignoredPrags = Map.fromList (map ignored pragmas) + where ignored opt = (opt, nested_comment lexToken) + impls = ["hugs", "nhc98", "jhc", "yhc", "catch", "derive"] + options_pragmas = map ("options_" ++) impls + -- CFILES is a hugs-only thing. + pragmas = options_pragmas ++ ["cfiles", "contract"] + +oneWordPrags = Map.fromList [ + ("rules", rulePrag), + ("inline", + strtoken (\s -> (ITinline_prag (SourceText s) Inline FunLike))), + ("inlinable", + strtoken (\s -> (ITinline_prag (SourceText s) Inlinable FunLike))), + ("inlineable", + strtoken (\s -> (ITinline_prag (SourceText s) Inlinable FunLike))), + -- Spelling variant + ("notinline", + strtoken (\s -> (ITinline_prag (SourceText s) NoInline FunLike))), + ("specialize", strtoken (\s -> ITspec_prag (SourceText s))), + ("source", strtoken (\s -> ITsource_prag (SourceText s))), + ("warning", strtoken (\s -> ITwarning_prag (SourceText s))), + ("deprecated", strtoken (\s -> ITdeprecated_prag (SourceText s))), + ("scc", strtoken (\s -> ITscc_prag (SourceText s))), + ("generated", strtoken (\s -> ITgenerated_prag (SourceText s))), + ("core", strtoken (\s -> ITcore_prag (SourceText s))), + ("unpack", strtoken (\s -> ITunpack_prag (SourceText s))), + ("nounpack", strtoken (\s -> ITnounpack_prag (SourceText s))), + ("ann", strtoken (\s -> ITann_prag (SourceText s))), + ("minimal", strtoken (\s -> ITminimal_prag (SourceText s))), + ("overlaps", strtoken (\s -> IToverlaps_prag (SourceText s))), + ("overlappable", strtoken (\s -> IToverlappable_prag (SourceText s))), + ("overlapping", strtoken (\s -> IToverlapping_prag (SourceText s))), + ("incoherent", strtoken (\s -> ITincoherent_prag (SourceText s))), + ("ctype", strtoken (\s -> ITctype (SourceText s))), + ("complete", strtoken (\s -> ITcomplete_prag (SourceText s))), + ("column", columnPrag) + ] + +twoWordPrags = Map.fromList [ + ("inline conlike", + strtoken (\s -> (ITinline_prag (SourceText s) Inline ConLike))), + ("notinline conlike", + strtoken (\s -> (ITinline_prag (SourceText s) NoInline ConLike))), + ("specialize inline", + strtoken (\s -> (ITspec_inline_prag (SourceText s) True))), + ("specialize notinline", + strtoken (\s -> (ITspec_inline_prag (SourceText s) False))) + ] + +dispatch_pragmas :: Map String Action -> Action +dispatch_pragmas prags span buf len = case Map.lookup (clean_pragma (lexemeToString buf len)) prags of + Just found -> found span buf len + Nothing -> lexError "unknown pragma" + +known_pragma :: Map String Action -> AlexAccPred ExtsBitmap +known_pragma prags _ (AI _ startbuf) _ (AI _ curbuf) + = isKnown && nextCharIsNot curbuf pragmaNameChar + where l = lexemeToString startbuf (byteDiff startbuf curbuf) + isKnown = isJust $ Map.lookup (clean_pragma l) prags + pragmaNameChar c = isAlphaNum c || c == '_' + +clean_pragma :: String -> String +clean_pragma prag = canon_ws (map toLower (unprefix prag)) + where unprefix prag' = case stripPrefix "{-#" prag' of + Just rest -> rest + Nothing -> prag' + canonical prag' = case prag' of + "noinline" -> "notinline" + "specialise" -> "specialize" + "constructorlike" -> "conlike" + _ -> prag' + canon_ws s = unwords (map canonical (words s)) + + + +{- +%************************************************************************ +%* * + Helper functions for generating annotations in the parser +%* * +%************************************************************************ +-} + +-- | Encapsulated call to addAnnotation, requiring only the SrcSpan of +-- the AST construct the annotation belongs to; together with the +-- AnnKeywordId, this is the key of the annotation map. +-- +-- This type is useful for places in the parser where it is not yet +-- known what SrcSpan an annotation should be added to. The most +-- common situation is when we are parsing a list: the annotations +-- need to be associated with the AST element that *contains* the +-- list, not the list itself. 'AddAnn' lets us defer adding the +-- annotations until we finish parsing the list and are now parsing +-- the enclosing element; we then apply the 'AddAnn' to associate +-- the annotations. Another common situation is where a common fragment of +-- the AST has been factored out but there is no separate AST node for +-- this fragment (this occurs in class and data declarations). In this +-- case, the annotation belongs to the parent data declaration. +-- +-- The usual way an 'AddAnn' is created is using the 'mj' ("make jump") +-- function, and then it can be discharged using the 'ams' function. +type AddAnn = SrcSpan -> P () + +addAnnotation :: SrcSpan -- SrcSpan of enclosing AST construct + -> AnnKeywordId -- The first two parameters are the key + -> SrcSpan -- The location of the keyword itself + -> P () +addAnnotation l a v = do + addAnnotationOnly l a v + allocateComments l + +addAnnotationOnly :: SrcSpan -> AnnKeywordId -> SrcSpan -> P () +addAnnotationOnly l a v = P $ \s -> POk s { + annotations = ((l,a), [v]) : annotations s + } () + +-- |Given a location and a list of AddAnn, apply them all to the location. +addAnnsAt :: SrcSpan -> [AddAnn] -> P () +addAnnsAt loc anns = mapM_ (\a -> a loc) anns + +-- |Given a 'SrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate +-- 'AddAnn' values for the opening and closing bordering on the start +-- and end of the span +mkParensApiAnn :: SrcSpan -> [AddAnn] +mkParensApiAnn (UnhelpfulSpan _) = [] +mkParensApiAnn s@(RealSrcSpan ss) = [mj AnnOpenP lo,mj AnnCloseP lc] + where + mj a l = (\s -> addAnnotation s a l) + f = srcSpanFile ss + sl = srcSpanStartLine ss + sc = srcSpanStartCol ss + el = srcSpanEndLine ss + ec = srcSpanEndCol ss + lo = mkSrcSpan (srcSpanStart s) (mkSrcLoc f sl (sc+1)) + lc = mkSrcSpan (mkSrcLoc f el (ec - 1)) (srcSpanEnd s) + +queueComment :: Located Token -> P() +queueComment c = P $ \s -> POk s { + comment_q = commentToAnnotation c : comment_q s + } () + +-- | Go through the @comment_q@ in @PState@ and remove all comments +-- that belong within the given span +allocateComments :: SrcSpan -> P () +allocateComments ss = P $ \s -> + let + (before,rest) = break (\(L l _) -> isSubspanOf l ss) (comment_q s) + (middle,after) = break (\(L l _) -> not (isSubspanOf l ss)) rest + comment_q' = before ++ after + newAnns = if null middle then [] + else [(ss,middle)] + in + POk s { + comment_q = comment_q' + , annotations_comments = newAnns ++ (annotations_comments s) + } () + +commentToAnnotation :: Located Token -> Located AnnotationComment +commentToAnnotation (L l (ITdocCommentNext s)) = L l (AnnDocCommentNext s) +commentToAnnotation (L l (ITdocCommentPrev s)) = L l (AnnDocCommentPrev s) +commentToAnnotation (L l (ITdocCommentNamed s)) = L l (AnnDocCommentNamed s) +commentToAnnotation (L l (ITdocSection n s)) = L l (AnnDocSection n s) +commentToAnnotation (L l (ITdocOptions s)) = L l (AnnDocOptions s) +commentToAnnotation (L l (ITlineComment s)) = L l (AnnLineComment s) +commentToAnnotation (L l (ITblockComment s)) = L l (AnnBlockComment s) +commentToAnnotation _ = panic "commentToAnnotation" + +-- --------------------------------------------------------------------- + +isComment :: Token -> Bool +isComment (ITlineComment _) = True +isComment (ITblockComment _) = True +isComment _ = False + +isDocComment :: Token -> Bool +isDocComment (ITdocCommentNext _) = True +isDocComment (ITdocCommentPrev _) = True +isDocComment (ITdocCommentNamed _) = True +isDocComment (ITdocSection _ _) = True +isDocComment (ITdocOptions _) = True +isDocComment _ = False + + +bol,column_prag,layout,layout_do,layout_if,layout_left,line_prag1,line_prag1a,line_prag2,line_prag2a,option_prags :: Int +bol = 1 +column_prag = 2 +layout = 3 +layout_do = 4 +layout_if = 5 +layout_left = 6 +line_prag1 = 7 +line_prag1a = 8 +line_prag2 = 9 +line_prag2a = 10 +option_prags = 11 +alex_action_1 = warnTab +alex_action_2 = nested_comment lexToken +alex_action_3 = lineCommentToken +alex_action_4 = lineCommentToken +alex_action_5 = lineCommentToken +alex_action_6 = lineCommentToken +alex_action_7 = lineCommentToken +alex_action_8 = lineCommentToken +alex_action_10 = begin line_prag1 +alex_action_11 = begin line_prag1 +alex_action_14 = do_bol +alex_action_15 = hopefully_open_brace +alex_action_17 = begin line_prag1 +alex_action_18 = new_layout_context True dontGenerateSemic ITvbar +alex_action_19 = pop +alex_action_20 = new_layout_context True generateSemic ITvocurly +alex_action_21 = new_layout_context False generateSemic ITvocurly +alex_action_22 = do_layout_left +alex_action_23 = begin bol +alex_action_24 = dispatch_pragmas linePrags +alex_action_25 = setLineAndFile line_prag1a +alex_action_26 = failLinePrag1 +alex_action_27 = popLinePrag1 +alex_action_28 = setLineAndFile line_prag2a +alex_action_29 = pop +alex_action_30 = setColumn +alex_action_31 = dispatch_pragmas twoWordPrags +alex_action_32 = dispatch_pragmas oneWordPrags +alex_action_33 = dispatch_pragmas ignoredPrags +alex_action_34 = endPrag +alex_action_35 = dispatch_pragmas fileHeaderPrags +alex_action_36 = nested_comment lexToken +alex_action_37 = warnThen Opt_WarnUnrecognisedPragmas (text "Unrecognised pragma") + (nested_comment lexToken) +alex_action_38 = multiline_doc_comment +alex_action_39 = nested_doc_comment +alex_action_40 = token (ITopenExpQuote NoE NormalSyntax) +alex_action_41 = token (ITopenTExpQuote NoE) +alex_action_42 = token (ITopenExpQuote HasE NormalSyntax) +alex_action_43 = token (ITopenTExpQuote HasE) +alex_action_44 = token ITopenPatQuote +alex_action_45 = layout_token ITopenDecQuote +alex_action_46 = token ITopenTypQuote +alex_action_47 = token (ITcloseQuote NormalSyntax) +alex_action_48 = token ITcloseTExpQuote +alex_action_49 = skip_one_varid ITidEscape +alex_action_50 = skip_two_varid ITidTyEscape +alex_action_51 = token ITparenEscape +alex_action_52 = token ITparenTyEscape +alex_action_53 = lex_quasiquote_tok +alex_action_54 = lex_qquasiquote_tok +alex_action_55 = token (ITopenExpQuote NoE UnicodeSyntax) +alex_action_56 = token (ITcloseQuote UnicodeSyntax) +alex_action_57 = token ITtypeApp +alex_action_58 = special (IToparenbar NormalSyntax) +alex_action_59 = special (ITcparenbar NormalSyntax) +alex_action_60 = special (IToparenbar UnicodeSyntax) +alex_action_61 = special (ITcparenbar UnicodeSyntax) +alex_action_62 = skip_one_varid ITdupipvarid +alex_action_63 = skip_one_varid ITlabelvarid +alex_action_64 = token IToubxparen +alex_action_65 = token ITcubxparen +alex_action_66 = special IToparen +alex_action_67 = special ITcparen +alex_action_68 = special ITobrack +alex_action_69 = special ITcbrack +alex_action_70 = special ITcomma +alex_action_71 = special ITsemi +alex_action_72 = special ITbackquote +alex_action_73 = open_brace +alex_action_74 = close_brace +alex_action_75 = idtoken qvarid +alex_action_76 = idtoken qconid +alex_action_77 = varid +alex_action_78 = idtoken conid +alex_action_79 = idtoken qvarid +alex_action_80 = idtoken qconid +alex_action_81 = varid +alex_action_82 = idtoken conid +alex_action_83 = idtoken qvarsym +alex_action_84 = idtoken qconsym +alex_action_85 = varsym +alex_action_86 = consym +alex_action_87 = tok_num positive 0 0 decimal +alex_action_88 = tok_num positive 2 2 binary +alex_action_89 = tok_num positive 2 2 octal +alex_action_90 = tok_num positive 2 2 hexadecimal +alex_action_91 = tok_num negative 1 1 decimal +alex_action_92 = tok_num negative 3 3 binary +alex_action_93 = tok_num negative 3 3 octal +alex_action_94 = tok_num negative 3 3 hexadecimal +alex_action_95 = tok_frac 0 tok_float +alex_action_96 = tok_frac 0 tok_float +alex_action_97 = tok_frac 0 tok_hex_float +alex_action_98 = tok_frac 0 tok_hex_float +alex_action_99 = tok_primint positive 0 1 decimal +alex_action_100 = tok_primint positive 2 3 binary +alex_action_101 = tok_primint positive 2 3 octal +alex_action_102 = tok_primint positive 2 3 hexadecimal +alex_action_103 = tok_primint negative 1 2 decimal +alex_action_104 = tok_primint negative 3 4 binary +alex_action_105 = tok_primint negative 3 4 octal +alex_action_106 = tok_primint negative 3 4 hexadecimal +alex_action_107 = tok_primword 0 2 decimal +alex_action_108 = tok_primword 2 4 binary +alex_action_109 = tok_primword 2 4 octal +alex_action_110 = tok_primword 2 4 hexadecimal +alex_action_111 = tok_frac 1 tok_primfloat +alex_action_112 = tok_frac 2 tok_primdouble +alex_action_113 = lex_char_tok +alex_action_114 = lex_string_tok +{-# LINE 1 "templates/GenericTemplate.hs" #-} +-- ----------------------------------------------------------------------------- +-- ALEX TEMPLATE +-- +-- This code is in the PUBLIC DOMAIN; you may copy it freely and use +-- it for any purpose whatsoever. + +-- ----------------------------------------------------------------------------- +-- INTERNALS and main scanner engine + + + + + + + + + + + + + + + + + +-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. +#if __GLASGOW_HASKELL__ > 706 +#define GTE(n,m) (tagToEnum# (n >=# m)) +#define EQ(n,m) (tagToEnum# (n ==# m)) +#else +#define GTE(n,m) (n >=# m) +#define EQ(n,m) (n ==# m) +#endif + + + + + + + + + + + + + + + + + + + +data AlexAddr = AlexA# Addr# +-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. +#if __GLASGOW_HASKELL__ < 503 +uncheckedShiftL# = shiftL# +#endif + +{-# INLINE alexIndexInt16OffAddr #-} +alexIndexInt16OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN + narrow16Int# i + where + i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low) + high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + low = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 2# +#else + indexInt16OffAddr# arr off +#endif + + + + + +{-# INLINE alexIndexInt32OffAddr #-} +alexIndexInt32OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN + narrow32Int# i + where + i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#` + (b2 `uncheckedShiftL#` 16#) `or#` + (b1 `uncheckedShiftL#` 8#) `or#` b0) + b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#))) + b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#))) + b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#))) + b0 = int2Word# (ord# (indexCharOffAddr# arr off')) + off' = off *# 4# +#else + indexInt32OffAddr# arr off +#endif + + + + + + +#if __GLASGOW_HASKELL__ < 503 +quickIndex arr i = arr ! i +#else +-- GHC >= 503, unsafeAt is available from Data.Array.Base. +quickIndex = unsafeAt +#endif + + + + +-- ----------------------------------------------------------------------------- +-- Main lexing routines + +data AlexReturn a + = AlexEOF + | AlexError !AlexInput + | AlexSkip !AlexInput !Int + | AlexToken !AlexInput !Int a + +-- alexScan :: AlexInput -> StartCode -> AlexReturn a +alexScan input__ (I# (sc)) + = alexScanUser undefined input__ (I# (sc)) + +alexScanUser user__ input__ (I# (sc)) + = case alex_scan_tkn user__ input__ 0# input__ sc AlexNone of + (AlexNone, input__') -> + case alexGetByte input__ of + Nothing -> + + + + AlexEOF + Just _ -> + + + + AlexError input__' + + (AlexLastSkip input__'' len, _) -> + + + + AlexSkip input__'' len + + (AlexLastAcc k input__''' len, _) -> + + + + AlexToken input__''' len (alex_actions ! k) + + +-- Push the input through the DFA, remembering the most recent accepting +-- state it encountered. + +alex_scan_tkn user__ orig_input len input__ s last_acc = + input__ `seq` -- strict in the input + let + new_acc = (check_accs (alex_accept `quickIndex` (I# (s)))) + in + new_acc `seq` + case alexGetByte input__ of + Nothing -> (new_acc, input__) + Just (c, new_input) -> + + + + case fromIntegral c of { (I# (ord_c)) -> + let + base = alexIndexInt32OffAddr alex_base s + offset = (base +# ord_c) + check = alexIndexInt16OffAddr alex_check offset + + new_s = if GTE(offset,0#) && EQ(check,ord_c) + then alexIndexInt16OffAddr alex_table offset + else alexIndexInt16OffAddr alex_deflt s + in + case new_s of + -1# -> (new_acc, input__) + -- on an error, we want to keep the input *before* the + -- character that failed, not after. + _ -> alex_scan_tkn user__ orig_input (if c < 0x80 || c >= 0xC0 then (len +# 1#) else len) + -- note that the length is increased ONLY if this is the 1st byte in a char encoding) + new_input new_s new_acc + } + where + check_accs (AlexAccNone) = last_acc + check_accs (AlexAcc a ) = AlexLastAcc a input__ (I# (len)) + check_accs (AlexAccSkip) = AlexLastSkip input__ (I# (len)) + + check_accs (AlexAccPred a predx rest) + | predx user__ orig_input (I# (len)) input__ + = AlexLastAcc a input__ (I# (len)) + | otherwise + = check_accs rest + check_accs (AlexAccSkipPred predx rest) + | predx user__ orig_input (I# (len)) input__ + = AlexLastSkip input__ (I# (len)) + | otherwise + = check_accs rest + + +data AlexLastAcc + = AlexNone + | AlexLastAcc !Int !AlexInput !Int + | AlexLastSkip !AlexInput !Int + +data AlexAcc user + = AlexAccNone + | AlexAcc Int + | AlexAccSkip + + | AlexAccPred Int (AlexAccPred user) (AlexAcc user) + | AlexAccSkipPred (AlexAccPred user) (AlexAcc user) + +type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool + +-- ----------------------------------------------------------------------------- +-- Predicates on a rule + +alexAndPred p1 p2 user__ in1 len in2 + = p1 user__ in1 len in2 && p2 user__ in1 len in2 + +--alexPrevCharIsPred :: Char -> AlexAccPred _ +alexPrevCharIs c _ input__ _ _ = c == alexInputPrevChar input__ + +alexPrevCharMatches f _ input__ _ _ = f (alexInputPrevChar input__) + +--alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ +alexPrevCharIsOneOf arr _ input__ _ _ = arr ! alexInputPrevChar input__ + +--alexRightContext :: Int -> AlexAccPred _ +alexRightContext (I# (sc)) user__ _ _ input__ = + case alex_scan_tkn user__ input__ 0# input__ sc AlexNone of + (AlexNone, _) -> False + _ -> True + -- TODO: there's no need to find the longest + -- match when checking the right context, just + -- the first match will do. + diff --git a/ghc-lib/stage0/compiler/build/Parser.hs b/ghc-lib/stage0/compiler/build/Parser.hs new file mode 100644 --- /dev/null +++ b/ghc-lib/stage0/compiler/build/Parser.hs @@ -0,0 +1,10061 @@ +{-# OPTIONS_GHC -w #-} +{-# OPTIONS -XMagicHash -XBangPatterns -XTypeSynonymInstances -XFlexibleInstances -cpp #-} +#if __GLASGOW_HASKELL__ >= 710 +{-# OPTIONS_GHC -XPartialTypeSignatures #-} +#endif +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | This module provides the generated Happy parser for Haskell. It exports +-- a number of parsers which may be used in any library that uses the GHC API. +-- A common usage pattern is to initialize the parser state with a given string +-- and then parse that string: +-- +-- @ +-- runParser :: DynFlags -> String -> P a -> ParseResult a +-- runParser flags str parser = unP parser parseState +-- where +-- filename = "\" +-- location = mkRealSrcLoc (mkFastString filename) 1 1 +-- buffer = stringToStringBuffer str +-- parseState = mkPState flags buffer location +-- @ +module Parser (parseModule, parseSignature, parseImport, parseStatement, parseBackpack, + parseDeclaration, parseExpression, parsePattern, + parseTypeSignature, + parseStmt, parseIdentifier, + parseType, parseHeader) where + +-- base +import Control.Monad ( unless, liftM, when, (<=<) ) +import GHC.Exts +import Data.Char +import Control.Monad ( mplus ) +import Control.Applicative ((<$)) + +-- compiler/hsSyn +import HsSyn + +-- compiler/main +import HscTypes ( IsBootInterface, WarningTxt(..) ) +import DynFlags +import BkpSyn +import PackageConfig + +-- compiler/utils +import OrdList +import BooleanFormula ( BooleanFormula(..), LBooleanFormula(..), mkTrue ) +import FastString +import Maybes ( isJust, orElse ) +import Outputable + +-- compiler/basicTypes +import RdrName +import OccName ( varName, dataName, tcClsName, tvName, startsWithUnderscore ) +import DataCon ( DataCon, dataConName ) +import SrcLoc +import Module +import BasicTypes + +-- compiler/types +import Type ( funTyCon ) +import Kind ( Kind ) +import Class ( FunDep ) + +-- compiler/parser +import RdrHsSyn +import Lexer +import HaddockUtils +import ApiAnnotation + +-- compiler/typecheck +import TcEvidence ( emptyTcEvBinds ) + +-- compiler/prelude +import ForeignCall +import TysPrim ( eqPrimTyCon ) +import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, tupleDataCon, nilDataCon, + unboxedUnitTyCon, unboxedUnitDataCon, + listTyCon_RDR, consDataCon_RDR, eqTyCon_RDR ) + +-- compiler/utils +import Util ( looksLikePackageName, fstOf3, sndOf3, thdOf3 ) +import GhcPrelude +import qualified Data.Array as Happy_Data_Array +import qualified Data.Bits as Bits +import qualified GHC.Exts as Happy_GHC_Exts +import Control.Applicative(Applicative(..)) +import Control.Monad (ap) + +-- parser produced by Happy Version 1.19.9 + +data HappyAbsSyn + = HappyTerminal ((Located Token)) + | HappyErrorToken Int + | HappyAbsSyn16 (Located RdrName) + | HappyAbsSyn17 ([LHsUnit PackageName]) + | HappyAbsSyn18 (OrdList (LHsUnit PackageName)) + | HappyAbsSyn19 (LHsUnit PackageName) + | HappyAbsSyn20 (LHsUnitId PackageName) + | HappyAbsSyn21 (OrdList (LHsModuleSubst PackageName)) + | HappyAbsSyn22 (LHsModuleSubst PackageName) + | HappyAbsSyn23 (LHsModuleId PackageName) + | HappyAbsSyn24 (Located PackageName) + | HappyAbsSyn25 (Located FastString) + | HappyAbsSyn27 (Maybe [LRenaming]) + | HappyAbsSyn28 (OrdList LRenaming) + | HappyAbsSyn29 (LRenaming) + | HappyAbsSyn30 (OrdList (LHsUnitDecl PackageName)) + | HappyAbsSyn32 (LHsUnitDecl PackageName) + | HappyAbsSyn33 (Located (HsModule GhcPs)) + | HappyAbsSyn35 (Maybe LHsDocString) + | HappyAbsSyn36 (()) + | HappyAbsSyn38 (Maybe (Located WarningTxt)) + | HappyAbsSyn39 (([AddAnn] + ,([LImportDecl GhcPs], [LHsDecl GhcPs]))) + | HappyAbsSyn42 (([LImportDecl GhcPs], [LHsDecl GhcPs])) + | HappyAbsSyn44 ([LImportDecl GhcPs]) + | HappyAbsSyn48 ((Maybe (Located [LIE GhcPs]))) + | HappyAbsSyn49 (OrdList (LIE GhcPs)) + | HappyAbsSyn54 (Located ([AddAnn],ImpExpSubSpec)) + | HappyAbsSyn55 (([AddAnn], [Located ImpExpQcSpec])) + | HappyAbsSyn57 (Located ([AddAnn], Located ImpExpQcSpec)) + | HappyAbsSyn58 (Located ImpExpQcSpec) + | HappyAbsSyn60 ([AddAnn]) + | HappyAbsSyn64 (LImportDecl GhcPs) + | HappyAbsSyn65 ((([AddAnn],SourceText),IsBootInterface)) + | HappyAbsSyn66 (([AddAnn],Bool)) + | HappyAbsSyn67 (([AddAnn],Maybe StringLiteral)) + | HappyAbsSyn69 (([AddAnn],Located (Maybe (Located ModuleName)))) + | HappyAbsSyn70 (Located (Maybe (Bool, Located [LIE GhcPs]))) + | HappyAbsSyn71 (Located (Bool, Located [LIE GhcPs])) + | HappyAbsSyn72 (Located (SourceText,Int)) + | HappyAbsSyn73 (Located FixityDirection) + | HappyAbsSyn74 (Located (OrdList (Located RdrName))) + | HappyAbsSyn75 (OrdList (LHsDecl GhcPs)) + | HappyAbsSyn77 (LHsDecl GhcPs) + | HappyAbsSyn78 (LTyClDecl GhcPs) + | HappyAbsSyn80 (LInstDecl GhcPs) + | HappyAbsSyn81 (Maybe (Located OverlapMode)) + | HappyAbsSyn82 (LDerivStrategy GhcPs) + | HappyAbsSyn84 (Maybe (LDerivStrategy GhcPs)) + | HappyAbsSyn85 (Located ([AddAnn], Maybe (LInjectivityAnn GhcPs))) + | HappyAbsSyn86 (LInjectivityAnn GhcPs) + | HappyAbsSyn87 (Located [Located RdrName]) + | HappyAbsSyn88 (Located ([AddAnn],FamilyInfo GhcPs)) + | HappyAbsSyn89 (Located ([AddAnn],Maybe [LTyFamInstEqn GhcPs])) + | HappyAbsSyn90 (Located [LTyFamInstEqn GhcPs]) + | HappyAbsSyn91 (Located ([AddAnn],TyFamInstEqn GhcPs)) + | HappyAbsSyn96 (Located (AddAnn, NewOrData)) + | HappyAbsSyn97 (Located ([AddAnn], Maybe (LHsKind GhcPs))) + | HappyAbsSyn98 (Located ([AddAnn], LFamilyResultSig GhcPs)) + | HappyAbsSyn100 (Located ([AddAnn], ( LFamilyResultSig GhcPs + , Maybe (LInjectivityAnn GhcPs)))) + | HappyAbsSyn101 (Located (Maybe (LHsContext GhcPs), LHsType GhcPs)) + | HappyAbsSyn102 (Located ([AddAnn],(Maybe (LHsContext GhcPs), Maybe [LHsTyVarBndr GhcPs], LHsType GhcPs))) + | HappyAbsSyn103 (Maybe (Located CType)) + | HappyAbsSyn104 (LDerivDecl GhcPs) + | HappyAbsSyn105 (LRoleAnnotDecl GhcPs) + | HappyAbsSyn106 (Located [Located (Maybe FastString)]) + | HappyAbsSyn108 (Located (Maybe FastString)) + | HappyAbsSyn110 ((Located RdrName, HsPatSynDetails (Located RdrName), [AddAnn])) + | HappyAbsSyn111 ([Located RdrName]) + | HappyAbsSyn112 ([RecordPatSynField (Located RdrName)]) + | HappyAbsSyn113 (Located ([AddAnn] + , Located (OrdList (LHsDecl GhcPs)))) + | HappyAbsSyn114 (LSig GhcPs) + | HappyAbsSyn116 (Located ([AddAnn],OrdList (LHsDecl GhcPs))) + | HappyAbsSyn117 (Located ([AddAnn] + , OrdList (LHsDecl GhcPs))) + | HappyAbsSyn118 (Located ([AddAnn] + ,(OrdList (LHsDecl GhcPs)))) + | HappyAbsSyn119 (Located (OrdList (LHsDecl GhcPs))) + | HappyAbsSyn122 (Located ([AddAnn] + , OrdList (LHsDecl GhcPs))) + | HappyAbsSyn124 (Located ([AddAnn],Located (OrdList (LHsDecl GhcPs)))) + | HappyAbsSyn125 (Located ([AddAnn],Located (HsLocalBinds GhcPs))) + | HappyAbsSyn127 (OrdList (LRuleDecl GhcPs)) + | HappyAbsSyn128 (LRuleDecl GhcPs) + | HappyAbsSyn129 (([AddAnn],Maybe Activation)) + | HappyAbsSyn130 (([AddAnn] + ,Activation)) + | HappyAbsSyn131 (([AddAnn], Maybe [LHsTyVarBndr GhcPs], [LRuleBndr GhcPs])) + | HappyAbsSyn132 ([LRuleTyTmVar]) + | HappyAbsSyn133 (LRuleTyTmVar) + | HappyAbsSyn134 (OrdList (LWarnDecl GhcPs)) + | HappyAbsSyn138 (Located ([AddAnn],[Located StringLiteral])) + | HappyAbsSyn139 (Located (OrdList (Located StringLiteral))) + | HappyAbsSyn141 (Located ([AddAnn],HsDecl GhcPs)) + | HappyAbsSyn142 (Located CCallConv) + | HappyAbsSyn143 (Located Safety) + | HappyAbsSyn144 (Located ([AddAnn] + ,(Located StringLiteral, Located RdrName, LHsSigType GhcPs))) + | HappyAbsSyn145 (([AddAnn], Maybe (LHsType GhcPs))) + | HappyAbsSyn146 (([AddAnn], Maybe (Located RdrName))) + | HappyAbsSyn147 (LHsType GhcPs) + | HappyAbsSyn150 ((OrdList (LHsSigType GhcPs))) + | HappyAbsSyn151 (Located ([AddAnn], SourceText, SrcUnpackedness)) + | HappyAbsSyn152 ((AddAnn, ForallVisFlag)) + | HappyAbsSyn157 (LHsContext GhcPs) + | HappyAbsSyn162 (Located [Located TyEl]) + | HappyAbsSyn163 (Located TyEl) + | HappyAbsSyn165 ([Located TyEl]) + | HappyAbsSyn168 (LHsSigType GhcPs) + | HappyAbsSyn169 ([LHsSigType GhcPs]) + | HappyAbsSyn170 ([LHsType GhcPs]) + | HappyAbsSyn173 ([LHsTyVarBndr GhcPs]) + | HappyAbsSyn174 (LHsTyVarBndr GhcPs) + | HappyAbsSyn175 (Located ([AddAnn],[Located (FunDep (Located RdrName))])) + | HappyAbsSyn176 (Located [Located (FunDep (Located RdrName))]) + | HappyAbsSyn177 (Located (FunDep (Located RdrName))) + | HappyAbsSyn179 (LHsKind GhcPs) + | HappyAbsSyn180 (Located ([AddAnn] + ,[LConDecl GhcPs])) + | HappyAbsSyn181 (Located [LConDecl GhcPs]) + | HappyAbsSyn182 (LConDecl GhcPs) + | HappyAbsSyn184 (Located ([AddAnn],[LConDecl GhcPs])) + | HappyAbsSyn187 (Located ([AddAnn], Maybe [LHsTyVarBndr GhcPs])) + | HappyAbsSyn188 (Located (Located RdrName, HsConDeclDetails GhcPs, Maybe LHsDocString)) + | HappyAbsSyn189 ([LConDeclField GhcPs]) + | HappyAbsSyn191 (LConDeclField GhcPs) + | HappyAbsSyn192 (HsDeriving GhcPs) + | HappyAbsSyn194 (LHsDerivingClause GhcPs) + | HappyAbsSyn195 (Located [LHsSigType GhcPs]) + | HappyAbsSyn197 (LDocDecl) + | HappyAbsSyn200 (Located ([AddAnn],GRHSs GhcPs (LHsExpr GhcPs))) + | HappyAbsSyn201 (Located [LGRHS GhcPs (LHsExpr GhcPs)]) + | HappyAbsSyn202 (LGRHS GhcPs (LHsExpr GhcPs)) + | HappyAbsSyn205 (([AddAnn],Activation)) + | HappyAbsSyn206 (Located (HsSplice GhcPs)) + | HappyAbsSyn207 (ExpCmdP) + | HappyAbsSyn209 (LHsExpr GhcPs) + | HappyAbsSyn212 (([Located Token],Bool)) + | HappyAbsSyn213 (Located (([AddAnn],SourceText),StringLiteral)) + | HappyAbsSyn214 (Located ( (([AddAnn],SourceText),(StringLiteral,(Int,Int),(Int,Int))), + ((SourceText,SourceText),(SourceText,SourceText)) + )) + | HappyAbsSyn222 ([LHsCmdTop GhcPs]) + | HappyAbsSyn223 (LHsCmdTop GhcPs) + | HappyAbsSyn224 (([AddAnn],[LHsDecl GhcPs])) + | HappyAbsSyn225 ([LHsDecl GhcPs]) + | HappyAbsSyn227 (([AddAnn],SumOrTuple)) + | HappyAbsSyn228 ((SrcSpan,[LHsTupArg GhcPs])) + | HappyAbsSyn229 ([LHsTupArg GhcPs]) + | HappyAbsSyn230 (([AddAnn],HsExpr GhcPs)) + | HappyAbsSyn231 (Located [LHsExpr GhcPs]) + | HappyAbsSyn232 (Located [LStmt GhcPs (LHsExpr GhcPs)]) + | HappyAbsSyn233 (Located [[LStmt GhcPs (LHsExpr GhcPs)]]) + | HappyAbsSyn235 (Located ([AddAnn],[LStmt GhcPs (LHsExpr GhcPs)] -> Stmt GhcPs (LHsExpr GhcPs))) + | HappyAbsSyn238 (forall b. ExpCmdI b => PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))]))) + | HappyAbsSyn241 (forall b. ExpCmdI b => PV (LMatch GhcPs (Located (b GhcPs)))) + | HappyAbsSyn242 (forall b. ExpCmdI b => PV (Located ([AddAnn],GRHSs GhcPs (Located (b GhcPs))))) + | HappyAbsSyn243 (forall b. ExpCmdI b => PV (Located [LGRHS GhcPs (Located (b GhcPs))])) + | HappyAbsSyn245 (Located ([AddAnn],[LGRHS GhcPs (LHsExpr GhcPs)])) + | HappyAbsSyn246 (forall b. ExpCmdI b => PV (LGRHS GhcPs (Located (b GhcPs)))) + | HappyAbsSyn247 (LPat GhcPs) + | HappyAbsSyn250 ([LPat GhcPs]) + | HappyAbsSyn251 (forall b. ExpCmdI b => PV (Located ([AddAnn],[LStmt GhcPs (Located (b GhcPs))]))) + | HappyAbsSyn253 (Maybe (LStmt GhcPs (LHsExpr GhcPs))) + | HappyAbsSyn254 (LStmt GhcPs (LHsExpr GhcPs)) + | HappyAbsSyn255 (forall b. ExpCmdI b => PV (LStmt GhcPs (Located (b GhcPs)))) + | HappyAbsSyn257 (([AddAnn],([LHsRecField GhcPs (LHsExpr GhcPs)], Maybe SrcSpan))) + | HappyAbsSyn259 (LHsRecField GhcPs (LHsExpr GhcPs)) + | HappyAbsSyn260 (Located [LIPBind GhcPs]) + | HappyAbsSyn261 (LIPBind GhcPs) + | HappyAbsSyn262 (Located HsIPName) + | HappyAbsSyn264 (LBooleanFormula (Located RdrName)) + | HappyAbsSyn267 ([LBooleanFormula (Located RdrName)]) + | HappyAbsSyn276 (Located DataCon) + | HappyAbsSyn315 (Located (HsLit GhcPs)) + | HappyAbsSyn317 (Located ModuleName) + | HappyAbsSyn318 (([SrcSpan],Int)) + | HappyAbsSyn321 (LHsDocString) + | HappyAbsSyn323 (Located (String, HsDocString)) + | HappyAbsSyn324 (Located (Int, HsDocString)) + +happyExpList :: HappyAddr +happyExpList = HappyA# "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc7\x1f\x1c\x00\x40\xd0\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x7f\xf3\x55\xff\xff\xe5\xff\x7e\x06\x41\xd0\x00\x88\x0a\x67\xfe\xff\x5f\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\x50\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\xd0\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x73\x11\xfd\xff\xe5\xff\x1c\x04\x41\x50\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc7\x1f\x1c\x00\x40\xd0\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfd\xfe\x84\x1f\x00\x00\x08\xc0\x21\x88\x82\xfe\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfd\xfe\x84\x1f\x00\x00\x00\x00\x00\x80\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x21\x00\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfc\xf8\x84\x1f\x00\x00\x00\x00\x00\x80\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfc\xf8\x84\x1f\x00\x00\x00\x00\x81\x88\x02\x47\x30\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x98\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd4\xe1\x88\xc3\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\xc6\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfc\xf8\x84\x1f\x00\x00\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfd\xfe\x84\x1f\x00\x00\x08\xc0\x21\x88\x82\x5e\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\x50\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\xd4\x21\x00\x41\x98\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfd\xfe\x84\x1f\x00\x00\x00\x00\x00\x00\x00\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\x50\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\x50\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\x50\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\x51\x80\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\x85\x1f\x00\x00\x40\x10\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\x85\x1f\x00\x00\x40\x10\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\x85\x1f\x00\x00\xc0\x90\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\x85\x1f\x00\x00\x40\x10\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x00\x00\x40\x10\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\x85\x1f\x00\x00\x40\x10\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x48\xd0\x21\x98\x8a\xff\xff\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x48\xd1\x21\x88\xcb\xff\xff\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x48\xd1\x21\x88\xce\xff\xff\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xfe\x84\x1f\x00\x00\x00\x00\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfd\xfe\x84\x1f\x00\x00\x00\x00\x00\x88\x02\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\x50\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\x50\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\x50\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\x50\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\xc0\x21\x00\x80\x98\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x02\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfd\xfe\x84\x1f\x00\x00\x00\x00\x00\x80\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfd\xfe\x84\x1f\x00\x00\x00\x00\x00\x88\x02\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x02\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x48\xd1\x21\x88\xcb\xff\xff\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\x85\x1f\x00\x00\x40\x10\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\xc0\x21\x00\x80\x98\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfc\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x80\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x81\x10\xfc\xfe\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfd\xfe\x84\x1f\x00\x00\x00\x00\x00\x88\x02\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfd\xfe\x84\x1f\x00\x00\x00\x00\x00\x88\x02\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfd\xfe\x84\x1f\x00\x00\x00\x00\x00\x88\x02\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x52\xfd\xfe\x84\x1f\x00\x00\x00\x00\x00\x88\x02\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\x85\x1f\x00\x00\x40\x10\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\x85\x1f\x00\x00\x40\x10\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\x85\x1f\x00\x00\x40\x10\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\xc0\x21\x00\x41\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfd\xfe\x84\x1f\x00\x00\x00\x00\x80\x00\x40\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x80\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x41\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfc\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfc\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfc\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x14\x00\x40\x50\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x20\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xfe\x84\x1f\x00\x00\x00\x00\x00\x00\x00\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfc\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\xc0\x3f\x00\x80\x98\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\x50\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x48\xd0\x21\x88\xca\xff\xff\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x48\xd1\x21\x88\x8a\xff\xff\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x00\x00\x40\x10\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xfe\x84\x1f\x00\x00\x00\x00\x00\x00\x00\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfd\xfe\x84\x1f\x00\x00\x08\xc0\x21\x88\x43\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfd\xfe\x84\x1f\x00\x00\x00\x00\x00\x80\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfd\xfe\x84\x1f\x00\x00\x00\x00\x00\x80\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfd\xfe\x84\x1f\x00\x00\x00\x00\x00\x80\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x73\x11\xfd\xff\xe5\xff\x1c\x04\x41\xd0\x00\x88\x0a\x67\xfe\xff\x5f\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x73\x11\xfd\xff\xe5\xff\x1c\x04\x41\xd0\x00\x88\x0a\x67\xfe\xff\x5f\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfd\xfe\x84\x1f\x00\x00\x00\x00\x00\x80\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x20\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\xd4\x21\x00\x80\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\xd4\x20\x00\x41\x98\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\xc0\x21\x00\x80\x98\x01\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\xc0\x21\x00\x41\x98\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x48\xd0\x21\x88\xca\xff\xff\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x01\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\x85\x1f\x00\x00\x40\x90\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\x85\x1f\x00\x00\x40\x10\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc7\x1f\x1c\x00\x40\xd0\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc7\x1f\x1c\x00\x40\xd0\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\xd0\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\x85\x1f\x00\x00\x40\x10\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\x50\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfd\xfe\x84\x1f\x00\x00\x04\x00\x00\x80\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfc\xf8\x84\x1f\x00\x00\x00\x00\x81\x88\x02\x47\x30\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\x50\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\x50\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\x50\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\x50\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\x50\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\xc3\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfd\xfe\x84\x1f\x00\x00\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfd\xfe\x84\x1f\x00\x00\x00\x00\x00\x80\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfd\xfe\x84\x1f\x00\x00\x00\x00\x00\x88\x02\x46\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfc\xf8\x84\x1f\x00\x00\x00\x00\x00\x80\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfc\xf8\x84\x1f\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfc\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\x1c\xf8\x84\x1f\x00\x00\x00\x00\x00\x00\x00\x06\x10\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x21\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\x50\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\x50\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\x50\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\xd0\x00\x89\x2a\x67\xfe\x1f\x5e\x7f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\xd0\x00\x8c\x2a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\x85\x1f\x00\x00\x40\x90\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x48\xd0\x21\x88\x8a\xff\xff\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\x50\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x31\xfd\xff\xc5\x1f\x1c\x00\x40\xd0\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x48\xd0\x21\x88\x8a\xff\xff\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x48\xd0\x21\x88\xca\xff\xff\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xfe\x84\x1f\x00\x00\x00\x00\x00\x88\x1a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x7f\xf3\x55\xff\xff\xe5\xff\x7e\x06\x41\xd0\x00\x88\x0a\x67\xfe\xff\x5f\x7f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfd\xfe\x84\x1f\x00\x00\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfc\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfc\xf8\x84\x1f\x00\x00\x00\x00\x00\x80\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x40\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\xc0\x21\x00\x80\x98\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfd\xfe\x84\x1f\x00\x00\x00\x00\x00\x88\x02\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfd\xfe\x84\x1f\x00\x00\x00\x00\x00\x88\x02\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x02\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x02\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\xc0\x21\x00\x80\x98\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\x50\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x48\xd0\x21\x88\x8a\xff\xff\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfc\xf8\x84\x1f\x00\x00\x00\x00\x00\x80\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\x50\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\xd0\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfc\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\xd0\x20\x00\x00\x98\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfc\xf8\x84\x1f\x00\x00\x00\x00\x00\x80\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x20\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfd\xfe\x84\x1f\x00\x00\x00\x00\x00\x80\x00\x02\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfd\xfe\x84\x1f\x00\x00\x00\x00\x00\x80\x00\x02\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfd\xfe\x84\x1f\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x20\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfd\xfe\x84\x1f\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfd\xfe\x84\x1f\x00\x00\x00\x00\x00\x80\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\xd0\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\xd0\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfd\xfe\x84\x1f\x00\x00\x00\x00\x00\x88\x02\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfd\xfe\x84\x1f\x00\x00\x00\x00\x00\x88\x02\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfd\xfe\x84\x1f\x00\x00\x00\x00\x00\x88\x02\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\x85\x1f\x00\x00\x40\x10\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x7f\xf3\x55\xff\xff\xe5\xff\x7e\x06\x41\xd0\x00\x88\x0a\x67\xfe\xff\x5f\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\x50\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfd\xfe\x84\x1f\x00\x00\x00\x00\x00\x80\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfd\xfe\x84\x1f\x00\x00\x00\x00\x00\x80\x00\x02\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfd\xfe\x84\x1f\x00\x00\x00\x00\x00\x80\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfc\xf8\x84\x1f\x00\x00\x00\x00\x00\x80\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfc\xf8\x84\x1f\x00\x00\x00\x04\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfc\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x20\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x20\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfc\xf8\x84\x1f\x00\x00\x00\x00\x00\x80\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x73\x11\xfd\xff\xe5\xff\x1c\x04\x41\xd0\x00\x88\x0a\x67\xfe\xff\x5f\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\x50\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x20\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfd\xfe\x84\x1f\x00\x00\x00\x00\x00\x80\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfc\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x20\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x20\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\xd4\x21\x00\x80\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\x50\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\x50\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\xd0\x00\x88\x2a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc7\x1f\x1c\x00\x40\xd0\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\x50\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\xd0\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\x50\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x48\xd0\x21\x88\x8a\xff\xff\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfd\xfe\x84\x1f\x00\x00\x04\x00\x00\x80\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\x1c\xf8\x84\x1f\x00\x00\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\x50\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\xd0\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x31\xfd\xff\xc5\x1f\x1c\x00\x40\xd0\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x31\xfd\xff\xc5\x1f\x1c\x00\x40\xd0\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\x50\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x20\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x20\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfc\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x80\x01\x00\x00\x00\x00\x00\x80\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x20\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x20\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\x50\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x5b\x73\x51\xfd\xff\xe5\xff\x1c\x04\x41\xd0\x00\x88\x0a\x67\xfe\xff\x5f\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x5b\x73\x51\xfd\xff\xe5\xff\x1c\x04\x41\xd0\x00\x88\x0a\x67\xfe\xff\x5f\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x4b\x73\x55\xfd\xff\xe5\xff\x1c\x04\x41\xd0\x00\x88\x0a\x67\xfe\xff\x5f\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x4b\x73\x55\xfd\xff\xe5\xff\x1c\x04\x41\xd0\x00\x88\x0a\x67\xfe\xff\x5f\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfc\xf8\x84\x1f\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfc\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x20\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfd\xfe\x84\x1f\x00\x00\x00\x00\x00\x80\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfd\xfe\x84\x1f\x00\x00\x00\x00\x00\x80\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfd\xfe\x84\x1f\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\xc0\x21\x00\x80\x98\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\x50\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x73\x11\xfd\xff\xe5\xff\x1c\x04\x41\xd0\x00\x88\x0a\x67\xfe\xff\x5f\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x73\x11\xfd\xff\xe5\xff\x1c\x04\x41\xd0\x00\x88\x0a\x67\xfe\xff\x5f\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x20\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfc\xf8\x84\x1f\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\x50\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x81\x10\xfd\xfa\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x02\x04\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x02\x04\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfc\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x83\xdf\x31\x20\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfc\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\x50\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\x50\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\x50\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\x1c\xf8\x84\x1f\x00\x00\x00\x00\x00\x00\x00\x06\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x52\xfd\xfe\xa4\x1f\x00\x00\x00\x00\x00\x80\x40\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x02\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\xd0\x21\x00\x00\x98\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\x1c\xf8\x84\x1f\x00\x00\x00\x00\x00\x00\x00\x06\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\x50\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfc\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x31\x40\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfc\xf8\x84\x1f\x00\x00\x00\x00\x00\x80\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x5b\x73\x51\xfd\xff\xe5\xff\x1c\x04\x41\xd0\x00\x88\x0a\x67\xfe\xff\x5f\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfc\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\xc0\x21\x00\x80\x98\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfc\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x4b\x73\x55\xfd\xff\xe5\xff\x1c\x04\x41\xd0\x00\x88\x0a\x67\xfe\xff\x5f\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x0c\xd0\xe1\x88\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x0c\xd0\xe1\x88\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfc\xf8\x84\x1f\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfd\xfe\x84\x1f\x00\x00\x00\x00\x00\x80\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfc\xf8\x84\x1f\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x20\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x02\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x33\x20\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x02\x04\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfc\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x31\x20\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfc\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x31\x40\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfc\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x43\x03\x11\xfd\xff\xc5\x1f\x1c\x00\x40\x50\x00\x88\x0a\x67\xfe\x1f\x5e\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x41\x10\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x50\xfd\xfe\x84\x1f\x00\x00\x04\x00\x00\x80\x00\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfc\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x31\x40\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd4\xe1\x88\xc3\xdf\x33\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfc\xf8\x84\x1f\x00\x00\x00\x00\x00\x80\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfd\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x31\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\xfc\xf8\x84\x1f\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x01\x01\x10\xfc\xf8\x84\x1f\x80\x01\x08\xd0\xe1\x88\x82\xdf\x31\x40\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x10\x1c\xf8\x84\x1f\x00\x00\x00\x00\x00\x00\x00\x0e\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x50\xfd\xfe\x84\x1f\x00\x00\x04\x00\x00\x80\x00\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x01\x52\xfd\xfe\xa4\x1f\x00\x00\x00\x00\x00\x80\x00\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +{-# NOINLINE happyExpListPerState #-} +happyExpListPerState st = + token_strs_expected + where token_strs = ["error","%dummy","%start_parseModule","%start_parseSignature","%start_parseImport","%start_parseStatement","%start_parseDeclaration","%start_parseExpression","%start_parsePattern","%start_parseTypeSignature","%start_parseStmt","%start_parseIdentifier","%start_parseType","%start_parseBackpack","%start_parseHeader","identifier","backpack","units","unit","unitid","msubsts","msubst","moduleid","pkgname","litpkgname_segment","litpkgname","mayberns","rns","rn","unitbody","unitdecls","unitdecl","signature","module","maybedocheader","missing_module_keyword","implicit_top","maybemodwarning","body","body2","top","top1","header","header_body","header_body2","header_top","header_top_importdecls","maybeexports","exportlist","exportlist1","expdoclist","exp_doc","export","export_subspec","qcnames","qcnames1","qcname_ext_w_wildcard","qcname_ext","qcname","semis1","semis","importdecls","importdecls_semi","importdecl","maybe_src","maybe_safe","maybe_pkg","optqualified","maybeas","maybeimpspec","impspec","prec","infix","ops","topdecls","topdecls_semi","topdecl","cl_decl","ty_decl","inst_decl","overlap_pragma","deriv_strategy_no_via","deriv_strategy_via","deriv_standalone_strategy","opt_injective_info","injectivity_cond","inj_varids","where_type_family","ty_fam_inst_eqn_list","ty_fam_inst_eqns","ty_fam_inst_eqn","at_decl_cls","opt_family","opt_instance","at_decl_inst","data_or_newtype","opt_kind_sig","opt_datafam_kind_sig","opt_tyfam_kind_sig","opt_at_kind_inj_sig","tycl_hdr","tycl_hdr_inst","capi_ctype","stand_alone_deriving","role_annot","maybe_roles","roles","role","pattern_synonym_decl","pattern_synonym_lhs","vars0","cvars1","where_decls","pattern_synonym_sig","decl_cls","decls_cls","decllist_cls","where_cls","decl_inst","decls_inst","decllist_inst","where_inst","decls","decllist","binds","wherebinds","rules","rule","rule_activation","rule_explicit_activation","rule_foralls","rule_vars","rule_var","warnings","warning","deprecations","deprecation","strings","stringlist","annotation","fdecl","callconv","safety","fspec","opt_sig","opt_tyconsig","sigtype","sigtypedoc","sig_vars","sigtypes1","unpackedness","forall_vis_flag","ktype","ktypedoc","ctype","ctypedoc","context","constr_context","type","typedoc","constr_btype","constr_tyapps","constr_tyapp","btype","tyapps","tyapp","atype","inst_type","deriv_types","comma_types0","comma_types1","bar_types2","tv_bndrs","tv_bndr","fds","fds1","fd","varids0","kind","gadt_constrlist","gadt_constrs","gadt_constr_with_doc","gadt_constr","constrs","constrs1","constr","forall","constr_stuff","fielddecls","fielddecls1","fielddecl","maybe_derivings","derivings","deriving","deriv_clause_types","docdecl","docdecld","decl_no_th","decl","rhs","gdrhs","gdrh","sigdecl","activation","explicit_activation","quasiquote","exp","infixexp","infixexp_top","exp10_top","exp10","optSemi","scc_annot","hpc_annot","fexp","aexp","aexp1","aexp2","splice_exp","splice_untyped","splice_typed","cmdargs","acmd","cvtopbody","cvtopdecls0","texp","tup_exprs","commas_tup_tail","tup_tail","list","lexps","flattenedpquals","pquals","squals","transformqual","guardquals","guardquals1","altslist","alts","alts1","alt","alt_rhs","ralt","gdpats","ifgdpats","gdpat","pat","bindpat","apat","apats","stmtlist","stmts","maybe_stmt","e_stmt","stmt","qual","fbinds","fbinds1","fbind","dbinds","dbind","ipvar","overloaded_label","name_boolformula_opt","name_boolformula","name_boolformula_and","name_boolformula_and_list","name_boolformula_atom","namelist","name_var","qcon_nowiredlist","qcon","gen_qcon","con","con_list","sysdcon_nolist","sysdcon","conop","qconop","gtycon","ntgtycon","oqtycon","oqtycon_no_varcon","qtyconop","qtycon","qtycondoc","tycon","qtyconsym","tyconsym","op","varop","qop","qopm","hole_op","qvarop","qvaropm","tyvar","tyvarop","tyvarid","var","qvar","qvarid","varid","qvarsym","qvarsym_no_minus","qvarsym1","varsym","varsym_no_minus","special_id","special_sym","qconid","conid","qconsym","consym","literal","close","modid","commas","bars0","bars","docnext","docprev","docnamed","docsection","moduleheader","maybe_docprev","maybe_docnext","'_'","'as'","'case'","'class'","'data'","'default'","'deriving'","'do'","'else'","'hiding'","'if'","'import'","'in'","'infix'","'infixl'","'infixr'","'instance'","'let'","'module'","'newtype'","'of'","'qualified'","'then'","'type'","'where'","'forall'","'foreign'","'export'","'label'","'dynamic'","'safe'","'interruptible'","'unsafe'","'mdo'","'family'","'role'","'stdcall'","'ccall'","'capi'","'prim'","'javascript'","'proc'","'rec'","'group'","'by'","'using'","'pattern'","'static'","'stock'","'anyclass'","'via'","'unit'","'signature'","'dependency'","'{-# INLINE'","'{-# SPECIALISE'","'{-# SPECIALISE_INLINE'","'{-# SOURCE'","'{-# RULES'","'{-# CORE'","'{-# SCC'","'{-# GENERATED'","'{-# DEPRECATED'","'{-# WARNING'","'{-# UNPACK'","'{-# NOUNPACK'","'{-# ANN'","'{-# MINIMAL'","'{-# CTYPE'","'{-# OVERLAPPING'","'{-# OVERLAPPABLE'","'{-# OVERLAPS'","'{-# INCOHERENT'","'{-# COMPLETE'","'#-}'","'..'","':'","'::'","'='","'\\\\'","'lcase'","'|'","'<-'","'->'","'@'","'~'","'=>'","'-'","'!'","'*'","'-<'","'>-'","'-<<'","'>>-'","'.'","TYPEAPP","'{'","'}'","vocurly","vccurly","'['","']'","'[:'","':]'","'('","')'","'(#'","'#)'","'(|'","'|)'","';'","','","'`'","SIMPLEQUOTE","VARID","CONID","VARSYM","CONSYM","QVARID","QCONID","QVARSYM","QCONSYM","IPDUPVARID","LABELVARID","CHAR","STRING","INTEGER","RATIONAL","PRIMCHAR","PRIMSTRING","PRIMINTEGER","PRIMWORD","PRIMFLOAT","PRIMDOUBLE","DOCNEXT","DOCPREV","DOCNAMED","DOCSECTION","'[|'","'[p|'","'[t|'","'[d|'","'|]'","'[||'","'||]'","TH_ID_SPLICE","'$('","TH_ID_TY_SPLICE","'$$('","TH_TY_QUOTE","TH_QUASIQUOTE","TH_QQUASIQUOTE","%eof"] + bit_start = st * 480 + bit_end = (st + 1) * 480 + read_bit = readArrayBit happyExpList + bits = map read_bit [bit_start..bit_end - 1] + bits_indexed = zip bits [0..479] + token_strs_expected = concatMap f bits_indexed + f (False, _) = [] + f (True, nr) = [token_strs !! nr] + +happyActOffsets :: HappyAddr +happyActOffsets = HappyA# "\x43\x00\x20\x00\xc8\x00\xfa\x24\x4a\x1a\x1a\x2c\x22\x29\x32\x23\xfa\x24\xa9\x43\x7a\x39\x7c\x00\x52\x00\xa9\x46\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x04\x00\x00\x00\x00\xc0\x01\x00\x00\xe4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x05\x01\x05\x01\x00\x00\xbc\x00\x13\x01\x0f\x01\x00\x00\x15\x02\xe9\x41\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbd\x4a\x00\x00\x00\x00\x00\x00\x5d\x01\x7c\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x68\x42\x11\x00\x84\x34\x07\x33\x86\x33\x43\x46\x0e\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x2c\x00\x00\x00\x00\x3f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x01\x32\x09\x31\x03\xa9\x45\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xac\x01\x98\x0a\x00\x00\x00\x00\x1a\x2c\x1a\x2c\x12\x2f\x00\x00\xb8\x01\x00\x00\x00\x00\x00\x00\x00\x00\xf4\x01\xb7\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x02\x00\x00\x00\x00\x1a\x2c\x9d\x00\x92\x25\xcd\x01\xc5\x02\x72\x31\xc5\x02\x72\x31\x02\x02\x33\x02\x14\x02\x7a\x2e\x72\x31\xaa\x2f\x72\x31\xd2\x20\xda\x1d\x72\x1e\x80\x32\x13\x45\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x2c\x1a\x2c\x7a\x39\x70\x04\x1a\x2c\x00\x00\x1a\x2c\xdf\x45\x40\x02\x00\x00\x2e\x02\xb4\x0b\x00\x00\x67\x02\xa5\x02\x00\x00\x00\x00\x00\x00\x0d\x05\xb5\x03\xa0\x02\x4d\x00\xa0\x02\xa9\x46\x8b\x48\xb5\x03\x0a\x1f\x00\x00\xbf\x02\x72\x31\xbf\x02\xbf\x02\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x0a\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x41\x43\x03\xb4\x02\x8b\x02\xf4\x05\x00\x00\x03\x35\x7f\x00\xc6\x48\xf1\x02\xf3\x48\xf3\x48\x5e\x48\x72\x31\x00\x00\x00\x00\x00\x00\x00\x00\xf0\x02\x00\x00\xf0\x02\x56\x03\x00\x03\x67\x03\x0c\x03\x95\x03\x00\x00\x00\x00\x00\x00\x69\x03\x92\x03\x5c\x00\x55\x03\x55\x03\xb7\x03\xbb\x03\x55\x02\x72\x31\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x72\x31\xb6\x03\xe6\x03\x2e\x00\x00\x00\x3c\x00\xd9\x03\xcf\x00\x00\x00\x3c\x00\xd2\x00\x00\x00\x01\x04\xee\x03\xc3\x49\x2b\x04\x76\x01\xd5\x02\x00\x00\x9d\x05\x9d\x05\x21\x04\x2a\x04\x72\x3d\xe9\x41\x42\x02\x7a\x39\x3c\x04\x3f\x04\x4a\x04\x6d\x04\x00\x00\x81\x04\x00\x00\x00\x00\x00\x00\xe9\x41\x7a\x39\xe9\x41\x88\x04\x68\x04\x00\x00\x55\x02\x00\x00\xe2\x2d\x00\x00\x00\x00\x82\x35\x73\x44\xe9\x41\x7d\x04\x4d\x04\x00\x00\x8c\x04\x98\x0a\xb6\x01\x8f\x04\x00\x00\x1a\x2c\x00\x00\x00\x00\x00\x00\x94\x04\x97\x04\xa6\x04\xaf\x04\xa2\x1f\x6a\x21\x00\x00\xaa\x2f\x00\x00\x00\x00\x73\x44\x73\x04\xd1\x04\xd7\x04\x00\x00\xda\x04\x00\x00\xb9\x04\x00\x00\xd6\x46\x2c\x00\xa9\x46\x00\x00\x1f\x01\xa9\x46\x7a\x39\xa9\x46\x00\x00\x3c\x05\x42\x1d\x42\x1d\x09\x4a\x01\x36\xc4\x04\x00\x00\x00\x00\x00\x00\x00\x00\xd5\x04\xb7\x05\xf8\x03\xe6\x04\xc5\x04\xd9\x04\x00\x00\x00\x00\xf7\x04\x50\x04\x06\x05\x00\x00\x00\x00\x94\x09\x00\x00\x00\x00\x1d\x01\x12\x05\x00\x00\x00\x00\x3a\x20\x00\x00\x2f\x05\x80\x01\x3a\x05\x44\x05\x00\x00\x00\x00\x42\x30\x00\x00\x00\x00\xda\x30\x2c\x05\x72\x31\x4f\x05\x89\x05\x96\x05\x9f\x05\x00\x00\x00\x00\x2a\x26\x2a\x26\xb5\x05\x00\x00\xe1\x05\x93\x05\x2e\x01\x00\x00\x00\x00\xba\x29\xbc\x05\x00\x00\xfd\x05\x72\x31\x1a\x2c\x70\x46\x00\x00\x68\x42\x00\x00\x00\x00\x1a\x2c\x7a\x39\x1a\x2c\x1a\x2c\x1a\x2c\x1a\x2c\xac\x05\xba\x05\x57\x04\xce\x05\xe7\x05\x39\x02\x05\x06\x22\x06\x25\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7a\x39\x05\x34\x0c\x46\xcf\x05\xd2\x05\x45\x00\xff\x05\x2d\x06\xbf\x04\x00\x00\x84\x02\x33\x06\x8c\x02\x36\x06\x00\x00\x71\x01\x00\x00\xc4\x05\x00\x00\x0b\x00\x00\x00\x09\x4a\x00\x00\x7b\x45\x00\x00\x00\x00\xb7\x02\xbd\x4a\x00\x00\x26\x32\xe9\x41\x00\x00\x7a\x39\x7a\x39\x7a\x39\xee\x00\x00\x00\x19\x43\xad\x00\x00\x00\x35\x06\x00\x00\xd2\x04\xd2\x04\x50\x00\x00\x00\x00\x00\x50\x00\x00\x00\x00\x00\xac\x06\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x06\xbc\x06\x98\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa6\x06\x00\x00\x7a\x39\x00\x00\x00\x00\x87\x01\x00\x00\xae\x02\x85\x06\x00\x00\x00\x00\x7a\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7a\x39\x00\x00\x00\x00\x00\x00\x7a\x39\x7a\x39\x00\x00\x00\x00\x90\x06\x93\x06\x9d\x06\x9e\x06\xa2\x06\xa3\x06\xaa\x06\xaf\x06\xb0\x06\xbb\x06\xbe\x06\xb9\x06\xc9\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd0\x06\x00\x00\xc7\x06\xf6\x06\x00\x00\x00\x00\x00\x00\x2c\x05\x44\x00\xf4\x06\xd6\x06\x00\x00\x00\x00\x00\x00\x32\x07\x00\x00\x1a\x2c\x1a\x2c\x7b\x01\x00\x00\x1d\x02\x1a\x2c\x00\x00\x00\x00\xfd\x06\x00\x00\x00\x00\x62\x24\xb2\x19\xda\x30\xf7\x06\xca\x23\x00\x00\x1a\x2c\xc2\x26\xca\x23\x00\x00\xe0\x06\x00\x00\x00\x00\x00\x00\x02\x22\xff\x06\x00\x00\xf9\x31\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x1a\x5c\x00\xf0\x06\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x06\x00\x00\xe6\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x96\x49\x00\x00\x00\x00\x02\x07\x00\x00\x6e\x01\x0c\x07\xe9\x41\xbd\x4a\x94\x01\xa9\x01\x00\x00\x00\x00\x66\x0e\x9a\x22\xc6\x01\x00\x00\x0d\x07\x95\x02\x9d\x02\x12\x07\x00\x00\x13\x07\x11\x07\xea\x06\x04\x07\x1d\x07\x00\x00\x22\x07\x06\x07\x07\x07\x2e\x49\x2e\x49\x00\x00\x23\x07\x54\x03\xb5\x03\x03\x07\x05\x07\x2d\x07\x00\x00\x10\x07\x0b\x05\x00\x00\x00\x00\x1a\x2c\xca\x23\x32\x00\xf1\x3d\x1c\x00\x00\x00\x1e\x07\x63\x01\x34\x07\xbd\x4a\x00\x00\x00\x00\x4e\x00\x00\x00\x1a\x2c\xba\x29\xe9\x41\x68\x07\x00\x00\x35\x07\x1c\x07\x00\x00\xf4\x05\x00\x00\x00\x00\x00\x00\x00\x00\x70\x07\x4f\x00\x38\x06\x90\x02\x00\x00\x3e\x07\xbd\x4a\x01\x36\xb4\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x42\x6a\x0b\x1a\x07\x01\x36\x00\x00\x6a\x0b\x09\x4a\x52\x2a\x52\x2a\x75\x07\x00\x00\x5a\x01\x00\x00\x14\x07\x00\x00\x19\x07\x00\x00\x00\x00\x5b\x49\x5b\x49\x00\x00\x00\x00\x5b\x49\x72\x31\x45\x07\x46\x07\x00\x00\x00\x00\x7d\x07\x00\x00\x9f\x03\x9f\x03\x00\x00\x00\x00\x00\x00\x8c\x07\x00\x00\x2a\x07\x00\x00\x4a\x1a\x31\x07\x3c\x00\x3c\x00\x31\x07\x1f\x07\x00\x00\x00\x00\x00\x00\x50\x07\x00\x00\x00\x00\x00\x00\x8d\x02\x00\x00\x00\x00\x25\x01\x38\x07\x1a\x2c\x36\x4a\x86\x07\x00\x00\x3f\x07\x36\x07\x00\x00\x00\x00\x3d\x07\x00\x00\xec\x42\x00\x00\x55\x07\x61\x07\x69\x07\x72\x07\x63\x4a\x00\x00\x00\x00\x73\x07\x63\x07\x7a\x39\x53\x07\x7a\x39\xbd\x4a\x00\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x05\x7a\x39\x00\x00\x00\x00\x7a\x39\x54\x07\x00\x00\x8c\x47\x00\x00\x57\x05\x00\x00\x76\x07\xaa\x07\x00\x00\x00\x00\x6e\x05\xb7\x02\xe9\x41\x77\x07\x80\x36\x80\x36\xad\x07\xc0\x07\x79\x07\x7a\x39\x1c\x00\x7a\x07\x00\x00\xea\x4a\x00\x00\x7f\x07\x00\x00\x00\x00\x80\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7a\x39\x00\x00\x66\x07\x7a\x39\x00\x00\x00\x00\x00\x00\x59\x07\x00\x00\x42\x1d\x1a\x2c\x00\x00\x00\x00\xff\x36\x63\x4a\xb7\x02\x81\x07\xe9\x41\xff\x36\xff\x36\xc4\x04\x00\x00\x00\x00\x6b\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x6b\x01\x00\x00\x00\x00\xb2\x2c\x00\x00\x00\x00\x4a\x2d\x00\x00\x5c\x00\x6c\x07\x00\x00\x83\x05\x00\x00\x5a\x27\x7b\x07\x00\x00\x58\x07\x00\x00\x00\x00\xf2\x27\x00\x00\x00\x00\x00\x00\x4a\x2d\xea\x2a\x4a\x2d\x00\x00\x00\x00\xca\x23\x70\x46\x00\x00\x00\x00\x00\x00\x7a\x39\x00\x00\x00\x00\x8d\x07\x00\x00\x85\x07\x84\x07\x5f\x07\x7a\x39\x00\x00\x7a\x39\x3c\x09\x8a\x05\x00\x00\x87\x07\x87\x07\xc7\x07\x00\x05\xdb\x07\x00\x00\x2a\x00\x2a\x00\x00\x00\x8b\x07\x71\x07\x00\x00\x7e\x07\x00\x00\x00\x00\x8e\x07\x00\x00\x00\x00\x00\x00\x00\x00\x97\x07\x00\x00\xa2\x07\x00\x00\x00\x00\x00\x00\xe3\x07\xb5\x07\x4a\x2d\x82\x2b\x00\x00\x00\x00\xdf\x07\xc1\x04\x8a\x28\x8a\x28\x4a\x2d\x9e\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\x36\xff\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x07\xa3\x07\xc9\x07\x00\x00\xcb\x07\x00\x00\xb9\x07\xe9\x41\x02\x08\x15\x08\x00\x00\x99\x07\x00\x00\x21\x08\x00\x00\x1c\x04\x21\x08\xf1\x05\xff\x36\x27\x03\x7e\x37\x00\x00\x00\x00\x4a\x2d\x00\x00\xe2\x1a\xe2\x1a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7a\x1b\x7a\x1b\x00\x00\x00\x00\x00\x00\x0e\x08\x26\x32\x00\x00\xe9\x41\x7a\x39\xdd\x07\xfd\x37\x00\x00\x00\x00\x63\x4a\x00\x00\x00\x00\x0b\x06\xcd\x07\x90\x4a\x00\x00\x6a\x0b\x2d\x03\x00\x00\x00\x00\xcf\x07\x00\x00\xb3\x07\x00\x00\xd2\x04\x00\x00\x14\x08\xee\x07\xf0\x07\x24\x08\xd0\x07\x00\x00\x40\x06\x00\x00\x00\x00\x40\x06\x3f\x08\x00\x00\x00\x00\x4a\x2d\xf4\x07\x00\x00\x2d\x08\x42\x1d\x42\x1d\x00\x00\x00\x00\xfd\x37\x00\x00\xf9\x07\x00\x00\xf5\x07\x00\x00\x54\x06\x00\x00\x60\x00\x00\x00\xd4\x01\x00\x00\x00\x00\x39\x08\xcf\x02\x00\x00\x26\x32\x00\x00\x00\x00\xe6\x01\x00\x00\x28\x08\x4a\x2d\x7c\x38\xd9\x02\x00\x00\x00\x00\x00\x00\x23\x05\x23\x05\x00\x00\x77\x02\x19\x08\xc5\x07\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x39\x00\x00\x24\x00\x00\x00\x34\x08\x00\x00\x48\x08\x00\x00\xe9\x41\x00\x00\x00\x00\x78\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x2d\x4a\x2d\x4a\x2d\x00\x00\x00\x00\x00\x00\xd4\x07\x4b\x08\x00\x00\x00\x00\x00\x00\x00\x00\xef\x01\x00\x00\xe1\x01\x46\x43\xe7\x02\x60\x06\xeb\x07\x00\x00\xa0\x44\x00\x05\x00\x00\x00\x00\x00\x00\x60\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x05\xed\x07\x00\x00\x00\x00\x00\x00\x00\x00\xd2\x04\xc9\x02\x4c\x04\x22\x04\x00\x05\x00\x00\x00\x00\x00\x00\x69\x00\xf3\x07\xf2\x07\x73\x43\xd2\x04\xd2\x04\x00\x00\x4a\x2d\x0c\x08\x00\x00\x00\x00\x2f\x08\x00\x00\x0b\x08\x00\x00\x00\x00\x70\x3e\xea\x4a\x13\x08\xfa\x07\x3d\x00\xff\x07\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\xfc\x07\x00\x00\x1e\x08\x00\x08\x11\x08\x00\x00\x12\x1c\x00\x00\x58\x04\xef\x3e\xe9\x41\xae\x0e\xe9\x41\x00\x00\x00\x00\x00\x00\xaa\x1c\xef\x3e\x00\x00\x00\x00\x6e\x3f\x29\x08\x00\x00\xf7\x3a\x76\x3b\x26\x32\xf5\x3b\x00\x00\x2f\x02\xf3\x02\x90\x4a\xf5\x3b\x00\x00\x4b\x00\xd2\x04\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x12\x08\x00\x00\x00\x00\x00\x00\x0f\x08\x00\x05\x0d\x08\x16\x08\x00\x00\x00\x00\x00\x00\x26\x32\x00\x00\x41\x02\x00\x00\x5c\x00\xfb\x02\x17\x08\x6e\x3f\x1c\x00\x00\x00\x00\x00\x2c\x08\xfb\x38\xb8\x04\x00\x00\x00\x00\xf5\x3b\x74\x3c\x00\x00\x00\x00\xb5\x03\xfb\x38\x23\x05\x00\x00\x00\x00\xed\x3f\xf7\x07\x23\x08\x30\x08\x00\x00\xf3\x3c\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x41\x4a\x2d\x07\x08\x00\x00\x54\x00\x54\x00\x00\x00\xd2\x04\x00\x00\xd2\x04\x00\x00\x00\x00\x1f\x08\x22\x08\x27\x08\x2a\x08\x00\x00\xda\x02\x00\x00\x00\x00\x00\x00\x41\x45\x18\x08\x00\x00\x00\x00\x00\x05\x2b\x08\x1a\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x03\x00\x00\x89\x08\xeb\x02\x00\x00\x25\x00\x2e\x08\x2e\x08\x47\x08\x00\x00\x00\x00\x00\x00\x6c\x40\x00\x00\x33\x08\x00\x00\x00\x00\x00\x00\x00\x00\x41\x08\x49\x08\x07\x33\x00\x00\x00\x00\xea\x4a\x00\x00\x00\x00\x83\x08\x9a\x08\x1c\x00\x00\x00\x00\x00\xeb\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x08\x00\x05\x00\x00\x00\x00\x3e\x08\x00\x00\x00\x00\x91\x08\xa7\x08\x00\x00\xa7\x08\x6f\x08\x26\x32\x00\x00\x6a\x41\x00\x00\x00\x00\xa8\x08\xa9\x08\x6c\x19\xd2\x04\x00\x00\xd2\x04\xd2\x04\x00\x00\xd2\x04\x41\x45\x00\x00\x00\x00\xd9\x44\x00\x00\x00\x00\x00\x00\x00\x00\x4f\x08\x78\x08\x00\x00\xd2\x04\x64\x06\x64\x06\x00\x00\x00\x00\x00\x00\xc6\x08\x00\x00\x00\x00\x00\x00\x00\x00\x59\x08\xd2\x04\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyGotoOffsets :: HappyAddr +happyGotoOffsets = HappyA# "\x05\x00\xfe\xff\xa0\x08\xb9\x4e\x48\x01\x4d\x53\x75\x52\xf2\x06\x01\x4f\x01\x00\x60\x12\x8d\x00\x07\x00\xf6\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe4\x04\x00\x00\x00\x00\x00\x00\x75\x01\x00\x00\x00\x00\x00\x00\x79\x01\x00\x00\x00\x00\x41\x05\x80\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x35\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\xff\x53\x01\x7d\x12\x83\x0e\x63\x0e\xd6\x00\x17\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x95\x53\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x04\xa4\x07\xcd\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x0c\x00\x00\x00\x00\xdd\x53\x25\x54\xd2\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x54\xec\x07\x0d\x51\x53\x05\xf6\x07\xbe\x14\xf8\x07\xaa\x15\x00\x00\x00\x00\x00\x00\xfa\x11\xc7\x34\xe6\x12\x46\x35\xb9\x4a\x5f\x46\x45\x47\xe6\x07\x49\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\x54\x4d\x5c\x12\x13\x06\x08\xfd\x54\x00\x00\x45\x55\xfc\x05\xaa\x08\x00\x00\x00\x00\xa7\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7a\x05\xa7\x02\xf1\x04\x40\x05\x66\x05\xd3\x03\x66\x0b\xdf\x02\xd2\x46\x00\x00\x00\x00\xc5\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\x01\x00\x00\x00\x00\x00\x00\x00\x00\x74\x07\x00\x00\x00\x00\xae\x05\x9f\x08\x00\x00\x2d\x16\x67\x08\x8c\x00\xe8\x05\x96\x04\x73\x02\x46\x03\x44\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x08\x00\x00\x00\x00\x00\x00\x00\x00\xb9\x00\x00\x00\xc1\x01\x00\x00\x5a\x02\xbc\x07\xc2\x07\xc6\x07\xb7\x08\x00\x00\xa4\x04\xc3\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x37\xe1\x07\x93\x04\x00\x00\x00\x00\x7a\x08\x00\x00\x00\x00\x00\x00\x7e\x08\x00\x00\x00\x00\xf6\x05\x00\x00\xc6\xff\x00\x00\x6f\xff\x2d\x04\x00\x00\x74\x08\x7d\x08\x00\x00\x00\x00\x18\x01\x8f\x16\x19\x03\xc9\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xac\x16\x88\x10\xc9\x16\x5d\x08\x00\x00\x00\x00\xef\x04\x00\x00\x02\x09\x00\x00\x00\x00\x6a\x08\xcd\x02\xaf\x07\xa6\x08\x00\x00\x00\x00\x00\x00\x2f\x0f\x98\xff\x00\x00\x00\x00\x95\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x27\x4b\x03\x4c\x00\x00\xe6\x12\x00\x00\x00\x00\x61\x03\x00\x00\x84\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9a\x05\x00\x00\xf6\x03\x00\x00\x00\x00\x30\x04\x5e\x0f\xbb\x04\x00\x00\x00\x00\xfa\x02\x42\x03\x7e\x00\x09\x09\xc9\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x01\xd9\x07\x00\x00\x00\x00\x00\x00\x1d\x00\x28\x00\x00\x00\x0b\x11\x00\x00\x00\x00\x00\x00\x04\x04\x3a\x08\x00\x00\x98\xff\x00\x00\x00\x00\x00\x00\x27\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x38\x00\x00\x00\x00\x89\x09\x31\x08\xbf\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x4f\x91\x4f\x00\x00\x00\x00\x00\x00\x45\x08\x80\xff\x00\x00\x00\x00\xde\x4f\xec\x05\x00\x00\x00\x00\xbd\x39\x8d\x55\xdb\x01\x00\x00\xba\xff\x00\x00\x00\x00\x69\x5d\x6b\x10\xd5\x55\x1d\x56\x65\x56\xad\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x10\xbf\x0d\xdd\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x02\x00\x00\xac\x00\x00\x00\x30\x03\x00\x00\x00\x00\x82\x08\x1b\x00\x00\x00\x59\x02\xe6\x16\x00\x00\x24\x15\x41\x15\x2f\x13\x00\x00\x00\x00\x16\x00\xe0\x07\x00\x00\x9a\x02\x00\x00\xe7\x07\xea\x07\x05\x09\x00\x00\x00\x00\x06\x09\x00\x00\x00\x00\xed\x08\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd6\x15\x00\x00\x00\x00\x00\x00\x00\x00\x79\x04\x00\x00\x00\x00\x00\x00\x3a\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x11\x00\x00\x00\x00\x00\x00\x74\x11\x91\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x08\x3b\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf5\x56\x3d\x57\xfb\x07\x00\x00\x00\x00\x85\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x50\x6f\x4a\xc9\x33\x00\x00\x71\x4c\x00\x00\xcd\x57\x29\x4e\xdf\x4c\x00\x00\x89\xff\x00\x00\x00\x00\x00\x00\x95\x4b\x00\x00\x00\x00\x33\x07\x00\x00\x00\x00\x00\x00\x00\x00\x90\x01\x08\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x02\x00\x00\x00\x00\x00\x00\x00\x00\x01\x08\x00\x00\x9e\x18\xa5\x00\x00\x00\x10\x08\x00\x00\x00\x00\x77\x01\x00\x00\x1b\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x07\x8e\x0b\x00\x00\x00\x00\xf6\x04\x4f\x03\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x0b\x11\x00\x00\x00\x00\x69\x5d\x4d\x4d\x00\x00\x09\x08\xc1\xff\x00\x00\x00\x00\x03\x08\x00\x00\x1b\x01\x00\x00\x00\x00\x04\x00\x00\x00\x15\x58\x78\x50\x48\x17\xb9\x08\xa7\x05\xd3\x08\x00\x00\x00\x00\xe5\x08\x00\x00\x00\x00\x00\x00\x00\x00\xc1\x08\x01\x06\x9b\x05\xdf\x08\x00\x00\x00\x00\x5c\x01\xe2\x0b\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\xff\xce\x02\x1c\x08\x26\x09\x00\x00\xd5\xff\xe8\xff\xbd\x52\x05\x53\xc4\x08\x00\x00\x00\x00\x00\x00\xc8\x08\x00\x00\xc2\x08\x00\x00\x00\x00\xd6\x01\x13\x0c\x00\x00\x00\x00\x97\x00\x3c\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x09\x00\x00\x2a\x09\x2b\x09\x00\x00\x00\x00\x00\x00\x17\x03\x00\x00\x16\x09\x00\x00\x90\x01\x23\x09\xce\x08\xcf\x08\x2c\x09\x17\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x5c\xd8\xff\xea\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x51\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3e\x03\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x13\x0a\x09\x69\x13\xbd\xff\x00\x00\xfa\x08\x00\x00\x00\x00\x00\x00\x00\x00\xee\x08\x7b\x0f\x00\x00\x00\x00\xfe\x13\x00\x00\x00\x00\xf7\x02\x00\x00\xf6\x08\x00\x00\x00\x00\xf8\x08\x00\x00\x00\x00\x5d\x06\xd4\x08\x65\x17\x00\x00\x8b\x0b\xa8\x0b\xc3\x08\xc2\x05\x00\x00\x1b\x14\xe4\xff\x00\x00\x00\x00\x7d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x0f\x00\x00\x00\x00\xb5\x0f\x00\x00\x00\x00\x00\x00\xe3\x05\x00\x00\xb1\x06\x5d\x58\x00\x00\x00\x00\x52\x09\x94\x03\xe2\x08\x00\x00\x82\x17\x78\x0c\x95\x0c\xc9\x05\x00\x00\x00\x00\x3f\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\x58\x00\x00\x00\x00\xed\x58\x00\x00\x40\x08\x00\x00\x00\x00\x31\x05\x00\x00\xc5\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x51\x00\x00\x00\x00\x00\x00\x35\x59\xe5\x51\x7d\x59\x00\x00\x00\x00\xbb\x4d\x17\x02\x00\x00\x00\x00\x00\x00\x26\x12\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x04\xf3\x15\x00\x00\x38\x14\x22\x00\x67\x09\x00\x00\x58\x09\x5c\x09\x00\x00\x15\x00\x00\x00\x00\x00\xfb\xff\xfd\xff\x00\x00\x00\x00\x47\x04\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xba\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0f\x09\x9b\x08\xc5\x59\x2d\x52\x00\x00\x00\x00\x00\x00\x00\x00\x71\x4e\x9d\x51\x0d\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x0c\xcf\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x17\xdc\x08\xcd\x05\x00\x00\xc5\xff\x00\x00\xd0\x08\x00\x00\xfc\xff\xd0\x05\x00\x00\x65\x0d\x00\x00\xc5\x0b\x00\x00\x00\x00\x55\x5a\x00\x00\xd8\x03\x20\x04\x00\x00\xe7\x08\x3c\x06\x00\x00\x00\x00\x00\x00\x1b\x02\x63\x02\x00\x00\x00\x00\x00\x00\x46\x09\xc3\xff\x00\x00\x01\x18\x55\x14\x00\x00\xf1\x09\x00\x00\x00\x00\xf4\xff\x00\x00\x00\x00\x00\x00\x00\x00\xed\xff\x00\x00\x6c\x03\x0b\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5a\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7b\x09\x00\x00\x00\x00\x7c\x09\x5f\x09\x00\x00\x00\x00\x9d\x5a\x00\x00\x00\x00\x00\x00\xaf\x05\x30\x06\x00\x00\x00\x00\x0e\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x09\x00\x00\x41\x09\x00\x00\x6e\x08\x00\x00\x00\x00\x53\x09\x00\x00\x00\x00\xf7\x02\x00\x00\x00\x00\x77\x08\x00\x00\x57\x09\x25\x5d\x13\x06\x00\x00\x00\x00\x00\x00\x00\x00\x37\x01\x5c\x02\x00\x00\x54\x01\x62\x09\x7c\x08\x00\x00\x00\x00\x00\x00\x00\x00\x78\x0d\x00\x00\x83\x03\x00\x00\xfb\x08\x00\x00\xd6\x05\x00\x00\x9e\x0d\x00\x00\x00\x00\x4e\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe5\x5a\x2d\x5b\x75\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x08\x00\x00\x00\x00\x26\x00\x00\x00\x8d\x09\x00\x00\x00\x00\x55\x00\xe3\xff\x00\x00\x00\x00\x00\x00\x98\x09\x00\x00\x58\x02\xa8\x02\x00\x00\x27\x00\x8f\x09\x00\x00\x00\x00\x00\x00\x00\x00\x8a\x08\xc3\x03\xec\x01\x13\x05\x2b\x00\x00\x00\x00\x00\x00\x00\x03\x00\xad\x09\x00\x00\x29\x00\x8c\x08\x92\x08\x00\x00\xbd\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa6\x0a\x8f\x01\x00\x00\x00\x00\x8f\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x96\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x05\x00\x00\x6a\x09\x7b\x06\x1e\x18\x0b\x11\x3b\x18\x00\x00\x00\x00\x00\x00\xab\x04\x15\x07\x00\x00\x00\x00\x20\x08\x6c\x09\x00\x00\x27\x04\x0f\x05\xda\xff\xea\x14\x00\x00\x99\x08\x00\x00\x34\x00\x10\x16\x00\x00\xb2\x06\xa3\x08\x00\x00\xfe\x01\x0a\x02\x00\x00\xa5\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x02\x00\x00\xab\x08\x00\x00\xac\x08\x00\x00\x00\x00\x44\x08\x06\x00\x00\x00\x00\x00\x74\x09\x3a\x0a\x7e\x09\x00\x00\x00\x00\x07\x15\x43\x12\x00\x00\x00\x00\x1a\x01\xd9\x0a\x69\x02\x00\x00\x00\x00\x8b\x0d\x49\x04\x00\x00\x00\x00\x00\x00\xb9\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x58\x18\x05\x5c\x00\x00\x00\x00\xbd\x09\xbe\x09\x00\x00\xff\xff\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x02\x00\x00\x00\x00\x00\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xba\x09\xbb\x09\x00\x00\x00\x00\x00\x00\x00\x00\xec\x0a\x00\x00\xb0\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x0e\x00\x00\x00\x00\x71\x00\x00\x00\x00\x00\x38\x09\xd9\x05\x0e\x00\x00\x00\x00\x00\x57\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x09\x0a\x06\x00\x00\x4e\x06\x00\x00\xd6\xff\x00\x00\xb9\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\xb3\x08\x00\x00\x02\x00\xb6\x08\x00\x00\xf5\xff\x5f\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x08\xd3\x09\xd4\x09\x00\x00\x00\x00\x00\x00\x92\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x08\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyAdjustOffset :: Happy_GHC_Exts.Int# -> Happy_GHC_Exts.Int# +happyAdjustOffset off = off + +happyDefActions :: HappyAddr +happyDefActions = HappyA# "\xbf\xff\xc0\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7d\xfd\x00\x00\x00\x00\xbe\xff\xbf\xff\x00\x00\xf2\xff\x0d\xfd\x0a\xfd\x07\xfd\xf7\xfc\xf5\xfc\xf6\xfc\x03\xfd\xf4\xfc\xf3\xfc\xf2\xfc\x05\xfd\x04\xfd\x06\xfd\x02\xfd\x01\xfd\xf1\xfc\xf0\xfc\xef\xfc\xee\xfc\xed\xfc\xec\xfc\xeb\xfc\xea\xfc\xe9\xfc\xe8\xfc\xe6\xfc\xe7\xfc\x00\x00\x08\xfd\x09\xfd\x00\x00\x8a\xff\x00\x00\xb0\xff\xc1\xff\x8a\xff\xc5\xfc\x00\x00\x00\x00\x00\x00\x7d\xfe\x00\x00\xa1\xfe\x00\x00\x9a\xfe\x93\xfe\x86\xfe\x85\xfe\x83\xfe\x71\xfe\x70\xfe\x00\x00\x7c\xfe\x44\xfd\x81\xfe\x3f\xfd\x35\xfd\x38\xfd\x2f\xfd\x7b\xfe\x80\xfe\x16\xfd\x13\xfd\x68\xfe\x5d\xfe\x11\xfd\x10\xfd\x12\xfd\x00\x00\x00\x00\x2c\xfd\x28\xfd\x2b\xfd\x2a\xfd\x7a\xfe\x29\xfd\x00\x00\xc1\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\xfd\x32\xfd\x2d\xfd\x2e\xfd\x36\xfd\x30\xfd\x31\xfd\x6b\xfd\x69\xfe\x6a\xfe\xcc\xfd\x00\x00\x11\xfe\x10\xfe\x00\x00\xf1\xff\x5a\xfd\x4d\xfd\x59\xfd\xef\xff\xf0\xff\x1a\xfd\xff\xfc\x00\xfd\xfb\xfc\xf8\xfc\x58\xfd\xe2\xfc\x49\xfd\xdf\xfc\xdc\xfc\xfa\xfc\xe5\xfc\xe3\xfc\xe4\xfc\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xfc\xf9\xfc\xdd\xfc\xe1\xfc\xfc\xfc\xde\xfc\xd0\xfd\x78\xfd\x0a\xfe\x01\xfe\x09\xfe\x00\x00\x00\x00\x02\xfe\xf7\xfd\xeb\xfd\xe9\xfd\xdb\xfd\xce\xfd\xcd\xfd\x00\x00\x00\x00\x7e\xfd\x7b\xfd\xe6\xfd\xe5\xfd\xe7\xfd\xe8\xfd\xe4\xfd\xdc\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\xfd\xdb\xfc\xda\xfc\xe3\xfd\xe2\xfd\xd7\xfc\xd6\xfc\xd9\xfc\xd8\xfc\xd5\xfc\xd4\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xca\xfd\x00\x00\xd6\xfd\x77\xff\x1e\xfe\x00\x00\x00\x00\x07\xfe\x00\x00\x0a\xfd\x75\xff\x74\xff\x73\xff\x00\x00\x00\x00\x15\xfe\x15\xfe\x15\xfe\x00\x00\x68\xfd\x00\x00\x00\x00\x8c\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x6d\xff\x6c\xff\x6b\xff\x15\xff\x6a\xff\x69\xff\x2a\xfe\x63\xff\x29\xfe\x32\xfe\x62\xff\x2d\xfe\x61\xff\x31\xfe\x30\xfe\x2f\xfe\x2e\xfe\x00\x00\x29\xff\x00\x00\x49\xff\x52\xff\x28\xff\x00\x00\x00\x00\x00\x00\xdc\xfe\xc6\xfe\xcb\xfe\x00\x00\x00\x00\xc9\xfc\xc8\xfc\xc7\xfc\xc6\xfc\x00\x00\x7c\xfd\x00\x00\x84\xff\x00\x00\x00\x00\x00\x00\x00\x00\x8a\xff\xc2\xff\x8a\xff\x00\x00\x87\xff\x00\x00\x00\x00\x00\x00\x82\xff\x00\x00\x00\x00\x00\x00\x5d\xfd\x54\xfd\x5e\xfd\x0f\xfd\x56\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xcc\xfe\x00\x00\x60\xfd\x00\x00\xc7\xfe\x00\x00\x00\x00\xdd\xfe\xda\xfe\x00\x00\x53\xfd\x00\x00\x00\x00\x00\x00\x67\xff\x00\x00\x00\x00\x00\x00\x93\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\xff\x00\x00\x4b\xff\x4d\xff\x4c\xff\x00\x00\x63\xfe\x00\x00\x5a\xfe\x00\x00\x1c\xff\x00\x00\x20\xfd\x00\x00\x1f\xfd\x21\xfd\x00\x00\x00\x00\x00\x00\x15\xff\x00\x00\x8b\xfd\xc1\xfd\x0a\xfe\x00\x00\x00\x00\x1d\xfd\x00\x00\x1c\xfd\x1e\xfd\x18\xfd\xfd\xfc\x00\x00\xfe\xfc\x49\xfd\x00\x00\x00\x00\xca\xfc\xfa\xfc\x51\xfd\xce\xfc\x00\x00\x53\xfd\xad\xfe\x00\x00\x69\xfd\x67\xfd\x65\xfd\x64\xfd\x61\xfd\x00\x00\x00\x00\x00\x00\x14\xfe\x00\x00\x00\x00\x00\x00\x00\x00\xe4\xfe\x00\x00\xe7\xfe\xe7\xfe\x00\x00\x00\x00\x00\x00\x76\xff\xd7\xfd\x47\xfd\xd8\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\xff\x6e\xff\x00\x00\x00\x00\x00\x00\xd9\xfd\xda\xfd\x00\x00\xc7\xfd\xe8\xfd\x00\x00\x00\x00\xfd\xfc\xfe\xfc\x00\x00\x4f\xfd\x00\x00\xb5\xfd\x00\x00\xb4\xfd\x4c\xfd\x89\xfd\x05\xfe\xf5\xfd\x88\xfd\x85\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\xfd\x7a\xfd\x7f\xfd\x7f\xfd\x00\x00\xed\xfd\x77\xfd\xfe\xfd\x00\x00\xf0\xfd\x90\xfd\x00\x00\x00\x00\xee\xfd\x00\x00\x00\x00\x00\x00\x75\xfd\xfa\xfd\x00\x00\x04\xfe\x00\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\xfe\x5c\xfd\x5b\xfd\x7f\xfe\x7e\xfe\x6c\xfe\x23\xfd\x63\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x62\xfe\x00\x00\x00\x00\x00\x00\x76\xfe\x00\x00\x38\xfd\x00\x00\x00\x00\x78\xfe\x00\x00\x40\xfd\x00\x00\x40\xfe\x3e\xfe\xc2\xfc\x00\x00\x82\xfe\x00\x00\xa4\xfe\xa5\xfe\x00\x00\x5d\xfe\x5c\xfe\x00\x00\x00\x00\x84\xfe\x00\x00\x00\x00\x00\x00\x00\x00\xe8\xff\x00\x00\x00\x00\xad\xff\x87\xff\xac\xff\x00\x00\x00\x00\xbb\xff\xd1\xfc\xd0\xfc\xbb\xff\xab\xff\xa9\xff\xaa\xff\x8b\xff\xec\xff\xd2\xfc\xd3\xfc\xe9\xff\x00\x00\xd8\xff\xdc\xff\xd9\xff\xdb\xff\xda\xff\xdd\xff\xeb\xff\x53\xfe\xa0\xfe\x9c\xfe\x92\xfe\x9b\xfe\x00\x00\x5e\xfe\x00\x00\xa2\xfe\xa3\xfe\x00\x00\xa8\xfe\x00\x00\x00\x00\x79\xfe\x73\xfe\x00\x00\x41\xfd\x43\xfd\xcf\xfc\x3e\xfd\x72\xfe\x00\x00\x42\xfd\x74\xfe\x75\xfe\x00\x00\x00\x00\x15\xfd\x37\xfd\x00\x00\x00\x00\x00\x00\x2c\xfd\x2b\xfd\x2a\xfd\x7a\xfe\x29\xfd\x2d\xfd\x2e\xfd\x31\xfd\x62\xfe\x00\x00\x64\xfe\xcb\xfd\xed\xff\xee\xff\x50\xfd\x57\xfd\x0b\xfd\x4e\xfd\x48\xfd\x19\xfd\x0b\xfe\x0c\xfe\x0d\xfe\x0e\xfe\x0f\xfe\xab\xfe\x08\xfe\xf9\xfd\x00\x00\x76\xfd\x73\xfd\x70\xfd\x72\xfd\x79\xfd\xf6\xfd\x00\x00\x00\x00\x00\x00\xa1\xfd\x9f\xfd\x91\xfd\x8e\xfd\x00\x00\xff\xfd\x00\x00\x00\x00\x00\x00\x80\xfd\x00\x00\x00\x00\xfd\xfd\xfc\xfd\x00\x00\x87\xfd\xf2\xfd\x00\x00\x00\x00\x85\xfd\x00\x00\x00\x00\xdd\xfd\xb3\xfd\x00\x00\x00\x00\x0c\xfd\xb7\xfd\xbb\xfd\xde\xfd\xbd\xfd\xb6\xfd\xbc\xfd\xdf\xfd\x00\x00\xd5\xfd\xd2\xfd\xd3\xfd\xc2\xfd\xc3\xfd\x00\x00\x00\x00\xd1\xfd\xd4\xfd\xc9\xfd\x45\xfd\x00\x00\x46\xfd\x1f\xfe\x26\xfd\x71\xff\x27\xfd\x4b\xfd\x25\xfd\x24\xfd\x00\x00\x21\xfe\xaa\xfe\x00\x00\x96\xfe\x91\xfe\x00\x00\x00\x00\x5d\xfe\x00\x00\x00\x00\x28\xfe\xe8\xfe\xaf\xfe\x27\xfe\x00\x00\x6d\xfd\xe6\xfd\x00\x00\x00\x00\x00\x00\x67\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcc\xfc\xcb\xfc\x0c\xfd\xbf\xfd\xe0\xfd\xe1\xfd\xc0\xfd\x00\x00\x00\x00\x00\x00\x27\xff\xae\xfe\x00\x00\x91\xfe\x00\x00\x5d\xfe\x06\xfe\x2b\xfe\xe0\xfe\x23\xfe\x00\x00\x00\x00\x00\x00\xf5\xfe\x55\xfe\x25\xff\x00\x00\x4e\xff\x52\xff\x53\xff\x54\xff\x56\xff\x55\xff\xeb\xfe\x12\xff\x00\x00\x23\xff\x59\xff\x00\x00\x5d\xfe\x00\x00\x00\x00\xb9\xfe\xb8\xfe\xb7\xfe\xb6\xfe\xb5\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x09\xff\x06\xff\x00\x00\x00\x00\x00\x00\xd3\xfe\xd9\xfe\x00\x00\x64\xff\xde\xfe\xc5\xfe\xc0\xfe\xc4\xfe\x66\xff\xc8\xfe\x00\x00\xca\xfe\x65\xff\xcd\xfe\x00\x00\x00\x00\x00\x00\x2c\xfe\x85\xff\x7e\xff\x83\xff\xbb\xff\xbb\xff\xb7\xff\xb6\xff\xb3\xff\x6e\xff\xb8\xff\x89\xff\xb4\xff\xb5\xff\xa7\xff\x00\x00\x00\x00\xa7\xff\x80\xff\x7f\xff\xbf\xfe\xbd\xfe\x00\x00\xce\xfe\x5f\xfd\xc9\xfe\x00\x00\xc1\xfe\xdf\xfe\x00\x00\x00\x00\x00\x00\xd1\xfe\x0b\xff\x0c\xff\x00\x00\x04\xff\x05\xff\x00\xff\x00\x00\x08\xff\x00\x00\xbb\xfe\x00\x00\xb3\xfe\xb2\xfe\xb4\xfe\x00\x00\xba\xfe\x5f\xff\x9f\xfe\x00\x00\x00\x00\x48\xff\x00\x00\x00\x00\x13\xff\x11\xff\x10\xff\x0d\xff\x0e\xff\x5a\xff\x00\x00\x00\x00\x68\xff\x5b\xff\x00\x00\x59\xfe\x57\xfe\x00\x00\x60\xff\x00\x00\x1d\xff\x00\x00\xe0\xfe\x25\xfe\x24\xfe\x00\x00\x00\x00\x00\x00\x90\xfe\x00\x00\x00\x00\x50\xfe\x3c\xfe\x00\x00\x00\x00\x27\xff\x00\x00\x18\xff\x5d\xfe\x16\xff\x00\x00\xbe\xfd\xba\xfd\xcd\xfc\x1b\xfd\x17\xfd\x52\xfd\xac\xfe\x1d\xfe\x66\xfd\x63\xfd\x55\xfd\x62\xfd\x1a\xfe\x00\x00\x13\xfe\x00\x00\x00\x00\x17\xfe\x1c\xfe\xe3\xfe\x6e\xfd\xe6\xfe\xe9\xfe\x00\x00\xe2\xfe\xe5\xfe\x00\x00\x00\x00\x00\x00\x8f\xfe\x00\x00\x00\x00\x00\x00\x00\x00\xc5\xfd\xc4\xfd\x70\xff\xc6\xfd\xc8\xfd\xcf\xfd\xb9\xfd\xb8\xfd\xc1\xfd\xad\xfd\xaf\xfd\xac\xfd\xaa\xfd\xa7\xfd\xa6\xfd\x00\x00\xb1\xfd\xae\xfd\x00\x00\x86\xfd\x00\x00\x9a\xfd\x96\xfd\x00\x00\x9b\xfd\x00\x00\x00\x00\x9c\xfd\x00\x00\x03\xfe\x84\xfd\x81\xfd\x83\xfd\xec\xfd\xf3\xfd\x00\x00\x00\x00\x00\x00\x8f\xfd\xef\xfd\x00\x00\x00\x00\xea\xfd\x6d\xfe\x0e\xfd\x00\x00\x22\xfd\x61\xfe\x60\xfe\x5f\xfe\x00\x00\x00\x00\xc3\xfc\x00\x00\x9d\xfe\x00\x00\x00\x00\x00\x00\xea\xff\xa7\xff\xa7\xff\x00\x00\xa0\xff\x00\x00\xe7\xff\xc0\xff\xc0\xff\xd7\xff\x00\x00\xc3\xfc\xc4\xfc\xc1\xfc\x6b\xfe\x77\xfe\x00\x00\x74\xfd\x71\xfd\x8d\xfd\xa0\xfd\xfe\xfd\x82\xfd\x00\x00\x9e\xfd\x99\xfd\x95\xfd\xe0\xfe\x92\xfd\x00\x00\x97\xfd\x9d\xfd\xf4\xfd\xa5\xfd\xec\xfc\x00\x00\x00\x00\xb2\xfd\x6f\xff\x8c\xff\x72\xff\x98\xfe\x8e\xfe\x97\xfe\x00\x00\x00\x00\xa9\xfe\x20\xfe\x6c\xfd\xea\xfe\x6f\xfd\x00\x00\xa7\xfe\x00\x00\x12\xfe\x00\x00\x17\xff\x00\x00\x00\x00\x50\xfe\x3c\xfe\x26\xff\xc1\xfc\x5d\xff\x3b\xfe\x39\xfe\x00\x00\x3c\xfe\x00\x00\x00\x00\x97\xfe\x00\x00\xe1\xfe\x26\xfe\x00\x00\xf6\xfe\xf9\xfe\xf9\xfe\x54\xfe\x55\xfe\x55\xfe\x24\xff\x14\xff\xec\xfe\xef\xfe\xef\xfe\x0f\xff\x21\xff\x22\xff\x43\xff\x00\x00\x38\xff\x00\x00\x00\x00\x00\x00\x00\x00\xbc\xfe\x4a\xfd\x00\x00\x07\xff\x0a\xff\x00\x00\x00\x00\xd1\xfe\xd0\xfe\x00\x00\x00\x00\xd8\xfe\xd6\xfe\x00\x00\xc3\xfe\x00\x00\xbe\xfe\x00\x00\x81\xff\x00\x00\x00\x00\x00\x00\x00\x00\x88\xff\x8d\xff\x00\x00\xbd\xff\xbc\xff\x00\x00\x7c\xff\xc2\xfe\xd7\xfe\x00\x00\x00\x00\xd2\xfe\xd4\xfe\xe7\xfe\xe7\xfe\x03\xff\xb0\xfe\x00\x00\x9e\xfe\x00\x00\x47\xff\x00\x00\x5e\xff\x00\x00\xf4\xfe\x15\xff\xf0\xfe\x00\x00\xf3\xfe\x29\xff\x30\xff\x00\x00\x58\xfe\x56\xfe\xff\xfe\xfa\xfe\x00\x00\xfe\xfe\x32\xff\x00\x00\x00\x00\x00\x00\x22\xfe\x99\xfe\x8d\xfe\x4d\xfe\x4d\xfe\x5c\xff\x00\x00\x38\xfe\x34\xfd\x35\xfe\x4f\xff\x51\xff\x50\xff\x00\x00\x3a\xfe\x49\xfe\x47\xfe\x43\xfe\x58\xff\x3c\xfe\x19\xff\x00\x00\x18\xfe\x19\xfe\x00\x00\x8c\xfe\xb0\xfd\xa9\xfd\xa8\xfd\xab\xfd\x00\x00\x00\x00\x00\x00\x98\xfd\x93\xfd\x94\xfd\x00\x00\x00\x00\x6e\xfe\x3f\xfe\x3d\xfe\x5b\xfe\x00\x00\xcb\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa5\xff\xa2\xff\xa0\xff\x9d\xff\x9e\xff\x9f\xff\x00\x00\xb1\xff\x8a\xff\x8a\xff\xa1\xff\xa0\xff\x99\xff\x91\xff\x8e\xff\x3d\xfd\x8f\xff\x00\x00\x00\x00\x00\x00\x00\x00\xa0\xff\xa8\xff\xb2\xff\xcf\xff\xcc\xff\xd6\xff\xe6\xff\xe6\xfc\x00\x00\x00\x00\xce\xff\x00\x00\x00\x00\xa4\xfd\xa3\xfd\x00\x00\xa6\xfe\x00\x00\x1a\xff\x57\xff\x00\x00\x5d\xfe\x00\x00\x66\xfe\x91\xfe\x00\x00\x34\xfe\x33\xfd\x36\xfe\x37\xfe\x00\x00\x4e\xfe\x4b\xfe\x00\x00\x00\x00\x00\x00\xf8\xfe\xfb\xfe\x34\xff\x20\xff\x00\x00\x00\x00\x00\x00\x00\x00\x31\xff\xf7\xfe\xee\xfe\xf1\xfe\x00\x00\x2f\xff\xed\xfe\x00\x00\x15\xff\x42\xff\x3a\xff\x3a\xff\x00\x00\x00\x00\xb1\xfe\x00\x00\x00\x00\xd1\xfe\x00\x00\xdb\xfe\x7a\xff\x00\x00\xc4\xff\x8a\xff\x8a\xff\xc3\xff\x00\x00\x00\x00\x7d\xff\x86\xff\x7b\xff\x00\x00\xa0\xff\x00\x00\x00\x00\x02\xff\x01\xff\x39\xff\x46\xff\x44\xff\x00\x00\x3b\xff\x00\x00\x00\x00\x00\x00\x00\x00\x27\xff\x2e\xff\xf2\xfe\x25\xff\x00\x00\x20\xff\x33\xff\x36\xff\x00\x00\x00\x00\xfc\xfe\x52\xfe\x00\x00\x00\x00\x4d\xfe\x51\xfe\x33\xfe\x00\x00\xc3\xfc\x00\x00\x00\x00\x94\xfe\x42\xfe\x8a\xfe\x88\xfe\x45\xfe\x87\xfe\x00\x00\x00\x00\x00\x00\xf1\xfd\xc7\xff\xc8\xff\xc5\xff\x00\x00\xc6\xff\x00\x00\xcd\xff\xa6\xff\x00\x00\x00\x00\x00\x00\x00\x00\x9a\xff\x00\x00\x90\xff\x9b\xff\x9c\xff\x97\xff\xa3\xff\xae\xff\xaf\xff\xa0\xff\x00\x00\x96\xff\x94\xff\x93\xff\x92\xff\x3c\xfd\x3b\xfd\x39\xfd\x3a\xfd\x00\x00\xd2\xff\xd0\xff\x00\x00\xe2\xff\x00\x00\xa7\xff\xa7\xff\x00\x00\xa2\xfd\x1b\xff\x89\xfe\x00\x00\x44\xfe\xc1\xfc\x65\xfe\x4f\xfe\x4a\xfe\x4c\xfe\x00\x00\x7b\xfe\x00\x00\x1f\xff\x35\xff\x00\x00\xfd\xfe\x37\xff\x50\xfe\x3c\xfe\x27\xff\x3f\xff\x41\xff\x3c\xff\x3e\xff\x40\xff\x45\xff\xd5\xfe\xcf\xfe\x00\x00\xa0\xff\xba\xff\xb9\xff\x00\x00\x79\xff\x3d\xff\x50\xfe\x3c\xfe\x2d\xff\x3c\xfe\x7b\xfe\x00\x00\x48\xfe\x42\xfe\x46\xfe\xfb\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xe5\xff\xe3\xff\x00\x00\xd5\xff\xd3\xff\x00\x00\x98\xff\xa4\xff\xa2\xff\x95\xff\xd4\xff\xd1\xff\xe4\xff\x00\x00\x00\x00\xe1\xff\x00\x00\x00\x00\x00\x00\x1e\xff\x2b\xff\x2c\xff\x3c\xfe\x78\xff\x2a\xff\xc9\xff\xca\xff\x00\x00\x00\x00\xe0\xff\xde\xff\xdf\xff"# + +happyCheck :: HappyAddr +happyCheck = HappyA# "\xff\xff\x00\x00\x0d\x00\x3a\x00\x05\x00\x06\x00\x23\x00\x24\x00\x06\x00\x46\x00\x0f\x00\x10\x00\x0f\x00\x10\x00\x13\x00\x11\x00\x13\x00\x13\x00\x51\x00\x10\x00\x0c\x00\x0d\x00\x13\x00\x12\x00\x13\x00\x14\x00\x13\x00\x14\x00\x46\x00\x18\x00\x08\x00\x09\x00\x0a\x00\x47\x00\x1b\x00\x04\x00\x1d\x00\x5f\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x04\x00\x09\x00\x0a\x00\x04\x00\x08\x00\x09\x00\x0a\x00\x08\x00\x09\x00\x0a\x00\x5f\x00\x51\x00\x21\x00\x22\x00\x23\x00\x24\x00\x21\x00\x22\x00\x23\x00\x24\x00\x42\x00\x21\x00\x22\x00\x23\x00\x24\x00\x7f\x00\x80\x00\x22\x00\x23\x00\x24\x00\x60\x00\x97\x00\x23\x00\x24\x00\x74\x00\x75\x00\x23\x00\x24\x00\x01\x00\x97\x00\x9d\x00\x9e\x00\x60\x00\x0a\x00\x13\x00\x51\x00\x3b\x00\x3c\x00\xaa\x00\x9e\x00\x00\x00\xd4\x00\x11\x00\x51\x00\x36\x00\x74\x00\x75\x00\x3b\x00\x3c\x00\x13\x00\xe6\x00\x19\x00\x11\x00\xa8\x00\x4e\x00\x4f\x00\xd4\x00\x19\x00\xa9\x00\xaa\x00\xbe\x00\x11\x00\x6e\x00\x62\x00\x4f\x00\x06\x01\x52\x00\x4b\x00\xbe\x00\x4b\x00\x25\x00\x70\x00\x13\x00\x4b\x00\xcc\x00\x2a\x00\x2b\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\xcc\x00\x35\x00\x29\x00\x2a\x00\x2b\x00\x0c\x00\xa8\x00\x4c\x00\x01\x00\x3f\x00\x40\x00\x54\x00\x87\x00\x3f\x00\x40\x00\x54\x00\x52\x00\x52\x00\x87\x00\x2a\x01\x75\x00\x1c\x00\x45\x00\x6f\x00\x35\x00\x36\x00\x52\x00\x65\x00\x15\x00\x87\x00\x61\x00\x45\x00\x62\x00\x87\x00\x74\x00\x75\x00\x7e\x00\x87\x00\x2c\x01\x00\x00\xa8\x00\xb3\x00\x7e\x00\x87\x00\x65\x00\x61\x00\x69\x00\x70\x00\xa8\x00\x2e\x01\x9d\x00\x9e\x00\x7e\x00\x09\x01\x0a\x01\x69\x00\xba\x00\x0d\x01\x64\x00\x0f\x01\x73\x00\x09\x01\x0a\x01\x88\x00\x2e\x01\x0d\x01\x30\x01\x0f\x01\x87\x00\x19\x01\x80\x00\x1b\x01\x19\x01\x06\x01\x1b\x01\x80\x00\x19\x00\x19\x01\x0c\x00\x1b\x01\x19\x01\x25\x01\x1b\x01\x87\x00\x25\x01\x12\x01\x13\x01\x61\x00\x1b\x01\x25\x01\x1c\x01\x31\x01\x25\x01\x1f\x01\x00\x00\x1f\x01\x2d\x00\x37\x01\x25\x01\x25\x01\x5e\x00\x25\x01\x23\x01\x24\x01\xd1\x00\x26\x01\x87\x00\x1b\x01\x31\x01\x2a\x01\x1f\x01\x1b\x01\x31\x01\x1f\x01\x37\x01\xd1\x00\x25\x01\x25\x01\x37\x01\x25\x01\x61\x00\x25\x01\x63\x00\x00\x01\x01\x01\x85\x00\x1c\x01\x04\x01\x05\x01\x1f\x01\x07\x01\x0d\x01\x0e\x01\x0f\x01\x1f\x01\x25\x01\x77\x00\x9e\x00\x1c\x01\x64\x00\x25\x01\x1f\x01\x31\x01\x31\x01\x33\x01\x34\x01\x17\x01\x25\x01\x4b\x00\x37\x01\x6f\x00\x4b\x00\x1d\x01\x1e\x01\x1f\x01\x20\x01\x2d\x01\x22\x01\x23\x01\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\x2a\x01\x2d\x01\x99\x00\x00\x00\x2d\x01\x35\x01\x85\x00\x35\x01\x35\x01\x19\x01\x2d\x01\x1b\x01\x31\x01\x35\x01\x34\x00\x35\x01\x25\x01\x35\x01\x37\x01\x6f\x00\x31\x01\x25\x01\x6f\x00\x9d\x00\x9e\x00\x25\x01\x37\x01\x31\x01\x25\x01\x33\x01\x34\x01\x31\x01\x25\x01\x33\x01\x34\x01\x25\x01\x31\x01\x62\x00\x33\x01\x34\x01\x1f\x01\x31\x01\x99\x00\x33\x01\x34\x01\x31\x01\x25\x01\x33\x01\x34\x01\x31\x01\x6f\x00\x33\x01\x34\x01\x0b\x01\x4e\x00\x0d\x01\x4b\x00\x0f\x01\x0b\x01\x57\x00\x0d\x01\x1c\x01\x0f\x01\x0b\x01\x1f\x01\x0d\x01\x1c\x01\x0f\x01\x52\x00\x1f\x01\x25\x01\x1d\x01\x1e\x01\x1f\x01\x56\x00\x25\x01\x1d\x01\x1e\x01\x1f\x01\x25\x01\x00\x00\x1d\x01\x1e\x01\x1f\x01\x25\x01\x52\x00\x39\x00\xae\x00\xaf\x00\x25\x01\x3d\x00\x3e\x00\x3f\x00\x40\x00\x6c\x00\x19\x01\x66\x00\x1b\x01\x70\x00\x02\x01\x03\x01\x04\x01\x05\x01\x64\x00\x1e\x00\xfd\x00\xfe\x00\x25\x01\x1e\x00\x50\x00\x02\x01\x1c\x01\x04\x01\x05\x01\x1f\x01\x7f\x00\x87\x00\x58\x00\x59\x00\x2d\x00\x25\x01\x7f\x00\x5d\x00\x2d\x00\x8f\x00\x4b\x00\x00\x00\x62\x00\x1f\x01\x94\x00\x95\x00\x96\x00\x97\x00\x56\x00\x25\x01\x4f\x00\x1c\x01\x28\x01\x52\x00\x1f\x01\x54\x00\x9d\x00\x9e\x00\x57\x00\x4e\x00\x25\x01\x52\x00\x19\x01\x28\x01\x1b\x01\xa7\x00\x54\x00\x4d\x00\x7c\x00\x57\x00\x00\x00\x4b\x00\x1c\x01\x39\x00\x25\x01\x1f\x01\x4c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x25\x01\x52\x00\x13\x00\x00\x00\x4e\x00\xbe\x00\x66\x00\x99\x00\x7f\x00\x19\x00\x70\x00\xa5\x00\xa6\x00\xa7\x00\x64\x00\x50\x00\x70\x00\x4e\x00\x0d\x01\xcc\x00\x0f\x01\x00\x00\x71\x00\x58\x00\x59\x00\x6f\x00\x88\x00\x76\x00\x5d\x00\x2d\x00\x00\x00\x70\x00\x1b\x01\x62\x00\x66\x00\x13\x00\x35\x00\x88\x00\x70\x00\x81\x00\x9d\x00\x9e\x00\x25\x01\xb4\x00\xb5\x00\xb6\x00\x53\x00\xad\x00\xae\x00\xaf\x00\xbb\x00\x70\x00\x31\x01\xbe\x00\xb3\x00\x52\x00\xc1\x00\xc2\x00\x37\x01\x7c\x00\x64\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x35\x00\x19\x00\x6f\x00\x61\x00\x9d\x00\x9e\x00\x02\x01\x03\x01\x04\x01\x05\x01\x6a\x00\x09\x01\x0a\x01\x19\x00\x0c\x01\x0d\x01\x70\x00\x0f\x01\x10\x01\x11\x01\x64\x00\x2d\x00\x9d\x00\x9e\x00\x61\x00\x00\x00\x63\x00\x19\x01\x1a\x01\x1b\x01\x19\x01\x6f\x00\x1b\x01\x2d\x00\x64\x00\x02\x01\x03\x01\x04\x01\x05\x01\x25\x01\xf6\x00\xf7\x00\x25\x01\x00\x00\x28\x01\x6f\x00\xb4\x00\xb5\x00\xb6\x00\x53\x00\x00\x01\x01\x01\x64\x00\xbb\x00\x04\x01\x05\x01\xbe\x00\x79\x00\x99\x00\xc1\x00\xc2\x00\x64\x00\x39\x00\x6f\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x6f\x00\x28\x01\x55\x00\x0d\x01\x0e\x01\x0f\x01\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x31\x01\x54\x00\x4f\x00\x50\x00\x57\x00\x25\x01\x37\x01\x27\x01\x28\x01\x10\x01\x11\x01\x2b\x01\x1a\x00\x19\x01\x1e\x00\x1b\x01\x5d\x00\x31\x01\x32\x01\x33\x01\x34\x01\x62\x00\x07\x01\x62\x00\x7e\x00\x25\x01\x67\x00\x68\x00\x31\x01\x2d\x00\xf6\x00\xf7\x00\x2e\x00\x2f\x00\x37\x01\x14\x01\x6f\x00\x16\x01\x17\x01\x2e\x01\x00\x01\x01\x01\x7e\x00\x64\x00\x04\x01\x05\x01\x19\x01\x20\x01\x1b\x01\x22\x01\x23\x01\x24\x01\x39\x00\x26\x01\x6f\x00\x14\x00\x29\x01\x2a\x01\x25\x01\x6a\x00\x4f\x00\x64\x00\x73\x00\x52\x00\x19\x01\x70\x00\x1b\x01\x69\x00\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x6f\x00\x7e\x00\x4f\x00\x50\x00\x25\x01\x25\x01\x74\x00\x27\x01\x28\x01\x1f\x00\x78\x00\x2b\x01\x31\x00\x32\x00\x33\x00\x7f\x00\x5d\x00\x31\x01\x32\x01\x33\x01\x34\x01\x62\x00\x1e\x00\x99\x00\x2e\x00\x2f\x00\x67\x00\x68\x00\xf1\x00\xf2\x00\xf3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xfd\x00\xfe\x00\x2d\x00\xbb\x00\x70\x00\x02\x01\xbe\x00\x04\x01\x05\x01\xc1\x00\xc2\x00\x4e\x00\x4f\x00\x69\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x76\x00\x77\x00\x74\x00\x00\x01\x01\x01\x6a\x00\x78\x00\x04\x01\x05\x01\x1c\x01\x66\x00\x70\x00\x1f\x01\x6a\x00\x62\x00\x1d\x01\x1e\x01\x1f\x01\x25\x01\x70\x00\x70\x00\x28\x01\x62\x00\x25\x01\xa5\x00\xa6\x00\xa7\x00\x6f\x00\x65\x00\x58\x00\x59\x00\x5a\x00\xf2\x00\xf3\x00\x54\x00\x6f\x00\x5f\x00\xa5\x00\xa6\x00\xa7\x00\xf6\x00\xf7\x00\x27\x01\x28\x01\x70\x00\x5f\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x01\x01\x01\x69\x00\xbb\x00\x04\x01\x05\x01\xbe\x00\x4d\x00\x75\x00\xc1\x00\xc2\x00\x61\x00\x4d\x00\x63\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x62\x00\x69\x00\x39\x00\x1d\x01\x1e\x01\x1f\x01\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x62\x00\x25\x01\x74\x00\x6f\x00\x6a\x00\x25\x01\x78\x00\x27\x01\x28\x01\x6a\x00\x70\x00\x2b\x01\x30\x00\x6f\x00\x62\x00\x70\x00\x76\x00\x31\x01\x32\x01\x33\x01\x34\x01\x76\x00\x66\x00\x3b\x00\x3c\x00\x7a\x00\x62\x00\x6f\x00\x5d\x00\x99\x00\xf6\x00\xf7\x00\x70\x00\x62\x00\x62\x00\x02\x01\x03\x01\x04\x01\x05\x01\x6f\x00\x00\x01\x01\x01\x6b\x00\x23\x00\x04\x01\x05\x01\x1b\x01\x6f\x00\x02\x01\x03\x01\x04\x01\x05\x01\x7e\x00\xfd\x00\xfe\x00\x19\x01\x25\x01\x1b\x01\x02\x01\x4f\x00\x04\x01\x05\x01\x52\x00\x4d\x00\x39\x00\x4f\x00\x6a\x00\x25\x01\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x70\x00\x28\x01\x58\x00\x59\x00\x5a\x00\x25\x01\x99\x00\x27\x01\x28\x01\x5f\x00\x31\x01\x2b\x01\x1c\x01\x3a\x00\x28\x01\x1f\x01\x37\x01\x31\x01\x32\x01\x33\x01\x34\x01\x25\x01\x99\x00\x31\x01\x28\x01\x35\x00\x6c\x00\x71\x00\x5d\x00\x37\x01\x70\x00\x75\x00\x76\x00\x62\x00\x99\x00\x79\x00\x7a\x00\x13\x00\x02\x01\x03\x01\x04\x01\x05\x01\x6b\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x29\x01\x2a\x01\x31\x01\xbb\x00\x02\x00\x2e\x01\xbe\x00\x65\x00\x37\x01\xc1\x00\xc2\x00\x69\x00\x0a\x00\x6b\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x74\x00\x74\x00\x16\x00\x62\x00\x78\x00\x78\x00\x1a\x00\x28\x01\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x1f\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x3f\x00\x40\x00\x2c\x00\x02\x01\x03\x01\x04\x01\x05\x01\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x1e\x01\x1f\x01\x1f\x01\xf4\x00\xf5\x00\xf6\x00\xf7\x00\x25\x01\x25\x01\x27\x01\x28\x01\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x01\x01\x01\x1f\x01\xbb\x00\x04\x01\x05\x01\xbe\x00\x6f\x00\x25\x01\xc1\x00\xc2\x00\x28\x01\x4b\x00\x28\x01\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x19\x01\x39\x00\x1b\x01\x1d\x01\x1e\x01\x1f\x01\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x65\x00\x25\x01\x25\x01\x69\x00\x69\x00\x25\x01\x6b\x00\x27\x01\x28\x01\x0a\x01\x4c\x00\x2b\x01\x0d\x01\x73\x00\x0f\x01\x74\x00\x74\x00\x31\x01\x32\x01\x33\x01\x34\x01\xff\x00\x14\x00\x01\x01\x7e\x00\x4d\x00\x04\x01\x5d\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\x62\x00\x63\x00\x64\x00\x4f\x00\x58\x00\x59\x00\x5a\x00\x53\x00\x00\x01\x01\x01\xfe\x00\x5f\x00\x04\x01\x05\x01\x02\x01\x70\x00\x04\x01\x05\x01\x1c\x01\x31\x00\x32\x00\x1f\x01\x6a\x00\x02\x01\x03\x01\x04\x01\x05\x01\x25\x01\x70\x00\x27\x01\x28\x01\x39\x00\x1c\x01\x75\x00\x76\x00\x1f\x01\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x1c\x01\x25\x01\x6c\x00\x1f\x01\x65\x00\x25\x01\x70\x00\x27\x01\x28\x01\x25\x01\x4c\x00\x2b\x01\x28\x01\x4d\x00\x4f\x00\x4a\x00\x4b\x00\x31\x01\x32\x01\x33\x01\x34\x01\x28\x01\x56\x00\x4e\x00\x58\x00\x59\x00\x5a\x00\x5d\x00\x54\x00\x1e\x01\x1f\x01\x5f\x00\x62\x00\x63\x00\x64\x00\x69\x00\x25\x01\x4b\x00\x27\x01\x28\x01\x4b\x00\x1f\x01\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x74\x00\x25\x01\x11\x00\xbb\x00\x78\x00\x4b\x00\xbe\x00\x75\x00\x76\x00\xc1\x00\xc2\x00\x79\x00\x7a\x00\x4d\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x4e\x00\x4f\x00\x58\x00\x59\x00\x5a\x00\x58\x00\x59\x00\x5a\x00\x87\x00\x5f\x00\x1c\x01\x65\x00\x5f\x00\x1f\x01\x31\x01\x69\x00\x8f\x00\x6b\x00\x4b\x00\x25\x01\x37\x01\x94\x00\x95\x00\x96\x00\x97\x00\x57\x00\x74\x00\x71\x00\x45\x00\x6c\x00\x78\x00\x75\x00\x76\x00\x70\x00\x75\x00\x79\x00\x7a\x00\x7e\x00\x79\x00\x0a\x01\xf6\x00\xf7\x00\x0d\x01\x61\x00\x0f\x01\x63\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x00\x01\x01\x01\x52\x00\xbb\x00\x04\x01\x05\x01\xbe\x00\x8f\x00\x54\x00\xc1\x00\xc2\x00\x70\x00\x39\x00\xbe\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x2d\x00\x2e\x00\x1d\x01\x1e\x01\x1f\x01\xcc\x00\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x25\x01\x6a\x00\x4f\x00\x50\x00\x1f\x01\x25\x01\x6a\x00\x27\x01\x28\x01\x6a\x00\x25\x01\x2b\x01\x27\x01\x28\x01\x4e\x00\x4f\x00\x5d\x00\x31\x01\x32\x01\x33\x01\x34\x01\x62\x00\x78\x00\x79\x00\x6a\x00\x4d\x00\x67\x00\x1d\x01\x1e\x01\x1f\x01\xf6\x00\xf7\x00\x54\x00\x6a\x00\x56\x00\x25\x01\x58\x00\x59\x00\x5a\x00\x4e\x00\x00\x01\x01\x01\x4b\x00\x5f\x00\x04\x01\x05\x01\x22\x01\x23\x01\x24\x01\x70\x00\x26\x01\x6c\x00\x52\x00\x29\x01\x2a\x01\x70\x00\x09\x01\x0a\x01\x2e\x01\x0c\x01\x0d\x01\x71\x00\x0f\x01\x10\x01\x11\x01\x75\x00\x76\x00\x66\x00\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x19\x01\x1a\x01\x1b\x01\x02\x00\x03\x00\x25\x01\x74\x00\x27\x01\x28\x01\x0d\x00\x78\x00\x2b\x01\x25\x01\x1d\x01\x1e\x01\x1f\x01\x6a\x00\x31\x01\x32\x01\x33\x01\x34\x01\x25\x01\x91\x00\x2a\x01\x4d\x00\x4a\x00\x4b\x00\x2e\x01\xb8\x00\xb9\x00\xba\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x58\x00\x59\x00\x5a\x00\xbb\x00\x39\x00\x8f\x00\xbe\x00\x5f\x00\x32\x01\xc1\x00\xc2\x00\x61\x00\x36\x01\x63\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x32\x01\x4c\x00\x32\x01\x71\x00\x36\x01\x6c\x00\x36\x01\x75\x00\x76\x00\x02\x00\x03\x00\x79\x00\x7a\x00\x8f\x00\x87\x00\x65\x00\x89\x00\x8a\x00\x5d\x00\x69\x00\x61\x00\x6b\x00\x63\x00\x62\x00\x63\x00\x6f\x00\xfd\x00\xfe\x00\x8f\x00\x87\x00\x74\x00\x02\x01\x6a\x00\x04\x01\x05\x01\x23\x01\x24\x01\x8f\x00\x26\x01\x66\x00\xf6\x00\xf7\x00\x94\x00\x95\x00\x96\x00\x97\x00\xb8\x00\xb9\x00\xba\x00\x87\x00\x00\x01\x01\x01\xbc\x00\xbd\x00\x04\x01\x05\x01\x61\x00\x1c\x01\x63\x00\x70\x00\x1f\x01\x23\x01\x24\x01\x61\x00\x26\x01\x63\x00\x25\x01\x87\x00\x2a\x01\x28\x01\x6c\x00\x6d\x00\x2e\x01\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x96\x00\x97\x00\xbe\x00\x7f\x00\x61\x00\x25\x01\x63\x00\x27\x01\x28\x01\x4b\x00\x52\x00\x2b\x01\x54\x00\x1d\x01\x1e\x01\x1f\x01\xcc\x00\x31\x01\x32\x01\x33\x01\x34\x01\x25\x01\x4b\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x6c\x00\x6d\x00\x39\x00\xbb\x00\x4b\x00\x61\x00\xbe\x00\x63\x00\x0d\x00\xc1\x00\xc2\x00\x43\x00\x44\x00\xbe\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xbc\x00\xbd\x00\x08\x01\x09\x01\x0a\x01\xcc\x00\x6f\x00\x0d\x01\x4d\x00\x0f\x01\x22\x01\x23\x01\x24\x01\x54\x00\x26\x01\x54\x00\x5d\x00\x56\x00\x52\x00\x58\x00\x59\x00\x62\x00\x15\x00\xe2\x00\xe3\x00\xe4\x00\x5f\x00\xe6\x00\x09\x01\x0a\x01\x6b\x00\x0c\x01\x0d\x01\x71\x00\x0f\x01\x10\x01\x11\x01\x6a\x00\xbc\x00\xbd\x00\xf6\x00\xf7\x00\x62\x00\x70\x00\x19\x01\x1a\x01\x1b\x01\x71\x00\x75\x00\x76\x00\x00\x01\x01\x01\x79\x00\x7a\x00\x04\x01\x05\x01\x25\x01\x22\x01\x23\x01\x24\x01\x6a\x00\x26\x01\x46\x00\x47\x00\x48\x00\x49\x00\x09\x01\x0a\x01\x71\x00\x0c\x01\x0d\x01\x71\x00\x0f\x01\x10\x01\x11\x01\xa0\x00\xa1\x00\xa2\x00\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x19\x01\x1a\x01\x1b\x01\x6a\x00\x61\x00\x25\x01\x63\x00\x27\x01\x28\x01\x6f\x00\x70\x00\x2b\x01\x25\x01\x5a\x00\x5b\x00\x5c\x00\x4b\x00\x31\x01\x32\x01\x33\x01\x34\x01\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x71\x00\x72\x00\x39\x00\xbb\x00\x6c\x00\x61\x00\xbe\x00\x63\x00\x6a\x00\xc1\x00\xc2\x00\xb0\x00\xb1\x00\xb2\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xb0\x00\xb1\x00\xb2\x00\xb0\x00\xb1\x00\xb2\x00\x2f\x01\x30\x01\x4d\x00\xb0\x00\xb1\x00\xb2\x00\xb0\x00\xb1\x00\xb2\x00\x6a\x00\x5d\x00\x56\x00\x6a\x00\x58\x00\x59\x00\x62\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\x5f\x00\xfe\x00\x6c\x00\x87\x00\x6b\x00\x02\x01\x6a\x00\x04\x01\x05\x01\x6a\x00\x61\x00\x8f\x00\x63\x00\x6f\x00\xf6\x00\xf7\x00\x94\x00\x95\x00\x96\x00\x97\x00\x10\x01\x11\x01\x75\x00\x76\x00\x00\x01\x01\x01\x79\x00\x7a\x00\x04\x01\x05\x01\x61\x00\x1c\x01\x63\x00\x0c\x00\x1f\x01\xb0\x00\xb1\x00\xb2\x00\x23\x01\x24\x01\x25\x01\x26\x01\x61\x00\x28\x01\x63\x00\x2a\x01\x61\x00\x4b\x00\x63\x00\x2e\x01\x6c\x00\x6d\x00\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x06\x01\xe4\x00\xbe\x00\xe6\x00\x34\x00\x25\x01\x19\x00\x27\x01\x28\x01\xf5\x00\xf6\x00\x2b\x01\x12\x01\x13\x01\xa1\x00\xa2\x00\xcc\x00\x31\x01\x32\x01\x33\x01\x34\x01\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x36\x00\x37\x00\x39\x00\xbb\x00\x23\x01\x24\x01\xbe\x00\x26\x01\x58\x00\xc1\x00\xc2\x00\x2a\x01\x4e\x00\x70\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xb0\x00\xb1\x00\xb2\x00\x71\x00\x87\x00\x70\x00\x08\x01\x09\x01\x0a\x01\x6a\x00\x6a\x00\x0d\x01\x8f\x00\x0f\x01\x6a\x00\x6a\x00\x5d\x00\x94\x00\x95\x00\x96\x00\x97\x00\x62\x00\x6a\x00\x19\x01\xff\x00\x1b\x01\x01\x01\x6a\x00\x6a\x00\x04\x01\x09\x01\x0a\x01\x07\x01\x0c\x01\x0d\x01\x25\x01\x0f\x01\x10\x01\x11\x01\x6a\x00\xf6\x00\xf7\x00\x6a\x00\x70\x00\x13\x01\x39\x00\x19\x01\x1a\x01\x1b\x01\x66\x00\x00\x01\x01\x01\x62\x00\x1c\x01\x04\x01\x05\x01\x1f\x01\x70\x00\x25\x01\xbe\x00\x23\x01\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\x2a\x01\xb0\x00\xb1\x00\xb2\x00\x4f\x00\x70\x00\xcc\x00\x54\x00\x17\x00\x4d\x00\x54\x00\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x70\x00\x52\x00\x62\x00\x6a\x00\x62\x00\x25\x01\x70\x00\x27\x01\x28\x01\x57\x00\x4e\x00\x2b\x01\x4f\x00\x4b\x00\x4b\x00\x4e\x00\x4b\x00\x31\x01\x32\x01\x33\x01\x34\x01\xb4\x00\xb5\x00\xb6\x00\xb7\x00\x7f\x00\x66\x00\x4e\x00\xbb\x00\x4b\x00\x4b\x00\xbe\x00\x6a\x00\x6a\x00\xc1\x00\xc2\x00\x71\x00\x57\x00\x71\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x52\x00\x70\x00\x19\x00\x4e\x00\x4e\x00\x09\x01\x0a\x01\x6a\x00\x0c\x01\x0d\x01\x19\x00\x0f\x01\x10\x01\x11\x01\x4f\x00\x74\x00\x1a\x00\x4b\x00\x4b\x00\x7e\x00\x16\x00\x19\x01\x1a\x01\x1b\x01\x7e\x00\x0c\x00\x6f\x00\x69\x00\x4b\x00\x87\x00\x7e\x00\x66\x00\x19\x00\x25\x01\x62\x00\x4b\x00\x4e\x00\x8f\x00\x52\x00\x70\x00\xf6\x00\xf7\x00\x94\x00\x95\x00\x96\x00\x97\x00\xbb\x00\x71\x00\x4e\x00\xbe\x00\x00\x01\x01\x01\xc1\x00\xc2\x00\x04\x01\x05\x01\x4e\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x4e\x00\x4e\x00\x5f\x00\x19\x00\x70\x00\x4f\x00\x19\x00\x07\x00\x4f\x00\x55\x00\x4b\x00\x54\x00\x66\x00\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x57\x00\x52\x00\xbe\x00\x7b\x00\x54\x00\x25\x01\x7f\x00\x27\x01\x28\x01\x6f\x00\x6f\x00\x2b\x01\x62\x00\x87\x00\x52\x00\x19\x00\xcc\x00\x31\x01\x32\x01\x33\x01\x34\x01\x8f\x00\x88\x00\xf6\x00\xf7\x00\x66\x00\x94\x00\x95\x00\x96\x00\x97\x00\x6a\x00\x69\x00\xbe\x00\x00\x01\x01\x01\x19\x00\x6a\x00\x04\x01\x05\x01\x6a\x00\x88\x00\x58\x00\x87\x00\x19\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x8d\x00\xcf\x00\x8f\x00\x55\x00\x87\x00\x6f\x00\x52\x00\x94\x00\x95\x00\x96\x00\x97\x00\x2d\x00\x6f\x00\x1c\x01\x1d\x01\x1e\x01\x1f\x01\x4f\x00\x70\x00\x4b\x00\xbe\x00\x4b\x00\x25\x01\x5f\x00\x27\x01\x28\x01\x19\x00\x07\x00\x2b\x01\x09\x01\x0a\x01\x87\x00\x0c\x01\x0d\x01\xcc\x00\x0f\x01\x10\x01\x11\x01\x19\x00\x07\x00\xf6\x00\xf7\x00\x4e\x00\x5f\x00\x19\x00\x19\x01\x1a\x01\x1b\x01\x7e\x00\xbe\x00\x00\x01\x01\x01\x66\x00\x87\x00\x04\x01\x05\x01\x4b\x00\x25\x01\x4b\x00\x8d\x00\x19\x00\x8f\x00\x6f\x00\xcc\x00\x02\x00\x4e\x00\x94\x00\x95\x00\x96\x00\x97\x00\x1a\x00\x4f\x00\x54\x00\x11\x00\x23\x00\x33\x00\x88\x00\x1a\x00\x07\x00\x1d\x01\x1e\x01\x1f\x01\x7f\x00\x09\x00\x6a\x00\x69\x00\x65\x00\x25\x01\x4d\x00\x27\x01\x28\x01\x69\x00\x2e\x00\x2b\x01\x56\x00\x09\x01\x0a\x01\x57\x00\x0c\x01\x0d\x01\x52\x00\x0f\x01\x10\x01\x11\x01\x6a\x00\x70\x00\x6f\x00\x4e\x00\xbe\x00\x45\x00\x6f\x00\x19\x01\x1a\x01\x1b\x01\x62\x00\x62\x00\x5f\x00\x56\x00\x6a\x00\x69\x00\x62\x00\x4e\x00\xcc\x00\x25\x01\x09\x01\x0a\x01\x88\x00\x0c\x01\x0d\x01\x5f\x00\x0f\x01\x10\x01\x11\x01\x7f\x00\x57\x00\x70\x00\x6a\x00\x70\x00\x02\x00\x6a\x00\x19\x01\x1a\x01\x1b\x01\x87\x00\x6a\x00\x4b\x00\x52\x00\x6a\x00\x6a\x00\x8d\x00\x69\x00\x8f\x00\x25\x01\x56\x00\x52\x00\x19\x00\x94\x00\x95\x00\x96\x00\x97\x00\x07\x00\xfb\x00\xfc\x00\xbe\x00\xfe\x00\x6a\x00\x87\x00\x6a\x00\x02\x01\x19\x00\x04\x01\x05\x01\x8d\x00\x07\x00\x8f\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x94\x00\x95\x00\x96\x00\x97\x00\x09\x01\x0a\x01\x87\x00\x0c\x01\x0d\x01\x4e\x00\x0f\x01\x10\x01\x11\x01\x19\x00\x19\x00\x1c\x01\x75\x00\x4d\x00\x1f\x01\xbe\x00\x19\x01\x1a\x01\x1b\x01\x87\x00\x25\x01\x07\x00\x75\x00\x28\x01\x30\x00\x8d\x00\x2e\x01\x8f\x00\x25\x01\xcc\x00\xd0\x00\xeb\x00\x94\x00\x95\x00\x96\x00\x97\x00\xf6\x00\xf7\x00\xbe\x00\x57\x00\x41\x00\xeb\x00\x38\x00\xeb\x00\x7d\x00\x31\x00\x00\x01\x01\x01\x2c\x01\x32\x00\x04\x01\x05\x01\xcc\x00\x83\x00\x84\x00\x2d\x01\x0f\x01\x87\x00\x7e\x00\x2d\x01\x7a\x00\x8b\x00\x8c\x00\x8d\x00\x7a\x00\x8f\x00\x90\x00\x7e\x00\x9f\x00\x57\x00\x94\x00\x95\x00\x96\x00\x97\x00\xbe\x00\x1d\x01\x1e\x01\x1f\x01\x82\x00\x2e\x01\xce\x00\xc4\x00\x88\x00\x25\x01\x2c\x01\x27\x01\x28\x01\xde\x00\xcc\x00\x2b\x01\x09\x01\x0a\x01\x2d\x01\x0c\x01\x0d\x01\x2d\x01\x0f\x01\x10\x01\x11\x01\x16\x00\x16\x00\x30\x00\x03\x00\x66\x00\xde\x00\xe6\x00\x19\x01\x1a\x01\x1b\x01\x52\x00\x41\x00\x2c\x01\xbe\x00\x09\x01\x0a\x01\x6a\x00\x0c\x01\x0d\x01\x25\x01\x0f\x01\x10\x01\x11\x01\x53\x00\x32\x01\x2c\x01\x32\x01\xcc\x00\x73\x00\x70\x00\x19\x01\x1a\x01\x1b\x01\x2c\x01\x7b\x00\x02\x00\x34\x00\x16\x00\x16\x00\x2c\x00\x20\x00\x28\x01\x25\x01\x0a\x00\x2c\x01\x7a\x00\x7a\x00\x33\x00\x61\x00\x20\x00\x09\x01\x0a\x01\x45\x00\x0c\x01\x0d\x01\x16\x00\x0f\x01\x10\x01\x11\x01\x5c\x00\x69\x00\x1c\x00\x1d\x00\x1e\x00\x65\x00\x88\x00\x19\x01\x1a\x01\x1b\x01\xf6\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x6e\x00\xa4\x00\x2c\x00\x25\x01\x88\x00\x2c\x00\x2c\x01\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x09\x01\x0a\x01\x0e\x00\x0c\x01\x0d\x01\x20\x00\x0f\x01\x10\x01\x11\x01\x20\x00\x6e\x00\xc4\x00\x4d\x00\xa4\x00\xe6\x00\xb2\x00\x19\x01\x1a\x01\x1b\x01\x54\x00\x2d\x01\x56\x00\xa2\x00\x58\x00\x59\x00\x5a\x00\x84\x00\x48\x00\x25\x01\x87\x00\x5f\x00\x17\x00\x17\x00\x35\x00\x8c\x00\x8d\x00\x49\x00\x57\x00\x90\x00\x2c\x01\x31\x01\x6a\x00\x94\x00\x95\x00\x96\x00\x97\x00\x4e\x00\x70\x00\x2c\x01\x4d\x00\x43\x00\xab\x00\x75\x00\x76\x00\x1c\x00\x84\x00\x79\x00\x7a\x00\x87\x00\x32\x01\x73\x00\x74\x00\x2c\x01\x8c\x00\x8d\x00\x1c\x00\x26\x00\x90\x00\x2d\x01\x0b\x00\x2d\x01\x94\x00\x95\x00\x96\x00\x97\x00\x54\x00\x2d\x01\xbe\x00\x32\x01\x2c\x01\x57\x00\xc2\x00\x2c\x01\x52\x00\xbe\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x2d\x01\x2c\x01\x54\x00\x16\x00\x16\x00\xcc\x00\x84\x00\x2c\x01\x2c\x01\x87\x00\x20\x00\x20\x00\xa4\x00\xa4\x00\x8c\x00\x8d\x00\x2d\x01\x4d\x00\x90\x00\x2d\x01\xbe\x00\x2d\x01\x94\x00\x95\x00\x96\x00\x97\x00\x17\x00\x17\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xcc\x00\x5f\x00\x2d\x01\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\x6a\x00\xf6\x00\xff\xff\xff\xff\x00\x01\x01\x01\x70\x00\xff\xff\x04\x01\x05\x01\xff\xff\x75\x00\x76\x00\xff\xff\xff\xff\x79\x00\x7a\x00\xff\xff\xbe\x00\xff\xff\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xf6\x00\xff\xff\xcc\x00\x1d\x01\x1e\x01\x1f\x01\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\x25\x01\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\xf6\x00\x00\x01\x01\x01\x25\x01\xff\xff\x04\x01\x05\x01\xff\xff\xff\xff\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x31\x01\xff\xff\xff\xff\xff\xff\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\x25\x01\xff\xff\x27\x01\x28\x01\xe9\x00\xea\x00\xff\xff\x84\x00\xff\xff\x25\x01\x87\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8c\x00\x8d\x00\xf6\x00\xf7\x00\x90\x00\xff\xff\x31\x01\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xff\xff\xff\xff\xff\xff\x84\x00\xff\xff\xff\xff\x87\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\xff\xff\x90\x00\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xbe\x00\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\x4d\x00\x4e\x00\x4f\x00\xff\xff\xff\xff\x52\x00\xcc\x00\x84\x00\xff\xff\xff\xff\x87\x00\x58\x00\x59\x00\x5a\x00\xff\xff\x8c\x00\x8d\x00\xff\xff\x5f\x00\x90\x00\xff\xff\xbe\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\x71\x00\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\xff\xff\xff\xff\x79\x00\x7a\x00\x4d\x00\x4e\x00\xf6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\xbe\x00\xff\xff\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xf6\x00\xff\xff\xcc\x00\xff\xff\xff\xff\x71\x00\x19\x01\x1a\x01\x1b\x01\x75\x00\x76\x00\xff\xff\xff\xff\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\x25\x01\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\xff\xff\x87\x00\xff\xff\xff\xff\xf6\x00\xff\xff\xff\xff\x25\x01\x8e\x00\xff\xff\xff\xff\x91\x00\x92\x00\x93\x00\xff\xff\xff\xff\x96\x00\x97\x00\xff\xff\x31\x01\x87\x00\xff\xff\xff\xff\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x93\x00\xff\xff\xff\xff\x96\x00\x97\x00\xff\xff\xac\x00\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x84\x00\xff\xff\x25\x01\x87\x00\xff\xff\xff\xff\xff\xff\xbe\x00\x8c\x00\x8d\x00\xff\xff\xff\xff\x90\x00\xff\xff\x31\x01\x02\x00\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xcc\x00\x87\x00\x0a\x00\xff\xff\xff\xff\xbe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x92\x00\x93\x00\x16\x00\xff\xff\x96\x00\x97\x00\x1a\x00\xcc\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xbe\x00\xac\x00\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\xff\xff\xff\xff\xff\xff\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x25\x01\xff\xff\xff\xff\xff\xff\xf6\x00\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\xff\xff\x32\x01\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x25\x01\xff\xff\xff\xff\xff\xff\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x32\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x25\x01\xff\xff\xff\xff\x4d\x00\x4e\x00\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\x31\x01\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\x25\x01\x87\x00\x5f\x00\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\xff\xff\xff\xff\x32\x01\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xff\xff\x71\x00\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\xff\xff\xff\xff\x79\x00\x7a\x00\x87\x00\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\xff\xff\x87\x00\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\xff\xff\x8f\x00\x90\x00\xff\xff\xcc\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xff\xff\xfe\x00\xff\xff\xbe\x00\xff\xff\x02\x01\x87\x00\x04\x01\x05\x01\x8a\x00\xff\xff\x8c\x00\x8d\x00\xff\xff\xff\xff\x90\x00\xff\xff\xcc\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\x1c\x01\xbe\x00\xff\xff\x1f\x01\xff\xff\xf9\x00\xfa\x00\xfb\x00\xfc\x00\x25\x01\xfe\x00\xff\xff\x28\x01\xff\xff\x02\x01\xcc\x00\x04\x01\x05\x01\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xf6\x00\xff\xff\xbe\x00\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\xff\xff\x1c\x01\xff\xff\xff\xff\x1f\x01\xcc\x00\xff\xff\x25\x01\x09\x01\x0a\x01\x25\x01\x0c\x01\x0d\x01\x28\x01\x0f\x01\x10\x01\x11\x01\xff\xff\xf6\x00\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xf6\x00\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\x87\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x25\x01\x90\x00\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xfd\x00\xfe\x00\xff\xff\x31\x01\xff\xff\x02\x01\xff\xff\x04\x01\x05\x01\xff\xff\xff\xff\xff\xff\x87\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\xff\xff\x90\x00\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xff\xff\x1c\x01\xff\xff\xff\xff\x1f\x01\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\x25\x01\x87\x00\xff\xff\x28\x01\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\xff\xff\x90\x00\xff\xff\xcc\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\xff\xff\x87\x00\xff\xff\xff\xff\xff\xff\x07\x01\x8c\x00\x8d\x00\xff\xff\xff\xff\x90\x00\xff\xff\xcc\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x14\x01\xff\xff\x16\x01\x17\x01\xff\xff\xff\xff\xff\xff\xf6\x00\xff\xff\xbe\x00\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\x24\x01\xff\xff\x26\x01\xff\xff\xff\xff\x29\x01\x2a\x01\xcc\x00\xff\xff\xff\xff\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xf6\x00\xff\xff\xbe\x00\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\x25\x01\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xf6\x00\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xf6\x00\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\x87\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8c\x00\x8d\x00\xff\xff\x25\x01\x90\x00\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xff\xff\x87\x00\x31\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x90\x00\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\x99\x00\x87\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x90\x00\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xbe\x00\x99\x00\x87\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\xff\xff\xff\xff\xcc\x00\x94\x00\x95\x00\x96\x00\x97\x00\xbe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\x87\x00\xff\xff\x89\x00\xbe\x00\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xf6\x00\xbe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\x19\x01\x1a\x01\x1b\x01\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x25\x01\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\x09\x01\x0a\x01\x31\x01\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x25\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\x09\x01\x0a\x01\x31\x01\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x25\x01\xff\xff\xff\xff\x4d\x00\x4e\x00\xf6\x00\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\x31\x01\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\x25\x01\xff\xff\x5f\x00\xff\xff\xff\xff\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x71\x00\x19\x01\x1a\x01\x1b\x01\x75\x00\x76\x00\xff\xff\xff\xff\x79\x00\x7a\x00\xff\xff\x23\x01\x24\x01\x25\x01\x26\x01\xff\xff\xff\xff\x29\x01\x2a\x01\x87\x00\xff\xff\x89\x00\x2e\x01\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x4d\x00\x4e\x00\xff\xff\x9b\x00\x9c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x87\x00\xff\xff\x89\x00\x5f\x00\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xff\xff\xff\xff\xff\xff\x71\x00\xff\xff\xbe\x00\xff\xff\x75\x00\x76\x00\xff\xff\xff\xff\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\x87\x00\xff\xff\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xbe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x83\x00\xff\xff\xff\xff\xcc\x00\x87\x00\xff\xff\xff\xff\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\xf6\x00\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\xff\xff\xff\xff\xff\xff\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xcc\x00\xff\xff\xff\xff\xff\xff\xf6\x00\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\x25\x01\xff\xff\xff\xff\xff\xff\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\x2e\x01\x0f\x01\x10\x01\x11\x01\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\xf6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x07\x01\xff\xff\xff\xff\x2e\x01\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\x14\x01\xff\xff\x16\x01\x17\x01\xf6\x00\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\x24\x01\xff\xff\x26\x01\x25\x01\xff\xff\x29\x01\x2a\x01\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\x2e\x01\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x83\x00\x19\x01\x1a\x01\x1b\x01\x87\x00\xff\xff\xff\xff\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x25\x01\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x83\x00\xff\xff\xff\xff\xff\xff\x87\x00\xff\xff\xff\xff\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x83\x00\xbe\x00\xff\xff\x86\x00\x87\x00\xff\xff\xff\xff\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\xff\xff\xcc\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x07\x01\xff\xff\x83\x00\xbe\x00\xff\xff\x86\x00\x87\x00\xff\xff\xff\xff\xff\xff\x8b\x00\xff\xff\x8d\x00\x14\x01\x8f\x00\x16\x01\x17\x01\xcc\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xff\xff\x20\x01\xff\xff\x22\x01\x23\x01\x24\x01\xf6\x00\x26\x01\xbe\x00\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xf6\x00\xff\xff\xbe\x00\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\x25\x01\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xf6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xf6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\x83\x00\xff\xff\xff\xff\x86\x00\x87\x00\xff\xff\xff\xff\xff\xff\x8b\x00\x25\x01\x8d\x00\xff\xff\x8f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x83\x00\xff\xff\xff\xff\xff\xff\x87\x00\xff\xff\xff\xff\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\xff\xff\x87\x00\xff\xff\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\xff\xff\xcc\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xff\xff\x9a\x00\x9b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\xff\xff\x87\x00\xff\xff\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\xff\xff\xcc\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xff\xff\x9a\x00\x9b\x00\xff\xff\xff\xff\xff\xff\xf6\x00\xff\xff\xbe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xf6\x00\xff\xff\xbe\x00\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\x25\x01\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xf6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xf6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\x87\x00\xff\xff\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x25\x01\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xff\xff\xff\xff\x9b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x87\x00\xff\xff\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xff\xff\xff\xff\x9b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\xff\xff\x87\x00\xff\xff\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\xff\xff\xcc\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xff\xff\xff\xff\xff\xff\x9c\x00\xff\xff\x07\x01\xff\xff\xff\xff\xbe\x00\xff\xff\xff\xff\x87\x00\xff\xff\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\x14\x01\x8f\x00\x16\x01\x17\x01\xcc\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xff\xff\x20\x01\x9b\x00\x22\x01\x23\x01\x24\x01\xf6\x00\x26\x01\xbe\x00\xff\xff\x29\x01\x2a\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xf6\x00\xff\xff\xbe\x00\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\x25\x01\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xf6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xf6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\x87\x00\xff\xff\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x25\x01\xff\xff\xbe\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xff\xff\xff\xff\x9b\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\x87\x00\xff\xff\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9e\x00\xff\xff\xe9\x00\xbe\x00\xff\xff\xff\xff\x87\x00\xff\xff\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\xf6\x00\xf7\x00\xcc\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xff\xff\xbe\x00\xff\xff\xff\xff\x87\x00\xff\xff\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\xff\xff\xcc\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xf6\x00\xff\xff\xbe\x00\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xf6\x00\xff\xff\xbe\x00\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\x25\x01\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xf6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xf6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\x87\x00\xff\xff\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x25\x01\xff\xff\xbe\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xff\xff\xff\xff\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\x87\x00\xff\xff\xff\xff\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\xa3\x00\x87\x00\xff\xff\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\xf6\x00\xf7\x00\xcc\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xff\xff\xbe\x00\xff\xff\xff\xff\x87\x00\xff\xff\xff\xff\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\xff\xff\xcc\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xf6\x00\xff\xff\xbe\x00\x25\x01\xa3\x00\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xf6\x00\xff\xff\xbe\x00\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\x25\x01\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xf6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xf6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\x87\x00\xff\xff\xff\xff\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x25\x01\xff\xff\xbe\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xa3\x00\x87\x00\xff\xff\xff\xff\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\xa3\x00\x87\x00\xff\xff\xff\xff\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\xf6\x00\xf7\x00\xcc\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xff\xff\xbe\x00\xff\xff\xa3\x00\x87\x00\xff\xff\xff\xff\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\xff\xff\xcc\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xf6\x00\xff\xff\xbe\x00\x25\x01\xa3\x00\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xf6\x00\xff\xff\xbe\x00\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\x25\x01\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xf6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xf6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\x87\x00\xff\xff\x89\x00\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x25\x01\xff\xff\xbe\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\x87\x00\xff\xff\xff\xff\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\xa3\x00\x87\x00\xff\xff\xff\xff\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\xf6\x00\xf7\x00\xcc\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xff\xff\xbe\x00\xff\xff\xff\xff\x87\x00\xff\xff\xff\xff\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\xff\xff\xcc\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xf6\x00\xff\xff\xbe\x00\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xf6\x00\xff\xff\xbe\x00\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\x25\x01\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xf6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xf6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\x87\x00\xff\xff\xff\xff\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\x25\x01\xff\xff\xbe\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\x87\x00\xff\xff\xff\xff\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\xff\xff\x87\x00\xff\xff\xff\xff\xff\xff\x8b\x00\xff\xff\x8d\x00\xff\xff\x8f\x00\xf6\x00\xf7\x00\xcc\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xff\xff\xbe\x00\xff\xff\xff\xff\x87\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\xff\xff\xff\xff\xcc\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xf6\x00\xff\xff\xbe\x00\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xf6\x00\xff\xff\xbe\x00\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\x25\x01\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xf6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x87\x00\xff\xff\x25\x01\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\x8f\x00\x0f\x01\x10\x01\x11\x01\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x87\x00\xff\xff\x25\x01\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\x8f\x00\x0f\x01\x10\x01\x11\x01\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\xff\xff\x87\x00\xff\xff\x25\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\xff\xff\xff\xff\xcc\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\xff\xff\x87\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\xff\xff\xff\xff\xcc\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\x25\x01\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x87\x00\xff\xff\x25\x01\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\x8f\x00\x0f\x01\x10\x01\x11\x01\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x87\x00\xff\xff\x25\x01\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\x8f\x00\x0f\x01\x10\x01\x11\x01\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\xff\xff\x87\x00\xff\xff\x25\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\xff\xff\xff\xff\xcc\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\xff\xff\x87\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\xff\xff\xff\xff\xcc\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\x25\x01\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x87\x00\xff\xff\x25\x01\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\x8f\x00\x0f\x01\x10\x01\x11\x01\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x87\x00\xff\xff\x25\x01\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\x8f\x00\x0f\x01\x10\x01\x11\x01\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\xff\xff\x87\x00\xff\xff\x25\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\xff\xff\xff\xff\xcc\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\xff\xff\x87\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x8f\x00\xff\xff\xff\xff\xcc\x00\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\x87\x00\x25\x01\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\x94\x00\x95\x00\x96\x00\x97\x00\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\xff\xff\xff\xff\xff\xff\x25\x01\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xcc\x00\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\x19\x01\x1a\x01\x1b\x01\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\x09\x01\x0a\x01\xff\xff\x0c\x01\x0d\x01\xff\xff\x0f\x01\x10\x01\x11\x01\xff\xff\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\xff\xff\x19\x01\x1a\x01\x1b\x01\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\x73\x00\x74\x00\x75\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x64\x00\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\x6f\x00\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\xff\xff\x14\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\x43\x00\x44\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\x06\x00\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\x0e\x00\x0f\x00\x10\x00\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x44\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\x0e\x00\x0f\x00\x10\x00\xff\xff\x12\x00\xff\xff\x14\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x44\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\x06\x00\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\x0e\x00\x0f\x00\x10\x00\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x44\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\x0e\x00\x0f\x00\x10\x00\xff\xff\x12\x00\xff\xff\x14\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x44\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\x0e\x00\x0f\x00\x10\x00\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x44\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\x50\x00\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\x6a\x00\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\x50\x00\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\x6c\x00\x6d\x00\xff\xff\xff\xff\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\x50\x00\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\x6a\x00\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\x6a\x00\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\x6c\x00\x6d\x00\xff\xff\xff\xff\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x66\x00\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\x50\x00\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\x4e\x00\x4f\x00\x50\x00\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\x0e\x00\x0f\x00\x10\x00\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x44\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x62\x00\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\x6f\x00\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\x6f\x00\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\x3d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3c\x00\xff\xff\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\x51\x00\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\xff\xff\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\xff\xff\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\xff\xff\xff\xff\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\xff\xff\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\x01\x00\x02\x00\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\x0a\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\x02\x00\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\x6e\x00\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\x01\x00\x02\x00\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\x0a\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\x73\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\xff\xff\x01\x00\x02\x00\xff\xff\x8b\x00\x8c\x00\x8d\x00\x8e\x00\xff\xff\x90\x00\x0a\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x54\x00\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\x6a\x00\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\x6c\x00\xff\xff\xff\xff\xff\xff\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\x6a\x00\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xbe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xe9\x00\xea\x00\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\x1d\x01\x1e\x01\x1f\x01\x65\x00\x66\x00\xff\xff\xff\xff\x69\x00\x25\x01\x6b\x00\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xbe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\x1d\x01\x1e\x01\x1f\x01\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\x25\x01\x6b\x00\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xbe\x00\xff\xff\xff\xff\xff\xff\xff\xff\x87\x00\xff\xff\x0a\x00\xff\xff\xff\xff\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\x1d\x01\x1e\x01\x1f\x01\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\x25\x01\x6b\x00\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xbe\x00\xff\xff\xff\xff\xff\xff\xff\xff\x87\x00\xff\xff\x0a\x00\xff\xff\xff\xff\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\x1d\x01\x1e\x01\x1f\x01\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\x25\x01\x6b\x00\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xbe\x00\xff\xff\xff\xff\xff\xff\xff\xff\x87\x00\xff\xff\x0a\x00\xff\xff\xff\xff\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\x1d\x01\x1e\x01\x1f\x01\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\x25\x01\x6b\x00\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xbe\x00\xff\xff\xff\xff\xff\xff\xff\xff\x87\x00\xff\xff\x0a\x00\xff\xff\xff\xff\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\x1d\x01\x1e\x01\x1f\x01\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\x25\x01\x6b\x00\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xbe\x00\xff\xff\xff\xff\xff\xff\xff\xff\x87\x00\xff\xff\x0a\x00\xff\xff\xff\xff\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\x1d\x01\x1e\x01\x1f\x01\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\x25\x01\x6b\x00\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x87\x00\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xbe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\x1d\x01\x1e\x01\x1f\x01\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\x25\x01\x6b\x00\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xbe\x00\xff\xff\xff\xff\xff\xff\xff\xff\x87\x00\xff\xff\x0a\x00\xff\xff\xff\xff\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\x1d\x01\x1e\x01\x1f\x01\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\x25\x01\x6b\x00\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\x6a\x00\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xbe\x00\xff\xff\xff\xff\xff\xff\xff\xff\x87\x00\xff\xff\x0a\x00\xff\xff\xff\xff\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\x1d\x01\x1e\x01\x1f\x01\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\x25\x01\x6b\x00\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xbe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xff\xff\x4c\x00\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\x1d\x01\x1e\x01\x1f\x01\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\x25\x01\x6b\x00\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x88\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x88\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x87\x00\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x88\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x88\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\x7e\x00\x7f\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x92\x00\x93\x00\xff\xff\x16\x00\xff\xff\x97\x00\x98\x00\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x02\x00\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\x0a\x00\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7e\x00\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\x92\x00\x93\x00\x73\x00\xff\xff\xff\xff\x97\x00\x98\x00\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x7e\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\x02\x00\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\x02\x00\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\x73\x00\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7e\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\x02\x00\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7e\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x7e\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\x02\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\x71\x00\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x01\x00\x02\x00\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\x71\x00\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\x78\x00\xff\xff\x7a\x00\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\x02\x00\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x00\xff\xff\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\x2f\x00\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\x13\x00\xff\xff\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\x2f\x00\x69\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\x02\x00\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\x69\x00\x02\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\x0a\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\x02\x00\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\x69\x00\x02\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\x0a\x00\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x65\x00\x02\x00\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\x02\x00\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\xff\xff\x77\x00\x78\x00\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\x65\x00\x02\x00\xff\xff\xff\xff\x69\x00\xff\xff\x6b\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\x02\x00\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\x4c\x00\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\x02\x00\x69\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x0a\x00\xff\xff\xff\xff\x73\x00\xff\xff\xff\xff\xff\xff\x77\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\xbe\x00\xbf\x00\xc0\x00\x77\x00\xc2\x00\xc3\x00\x4d\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xd2\x00\xd3\x00\xff\xff\xff\xff\x5f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\x6a\x00\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\xff\xff\xff\xff\x73\x00\x74\x00\x75\x00\x76\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xff\xff\x07\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x01\x16\x01\xff\xff\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\x21\x01\x22\x01\x23\x01\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\x2a\x01\x2b\x01\xff\xff\xff\xff\x2e\x01\x02\x00\x30\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\x0a\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\x16\x00\xff\xff\xd2\x00\xd3\x00\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xff\xff\x07\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x54\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x01\x16\x01\xff\xff\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\x21\x01\x22\x01\x23\x01\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\x2a\x01\x2b\x01\xff\xff\x73\x00\x2e\x01\xff\xff\x30\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd2\x00\xd3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xff\xff\x07\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x01\x16\x01\xff\xff\x18\x01\xff\xff\xff\xff\x02\x00\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\x21\x01\x22\x01\x0a\x00\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\x2a\x01\x2b\x01\x13\x00\xff\xff\x2e\x01\x16\x00\x30\x01\x18\x00\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\x02\x00\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\x02\x00\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x65\x00\xff\xff\x2c\x00\xff\xff\x69\x00\x02\x00\x6b\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x0a\x00\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\x02\x00\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x65\x00\xff\xff\x2c\x00\xff\xff\x69\x00\x02\x00\x6b\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x0a\x00\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\x02\x00\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x65\x00\xff\xff\x2c\x00\xff\xff\x69\x00\x02\x00\x6b\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x0a\x00\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\x0a\x00\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x61\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x70\x00\xff\xff\x2c\x00\x73\x00\xff\xff\x02\x00\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\x02\x00\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\x73\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\x02\x00\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\x73\x00\x1a\x00\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\x02\x00\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\x73\x00\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\x02\x00\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\x73\x00\xff\xff\xff\xff\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\xff\xff\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\xbf\x00\xc0\x00\x73\x00\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xdf\x00\xe0\x00\xe1\x00\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xe7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xff\xff\xff\xff\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd2\x00\x1d\x01\x1e\x01\x1f\x01\xd6\x00\xd7\x00\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\x2c\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xff\xff\x07\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x01\x16\x01\xff\xff\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\x21\x01\x22\x01\xff\xff\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\x2a\x01\x2b\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd2\x00\xff\xff\xff\xff\xd5\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xff\xff\x07\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x01\x16\x01\xff\xff\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\x21\x01\x22\x01\xff\xff\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\x2a\x01\x2b\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd2\x00\xff\xff\xff\xff\xd5\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xff\xff\x07\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x01\x16\x01\xff\xff\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\x21\x01\x22\x01\xff\xff\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\x2a\x01\x2b\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xff\xff\x07\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x01\x16\x01\xff\xff\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\x21\x01\x22\x01\xff\xff\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\x2a\x01\x2b\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xff\xff\x07\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x01\x16\x01\xff\xff\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\x21\x01\x22\x01\xff\xff\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\x2a\x01\x2b\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xff\xff\x07\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x01\x16\x01\xff\xff\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\x21\x01\x22\x01\xff\xff\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\x2a\x01\x2b\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xff\xff\x07\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x01\x16\x01\xff\xff\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\x21\x01\x22\x01\xff\xff\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\x2a\x01\x2b\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xff\xff\x07\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x15\x01\x16\x01\xff\xff\x18\x01\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\x21\x01\x22\x01\xff\xff\x24\x01\x25\x01\x26\x01\x27\x01\x28\x01\x29\x01\x2a\x01\x2b\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xd9\x00\xda\x00\xdb\x00\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xe8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xe8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xee\x00\xef\x00\xf0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xe8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xed\x00\xff\xff\xef\x00\xf0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xe8\x00\xff\xff\xff\xff\xff\xff\xec\x00\xff\xff\xff\xff\xef\x00\xf0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xe8\x00\xff\xff\xff\xff\xff\xff\xec\x00\xff\xff\xff\xff\xef\x00\xf0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xdc\x00\xdd\x00\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xdf\x00\xe0\x00\xe1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xdc\x00\xdd\x00\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xdf\x00\xe0\x00\xe1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xe4\x00\xe5\x00\xe6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xe8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xef\x00\xf0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xdb\x00\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xe8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xe8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xe1\x00\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xe7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xe7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xe7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xe7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xbe\x00\xbf\x00\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xbe\x00\xff\xff\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xbe\x00\xff\xff\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xbe\x00\xff\xff\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xbe\x00\xff\xff\xc0\x00\xff\xff\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xbe\x00\xff\xff\x04\x01\x05\x01\xc2\x00\xc3\x00\xff\xff\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf6\x00\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x01\x01\x01\xff\xff\xff\xff\x04\x01\x05\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x01\x1e\x01\x1f\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x25\x01\xff\xff\x27\x01\x28\x01\xff\xff\xff\xff\x2b\x01\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# + +happyTable :: HappyAddr +happyTable = HappyA# "\x00\x00\x70\x00\x83\x05\x8f\x02\x41\x05\x42\x05\x9b\x04\x93\x04\x85\x05\x4a\x04\x8e\x04\x8b\x04\x8a\x04\x8b\x04\x8c\x04\x0d\x01\x8c\x04\x0e\x01\x59\x03\x25\x05\x3e\x05\x3f\x05\x8c\x04\x0f\x01\x10\x01\x11\x01\x2d\x00\x2e\x00\x8c\x05\x12\x01\x10\x02\x11\x02\x12\x02\xf8\x04\x2f\x00\x87\x05\x30\x00\xf0\x02\x88\x05\xac\x04\x11\x02\x12\x02\xab\x04\x11\x02\xc8\x03\x21\x05\xac\x04\x11\x02\x12\x02\xac\x04\x11\x02\x12\x02\x2b\x03\xfa\x03\x90\x04\x91\x04\x92\x04\x93\x04\x64\x05\x91\x04\x92\x04\x93\x04\x66\x04\x68\x05\x91\x04\x92\x04\x93\x04\x2f\x03\x30\x03\x80\x05\x81\x05\x93\x04\x29\x03\xee\x01\x31\x05\x93\x04\x25\x04\x26\x04\x26\x05\x93\x04\x42\x03\x54\x02\xf2\x01\xf3\x01\x45\x04\xf2\x04\xc0\xff\x59\x05\x85\x02\x86\x02\x71\x05\x16\x04\x0e\x02\x8c\x03\x7a\x01\x6b\x05\x8e\x04\x41\x04\x26\x04\x85\x02\x86\x02\xc0\xff\x61\x02\x54\x03\x55\x01\x5a\x03\x5d\x03\xc1\xfc\x7d\x02\xbb\xff\x6f\x04\x70\x04\x40\x00\xdb\x04\x51\x03\x41\xfe\x78\x05\xed\x02\xc1\xfc\xb2\x02\x40\x00\x02\x03\x9c\x04\xc1\xfc\xc0\xff\x62\x03\x41\x00\x9d\x04\x9e\x04\x35\x05\x36\x05\x37\x05\x38\x05\x9e\x04\x41\x00\xc0\xff\x82\x05\x38\x05\x9e\x04\x36\x01\xfb\x03\xe5\x03\x34\x00\x16\x03\x17\x03\x83\x03\x06\x01\x16\x03\x17\x03\xc5\x02\xb8\x01\x33\x02\x06\x01\x93\x02\x79\x05\x37\x01\x56\x01\x03\x03\xc0\xff\x8e\x04\xd3\x02\xfc\x02\x35\x00\x06\x01\x14\x01\x56\x01\xac\x03\x34\x00\xf4\x04\x26\x04\xb3\x02\x06\x01\x62\x02\x0e\x02\x5a\x05\x67\x04\x63\x03\x34\x00\x78\x01\x33\x00\xf3\x04\x34\x02\x6c\x05\x7e\x02\x1e\x02\xf3\x01\xfd\x02\x43\x00\x44\x00\xbb\xff\x52\x03\x46\x00\x0f\x02\x47\x00\x43\x03\x43\x00\x44\x00\x07\x01\x7e\x02\x46\x00\x7f\x02\x47\x00\x34\x00\x4a\x00\x36\x03\x4c\x00\xf4\x01\x90\x02\x4c\x00\x1f\x04\x16\x01\x4a\x00\x0d\x01\x4c\x00\xf4\x01\x4d\x00\x4c\x00\x34\x00\x4d\x00\x91\x02\x92\x02\x37\x00\x4b\x04\x4d\x00\x31\x03\xec\x01\x4d\x00\x20\x01\xff\xff\xf1\x02\x15\x01\x71\x04\x4d\x00\x11\x00\x2f\x01\x11\x00\xd7\x01\x7a\x00\x88\x02\x7b\x00\x34\x00\x4b\x04\xec\x01\x93\x02\xf1\x02\xf9\x04\xec\x01\x27\x04\x5b\x03\x87\x02\x11\x00\x4d\x00\x71\x04\x11\x00\xaf\x01\x4d\x00\xb0\x01\x71\x00\x72\x00\x9f\x02\x2a\x03\x73\x00\x74\x00\x20\x01\x75\x00\x68\x04\x69\x04\x47\x00\x27\x04\x11\x00\x1d\x03\x51\x05\x2a\x03\x0f\x02\x11\x00\x20\x01\x94\x04\xec\x01\x95\x04\x96\x04\x76\x00\x11\x00\xfe\x02\x5b\x03\x10\x02\xf9\x02\x0e\x00\x0f\x00\x10\x00\x77\x00\x40\x05\x78\x00\x79\x00\x7a\x00\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x43\x05\xff\xff\x0e\x02\x43\x05\x31\x00\x22\x02\x31\x00\x31\x00\xf4\x01\x40\x05\x4c\x00\xec\x01\x31\x00\xfe\x01\x31\x00\x13\x02\x31\x00\x5b\x03\xff\x02\xec\x01\x4d\x00\xfa\x02\x7f\x03\xf3\x01\x13\x02\x5b\x03\x94\x04\x13\x02\x95\x04\x96\x04\x94\x04\x13\x02\x95\x04\x96\x04\x13\x02\x94\x04\x18\x02\x95\x04\x96\x04\x27\x04\x94\x04\xff\xff\x95\x04\x96\x04\x94\x04\x11\x00\x95\x04\x96\x04\x94\x04\x10\x02\x95\x04\x96\x04\x9f\x04\xfb\x01\xa0\x04\xe2\x02\x47\x00\x9f\x04\xfa\x01\xa0\x04\x31\x03\x47\x00\x9f\x04\x20\x01\xa0\x04\x31\x03\x47\x00\x67\x01\x20\x01\x11\x00\xa1\x04\x0f\x00\x10\x00\xaf\x02\x11\x00\xa1\x04\x0f\x00\x10\x00\x11\x00\x0e\x02\xa1\x04\x0f\x00\x10\x00\x11\x00\xb8\x01\xce\x00\x87\x04\xeb\x01\x11\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\x81\x02\xf4\x01\x2c\x04\x4c\x00\x6a\x01\x30\x01\x31\x01\x73\x00\x1e\x01\x0f\x02\x01\x02\x27\x01\x28\x01\x4d\x00\xff\x01\xe9\x00\x1d\x01\x23\x02\x73\x00\x1e\x01\x20\x01\xb0\x02\x37\x00\xea\x00\xeb\x00\x00\x02\x11\x00\x2d\x04\xec\x00\x00\x02\xe3\x02\xf2\x01\x0e\x02\xcf\x00\x32\x01\x38\x01\x3d\x00\x3e\x00\x3f\x00\x24\x03\x11\x00\x93\xfe\x1f\x01\x21\x01\x93\xfe\x20\x01\x58\x03\x54\x03\xf3\x01\x95\xfe\xf7\x01\x11\x00\xe3\x03\xf4\x01\x21\x01\x4c\x00\x50\x05\x83\x03\x81\x00\xed\x00\x95\xfe\x0e\x02\xf1\x01\x23\x02\xce\x00\x4d\x00\x20\x01\x77\x02\x87\x03\xe6\x00\xe7\x00\xe8\x00\x11\x00\x78\x02\x03\x02\x0e\x02\xbb\x03\x40\x00\x28\x02\xff\xff\x25\x03\x14\x01\xe4\x03\xc9\x04\xc5\x04\xc6\x04\x0f\x02\xe9\x00\x29\x02\x7e\x03\xdb\x01\x41\x00\x47\x00\x0e\x02\xef\x02\xea\x00\xeb\x00\xa5\x03\x07\x01\x8c\x00\xec\x00\x15\x01\x0e\x02\x79\x02\xdc\x01\xcf\x00\xa1\x01\xaf\x04\x04\x02\x07\x01\x7f\x03\x4c\x01\x39\x03\xf3\x01\x4d\x00\xee\x00\xef\x00\xf0\x00\x8a\xfd\xe9\x01\xea\x01\xeb\x01\xf1\x00\x7f\x03\xec\x01\x8f\x00\xc3\x04\x67\x01\xf2\x00\xd2\x00\xed\x01\xed\x00\x0f\x02\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\xb0\x04\xed\x04\x7a\x03\xbe\x01\xf8\x03\xf3\x01\x6b\x01\xc7\x04\x73\x00\x1e\x01\xc3\x02\x43\x00\x44\x00\xec\x04\x45\x00\x46\x00\x6a\x01\x47\x00\x48\x00\x49\x00\x0f\x02\x15\x01\x13\x05\xf3\x01\x7e\x01\x0e\x02\x7f\x01\x4a\x00\x4b\x00\x4c\x00\xf4\x01\x78\x03\x4c\x00\x15\x01\x0f\x02\x6b\x01\xc7\x04\x73\x00\x1e\x01\x4d\x00\xa1\x00\xa2\x00\x4d\x00\x0e\x02\x21\x01\xd6\x04\xee\x00\xef\x00\xf0\x00\xbd\x01\xa3\x00\x72\x00\x0f\x02\xf1\x00\x73\x00\x74\x00\x8f\x00\x1f\x03\xff\xff\xf2\x00\xd2\x00\x0f\x02\xce\x00\xcc\x04\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\xab\x04\x21\x01\xbc\x01\x68\x04\x69\x04\x47\x00\xd3\x00\xa4\x00\x0f\x00\xd4\x00\xec\x01\xf9\x01\x4e\x04\x4f\x04\x95\xfe\x11\x00\xc8\x04\x7c\x00\x7d\x00\x8d\x02\x49\x00\xa5\x00\x0d\x03\xf4\x01\x33\x05\x4c\x00\xec\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xcf\x00\x4d\x01\xa4\x03\xac\x01\x4d\x00\x50\x04\x55\x04\xec\x01\x00\x02\xa1\x00\xa2\x00\x0e\x03\x0f\x03\xed\x01\x4e\x01\xa5\x03\x4f\x01\x50\x01\xe4\x01\xa3\x00\x72\x00\xa9\x01\x0f\x02\x73\x00\x74\x00\xf4\x01\x77\x00\x4c\x00\x78\x00\x79\x00\x7a\x00\xce\x00\x7b\x00\x7a\x03\x44\x01\x7e\x00\x7f\x00\x4d\x00\x48\x02\xd2\x02\x0f\x02\xaa\x01\xd3\x02\xf4\x01\x2c\x02\x4c\x00\xe1\x02\xd3\x00\xa4\x00\x0f\x00\xd4\x00\x5f\x05\xab\x01\x4e\x04\x4f\x04\x4d\x00\x11\x00\x64\x00\x7c\x00\x7d\x00\x08\x02\x67\x00\xa5\x00\x45\x01\x46\x01\x47\x01\x83\x01\xec\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xcf\x00\x32\x05\xff\xff\x09\x02\x0a\x02\x50\x04\x51\x04\x55\x02\x56\x02\x57\x02\xee\x00\xef\x00\xa1\x02\x52\x04\x2b\x01\x28\x01\x00\x02\xf1\x00\x80\x01\x1d\x01\x8f\x00\x73\x00\x1e\x01\xa3\x02\xd2\x00\x3d\x03\x3e\x03\x6e\x04\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\xa4\x02\x9b\x00\x9c\x00\x25\x01\x26\x01\x64\x00\x2b\x05\x72\x00\x2e\x02\x67\x00\x73\x00\x74\x00\x1f\x01\x2e\x04\x2f\x02\x20\x01\x2b\x02\x79\x03\x58\x02\x0f\x00\x10\x00\x11\x00\x2c\x02\x2f\x04\x21\x01\x77\x03\x11\x00\xc4\x04\xc5\x04\xc6\x04\x7a\x03\x78\x01\x82\x00\x83\x00\x84\x00\xd0\x03\x57\x02\x21\x02\x78\x03\x85\x00\x4e\x05\xc5\x04\xc6\x04\xa1\x00\xa2\x00\x7c\x00\x7d\x00\x0f\xfd\x22\x02\xee\x00\xef\x00\xa1\x02\x52\x04\xa3\x00\x72\x00\x48\x01\xf1\x00\x73\x00\x74\x00\x8f\x00\x81\x00\x8b\x00\xa3\x02\xd2\x00\xaf\x01\x81\x00\xb0\x01\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\xa4\x02\x9b\x00\x9c\x00\xd5\x04\xe1\x02\xce\x00\x58\x02\x0f\x00\x10\x00\xd3\x00\xa4\x00\x0f\x00\xd4\x00\xcb\x04\x11\x00\x64\x00\xd6\x04\x69\x01\x11\x00\x67\x00\x7c\x00\x7d\x00\x69\x01\x6a\x01\xa5\x00\x11\x03\xcc\x04\xaa\x04\x6a\x01\x8c\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\x8c\x00\x7a\x05\x12\x03\x13\x03\x8f\x00\xf6\x04\xab\x04\xec\x00\xff\xff\xa1\x00\xa2\x00\x7b\x05\xcf\x00\x5e\x05\x6b\x01\xc7\x04\x73\x00\x1e\x01\x7a\x03\xa3\x00\x72\x00\xa8\x02\x49\x01\x73\x00\x74\x00\x61\x05\x5f\x05\x6b\x01\xc7\x04\x73\x00\x1e\x01\x2f\x01\x27\x01\x28\x01\x1d\x02\x4d\x00\x4c\x00\x1d\x01\x9b\xfe\x73\x00\x1e\x01\x9b\xfe\x81\x00\xce\x00\x40\x04\x7d\x05\x4d\x00\xd3\x00\xa4\x00\x0f\x00\xd4\x00\x7e\x05\x21\x01\x82\x00\x83\x00\x84\x00\x11\x00\xff\xff\x7c\x00\x7d\x00\x85\x00\xec\x01\xa5\x00\x1f\x01\x1b\x01\x21\x01\x20\x01\xc8\x04\xf3\x00\xf4\x00\xf5\x00\xf6\x00\x11\x00\xff\xff\xec\x01\x21\x01\x19\x01\x9c\x01\x53\x01\xec\x00\xc8\x04\x6a\x01\x8b\x00\x8c\x00\xcf\x00\xff\xff\x8e\x00\x8f\x00\x18\x01\x6b\x01\x31\x01\x73\x00\x1e\x01\xa0\x02\xee\x00\xef\x00\xa1\x02\xa2\x02\xcc\x01\x7f\x00\xec\x01\xf1\x00\x13\x00\xcd\x01\x8f\x00\x87\x01\x25\x02\xa3\x02\xd2\x00\x88\x01\x14\x00\x89\x01\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\xa4\x02\x9b\x00\x9c\x00\x64\x00\x06\x02\x15\x00\x11\x03\x67\x00\x07\x02\x16\x00\x21\x01\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x0a\x03\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x16\x03\x17\x03\x24\x00\x6b\x01\x6c\x01\x73\x00\x1e\x01\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xc8\x01\x10\x00\x2e\x03\xa9\x02\xa6\x02\xa7\x02\xa2\x00\x11\x00\x11\x00\xc9\x01\x7d\x00\xee\x00\xef\x00\xa1\x02\xa2\x02\xa3\x00\x72\x00\x36\x02\xf1\x00\x73\x00\x74\x00\x8f\x00\x0c\x02\x11\x00\xa3\x02\xd2\x00\x2d\x03\x08\x03\x21\x01\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\xa4\x02\x9b\x00\x9c\x00\x0d\x04\xce\x00\x4c\x00\x0e\x00\x0f\x00\x10\x00\xd3\x00\xa4\x00\x0f\x00\xd4\x00\x86\x00\x11\x00\x4d\x00\x25\x02\x34\x01\x11\x00\x88\x00\x7c\x00\x7d\x00\xdf\x02\x58\x04\xa5\x00\x46\x00\x2c\x00\x47\x00\x8a\x00\x64\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xd1\x01\x6b\x04\xd2\x01\x36\x03\x81\x00\xd3\x01\xec\x00\xa5\x02\xa6\x02\xa7\x02\xa2\x00\xcf\x00\x59\x04\x5f\x04\xf4\x02\x82\x00\x83\x00\x84\x00\xf5\x02\xa3\x00\x72\x00\x1c\x01\x85\x00\x73\x00\x74\x00\x1d\x01\x00\x03\x73\x00\x1e\x01\xd6\x01\x6c\x04\x6d\x04\x20\x01\x69\x01\x6b\x01\x68\x03\x73\x00\x1e\x01\x11\x00\x6a\x01\x7c\x00\x7d\x00\xce\x00\x1d\x04\x8b\x00\x8c\x00\x20\x01\xd3\x00\xa4\x00\x0f\x00\xd4\x00\x1f\x01\x11\x00\x8d\x02\x20\x01\xf8\x02\x11\x00\x6a\x01\x7c\x00\x7d\x00\x11\x00\x58\x04\xa5\x00\x21\x01\x28\x05\xe6\x02\xfd\x04\xfb\x04\xf3\x00\xf4\x00\xf5\x00\xf6\x00\x21\x01\x29\x05\xf0\x02\x82\x00\x83\x00\x84\x00\xec\x00\xf9\x01\xbb\x02\x10\x00\x85\x00\xcf\x00\x59\x04\x5a\x04\x6e\x04\x11\x00\xde\x02\xc9\x01\x7d\x00\xdd\x02\x40\x04\xee\x00\xef\x00\xa1\x02\x5b\x04\x64\x00\x11\x00\xda\x02\xf1\x00\x67\x00\xdc\x02\x8f\x00\x8b\x00\x2a\x05\xa3\x02\xd2\x00\x8e\x00\x2b\x05\x81\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\xa4\x02\x9b\x00\x9c\x00\x09\x05\x0a\x05\x82\x00\x83\x00\x84\x00\x82\x00\x83\x00\x84\x00\x37\x00\x85\x00\xed\x03\x86\x00\x85\x00\x20\x01\xec\x01\x2d\x05\xe3\x02\x88\x00\xdb\x02\x11\x00\xbc\x04\x38\x01\x3d\x00\x3e\x00\x3f\x00\xd4\x02\x8a\x00\x53\x01\x56\x01\x4b\x02\x8d\x00\x8b\x00\x8c\x00\x2c\x02\x8b\x00\x8e\x00\x8f\x00\xc6\x02\x8e\x00\x2d\x05\xa1\x00\xa2\x00\x46\x00\x8d\x01\x47\x00\x8e\x01\xee\x00\xef\x00\xa1\x02\x5b\x04\xa3\x00\x72\x00\xd6\x02\xf1\x00\x73\x00\x74\x00\x8f\x00\x84\x02\xc5\x02\xa3\x02\xd2\x00\xbb\x02\xce\x00\x40\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\xa4\x02\x9b\x00\x9c\x00\x7f\x04\x80\x04\x74\x01\x0f\x00\x10\x00\x41\x00\xd3\x00\xa4\x00\x0f\x00\xd4\x00\x11\x00\xc2\x02\x4e\x04\x4f\x04\x36\x02\x11\x00\x4a\x02\x7c\x00\x7d\x00\xc0\x02\x11\x00\xa5\x00\xc9\x01\x7d\x00\x09\x05\x57\x05\xec\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xcf\x00\x29\x01\x2a\x01\xfb\xfc\x81\x00\x02\x05\xb0\x02\x0f\x00\x10\x00\xa1\x00\xa2\x00\x95\x02\x49\x02\x96\x02\x11\x00\x82\x00\x83\x00\x84\x00\xba\x02\xa3\x00\x72\x00\xb8\x02\x85\x00\x73\x00\x74\x00\xcb\x01\x9c\x01\x7a\x00\xb6\x02\x7b\x00\x30\x02\xb7\x02\xcc\x01\x7f\x00\x2c\x02\x43\x00\x44\x00\xcd\x01\x45\x00\x46\x00\x97\x02\x47\x00\x48\x00\x49\x00\x8b\x00\x8c\x00\xe9\x01\xd3\x00\xa4\x00\x0f\x00\xd4\x00\x4a\x00\x4b\x00\x4c\x00\xfe\x01\xfc\x01\x11\x00\x06\x02\x7c\x00\x7d\x00\x66\x02\x07\x02\xa5\x00\x4d\x00\xad\x02\x0f\x00\x10\x00\x8c\x02\xf3\x00\xf4\x00\xf5\x00\xf6\x00\x11\x00\x8b\x02\xb4\x02\x81\x00\xfa\x04\xfb\x04\xcd\x01\x06\x03\xcf\x02\xd0\x02\xee\x00\xef\x00\xa1\x02\x52\x04\x82\x00\x83\x00\x84\x00\xf1\x00\xce\x00\x8a\x02\x8f\x00\x85\x00\xcb\x03\xa3\x02\xd2\x00\x7e\x01\xcc\x03\x7f\x01\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\xa4\x02\x9b\x00\x9c\x00\xcb\x03\x58\x04\xcb\x03\x53\x01\x88\x04\x7d\x02\x4c\x05\x8b\x00\x8c\x00\xfb\x01\xfc\x01\x8e\x00\x8f\x00\x85\x02\x06\x01\x86\x00\x08\x01\x09\x01\xec\x00\x34\x01\x71\x02\x88\x00\x72\x02\xcf\x00\x0a\x05\xc1\xfc\x2b\x01\x28\x01\x83\x02\x37\x00\x8a\x00\x1d\x01\x7a\x02\x73\x00\x1e\x01\x38\x02\x7a\x00\xe3\x02\x7b\x00\x76\x02\xa1\x00\xa2\x00\x38\x01\x3d\x00\x3e\x00\x3f\x00\xce\x02\xcf\x02\xd0\x02\x06\x01\xa3\x00\x72\x00\x7a\x01\x76\x01\x73\x00\x74\x00\x14\x04\x1f\x01\x15\x04\x75\x02\x20\x01\x38\x02\x7a\x00\x0c\x04\x7b\x00\x0d\x04\x11\x00\x37\x00\xb4\x02\x21\x01\x7b\x01\xb2\x01\xcd\x01\xe8\x02\xe9\x02\xea\x02\xeb\x02\xec\x02\xd3\x00\xa4\x00\x0f\x00\xd4\x00\xf7\x01\x3f\x00\x40\x00\x6e\x02\x7e\x01\x11\x00\x7f\x01\x7c\x00\x7d\x00\x6d\x02\xb8\x01\xa5\x00\xdd\x03\xaa\x02\x0f\x00\x10\x00\x41\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\x11\x00\x6c\x02\xee\x00\xef\x00\xa1\x02\x5b\x04\x7b\x01\x7c\x01\xce\x00\xf1\x00\x6b\x02\xc7\x03\x8f\x00\xc8\x03\x66\x02\xa3\x02\xd2\x00\x41\x01\x42\x01\x40\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\xa4\x02\x9b\x00\x9c\x00\x78\x01\x76\x01\x69\x03\x84\x01\x44\x00\x41\x00\x65\x02\x46\x00\x56\x00\x47\x00\xcb\x01\x9c\x01\x7a\x00\x67\x02\x7b\x00\xe6\x01\xec\x00\x57\x00\xb8\x01\x58\x00\x59\x00\xcf\x00\x5d\x02\xd9\x03\xda\x03\xdb\x03\x5b\x00\xb6\x01\x43\x00\x44\x00\xe2\x04\x45\x00\x46\x00\x4d\x02\x47\x00\x48\x00\x49\x00\x8f\x02\x75\x01\x76\x01\xa1\x00\xa2\x00\x27\x02\x6a\x01\x4a\x00\x4b\x00\x4c\x00\x4c\x02\x65\x00\x66\x00\xa3\x00\x72\x00\x68\x00\x69\x00\x73\x00\x74\x00\x4d\x00\xcb\x01\x9c\x01\x7a\x00\x4a\x02\x7b\x00\x3e\x01\x3f\x01\x40\x01\x41\x01\x43\x00\x44\x00\x36\x02\x45\x00\x46\x00\x35\x02\x47\x00\x48\x00\x49\x00\x49\x03\x4a\x03\x4b\x03\xd3\x00\xa4\x00\x0f\x00\xd4\x00\x4a\x00\x4b\x00\x4c\x00\x49\x02\x64\x04\x11\x00\x65\x04\x7c\x00\x7d\x00\x2c\x01\x2d\x01\xa5\x00\x4d\x00\x3e\x03\x3f\x03\x40\x03\xcc\x04\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xee\x00\xef\x00\xa1\x02\xa2\x02\xf5\x02\xf6\x02\xce\x00\xf1\x00\x32\x02\x44\x04\x8f\x00\x45\x04\x47\x02\xa3\x02\xd2\x00\xfe\x03\xff\x03\x00\x04\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\xa4\x02\x9b\x00\x9c\x00\x72\x04\xff\x03\x00\x04\x65\x04\xff\x03\x00\x04\x64\x03\x65\x03\x56\x00\xb9\x04\xff\x03\x00\x04\x6d\x05\xff\x03\x00\x04\x46\x02\xec\x00\x57\x00\x45\x02\x58\x00\x59\x00\xcf\x00\xb3\x02\x6f\x01\x70\x01\x71\x01\x5b\x00\x72\x01\x31\x02\x37\x00\xe1\x04\x1d\x01\x2d\x02\x73\x00\x1e\x01\x2a\x02\xea\x04\xcd\x04\xeb\x04\x0c\x02\xa1\x00\xa2\x00\x38\x01\x3d\x00\x3e\x00\x3f\x00\x8d\x02\x49\x00\x65\x00\x66\x00\xa3\x00\x72\x00\x68\x00\x69\x00\x73\x00\x74\x00\xdd\x04\x1f\x01\xde\x04\x0d\x01\x20\x01\x8e\x05\xff\x03\x00\x04\x38\x02\x7a\x00\x11\x00\x7b\x00\x9a\x04\x21\x01\x9b\x04\xb4\x02\xea\x04\x06\x05\xeb\x04\xcd\x01\x7b\x01\x07\x04\xd3\x00\xa4\x00\x0f\x00\xd4\x00\x90\x02\x5d\x02\x40\x00\xb6\x01\xfe\x01\x11\x00\xbf\x03\x7c\x00\x7d\x00\xf1\x03\xf2\x03\xa5\x00\xe7\x03\x92\x02\x56\x04\x4b\x03\x41\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xee\x00\xef\x00\xa1\x02\xa2\x02\xef\x04\xf0\x04\xce\x00\xf1\x00\xd7\x01\x7a\x00\x8f\x00\x7b\x00\xbe\x03\xa3\x02\xd2\x00\x93\x02\xbd\x03\xba\x03\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\xa4\x02\x9b\x00\x9c\x00\x8d\x05\xff\x03\x00\x04\xb4\x03\x37\x00\xb3\x03\x83\x01\x84\x01\x44\x00\xb2\x03\xdc\xfc\x46\x00\xe3\x02\x47\x00\xfa\xfc\xe5\xfc\xec\x00\x38\x01\x3d\x00\x3e\x00\x3f\x00\xcf\x00\xe3\xfc\x85\x01\xd1\x01\x4c\x00\xd2\x01\xe4\xfc\xf9\xfc\xd3\x01\x43\x00\x44\x00\xd4\x01\x45\x00\x46\x00\x4d\x00\x47\x00\x48\x00\x49\x00\xdd\xfc\xa1\x00\xa2\x00\xde\xfc\x34\x02\xd5\x01\xce\x00\x4a\x00\x4b\x00\x4c\x00\xb1\x03\xa3\x00\x72\x00\xb0\x03\xd6\x01\x73\x00\x74\x00\x20\x01\xaf\x03\x4d\x00\x40\x00\xd7\x01\x7a\x00\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x91\x05\xff\x03\x00\x04\xae\x03\xaa\x03\x41\x00\xab\x03\xa9\x03\xa2\x03\x98\x03\xd3\x00\xa4\x00\x0f\x00\xd4\x00\x6a\x01\xbf\x02\x86\x03\x2d\x02\xcf\x00\x11\x00\x85\x03\x7c\x00\x7d\x00\x84\x03\x82\x03\xa5\x00\x7b\x03\x76\x03\x75\x03\x74\x03\x01\x05\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xee\x00\xef\x00\xa1\x02\xf0\x03\x73\x03\x72\x03\x71\x03\xf1\x00\x70\x03\x6b\x03\x8f\x00\x6f\x03\x6e\x03\xa3\x02\xd2\x00\x68\x03\x59\x03\x67\x03\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\xa4\x02\x9b\x00\x9c\x00\x67\x01\x0e\xfd\x4e\x03\x56\x03\x49\x03\x43\x00\x44\x00\x47\x03\x45\x00\x46\x00\x45\x03\x47\x00\x48\x00\x49\x00\x3b\x03\x8a\x00\x27\x03\x1c\x03\x1b\x03\x2f\x01\x1a\x03\x4a\x00\x4b\x00\x4c\x00\x22\x03\x0d\x01\xe7\x03\xc4\x03\x30\x04\x37\x00\x32\x04\x2b\x04\x25\x04\x4d\x00\x23\x04\x6a\x05\x1f\x04\xe3\x02\x1a\x04\x22\x04\xa1\x00\xa2\x00\x38\x01\x3d\x00\x3e\x00\x3f\x00\xd0\x00\x21\x04\x05\xfd\x8f\x00\xa3\x00\x72\x00\xd1\x00\xd2\x00\x73\x00\x74\x00\x04\xfd\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x06\xfd\x1d\x04\x1c\x04\x54\x03\x10\x04\x0a\x04\x04\x04\x02\x04\xfe\x03\x49\x01\xf8\x03\x05\x04\xf6\x03\xd3\x00\xa4\x00\x0f\x00\xd4\x00\xfa\x03\xbf\x02\x40\x00\x6a\x00\xec\x03\x11\x00\xd7\x03\x7c\x00\x7d\x00\xe7\x03\xde\x03\xa5\x00\xd8\x03\x37\x00\x33\x02\x98\x04\x41\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xe3\x02\x07\x01\xa1\x00\xa2\x00\xce\x03\x38\x01\x3d\x00\x3e\x00\x3f\x00\xcf\x03\xc4\x03\x8f\x00\xa3\x00\x72\x00\x90\x04\x8a\x04\x73\x00\x74\x00\x87\x04\x07\x01\x85\x04\x37\x00\x54\x03\x88\x03\x9a\x00\x9b\x00\x9c\x00\x4a\x01\x89\x03\x4b\x01\xc7\x02\x06\x01\x65\x02\xb8\x01\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x81\x04\x38\x04\xd3\x00\xa4\x00\x0f\x00\xd4\x00\x7b\x03\x79\x04\x78\x04\x40\x00\x77\x04\x11\x00\x76\x04\x7c\x00\x7d\x00\x04\x04\x02\x04\xa5\x00\x43\x00\x44\x00\x06\x01\x45\x00\x46\x00\x41\x00\x47\x00\x48\x00\x49\x00\x4e\x04\x02\x04\xa1\x00\xa2\x00\x48\x04\x43\x04\x3c\x04\x4a\x00\x4b\x00\x4c\x00\x3e\x04\x40\x00\xa3\x00\x72\x00\x3f\x04\x37\x00\x73\x00\x74\x00\x3b\x04\x4d\x00\x3a\x04\x4a\x01\x39\x04\x4b\x01\x38\x04\x41\x00\xe8\x04\xe5\x04\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xe4\x04\xe0\x04\xdf\x04\xd8\x04\xd3\x04\x47\x01\x07\x01\xbc\x04\x02\x04\x95\x01\x0f\x00\x10\x00\xb3\x04\xb2\x04\xa8\x04\x31\x05\x23\x05\x11\x00\x1e\x05\x7c\x00\x7d\x00\x25\x05\x1d\x05\xa5\x00\x5d\x03\x43\x00\x44\x00\x1c\x05\x45\x00\x46\x00\x13\x05\x47\x00\x48\x00\x49\x00\x11\x05\x12\x05\x0f\x05\x0e\x05\x40\x00\x56\x01\x0d\x05\x4a\x00\x4b\x00\x4c\x00\x0c\x05\x67\x05\x63\x05\x00\x05\x64\x05\x66\x05\x5d\x05\x49\x03\x41\x00\x4d\x00\x43\x00\x44\x00\x07\x01\x45\x00\x46\x00\x4c\x05\x47\x00\x48\x00\x49\x00\x47\x05\x4b\x05\x35\x05\x3e\x05\x7f\x05\x7c\x05\x3d\x05\x4a\x00\x4b\x00\x4c\x00\x37\x00\x3c\x05\x75\x05\x71\x05\x3b\x05\x80\x05\x5e\x03\xc4\x03\x5f\x03\x4d\x00\x5b\x05\x5c\xfe\x04\x04\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x02\x04\x6c\x03\x71\x01\x8f\x00\x72\x01\x6a\x05\x37\x00\x91\x05\x1d\x01\x04\x04\x73\x00\x1e\x01\x5e\x03\x02\x04\x5f\x03\x94\x01\x9a\x00\x9b\x00\x9c\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x43\x00\x44\x00\x06\x01\x45\x00\x46\x00\xbd\x03\x47\x00\x48\x00\x49\x00\x8c\x05\x8b\x05\x1f\x01\x97\x05\x96\x05\x20\x01\x40\x00\x4a\x00\x4b\x00\x4c\x00\x37\x00\x11\x00\x02\x04\x99\x05\x21\x01\x0b\x01\x5e\x03\xca\x01\x5f\x03\x4d\x00\x41\x00\x8b\x01\xb9\x01\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xa1\x00\xa2\x00\x40\x00\x53\x01\x3c\x01\xb1\x01\x81\x01\xad\x01\x34\x01\x19\x01\xa3\x00\x72\x00\x0c\x03\x08\x03\x73\x00\x74\x00\x41\x00\xc8\x02\x97\x02\x0b\x03\x03\x03\x37\x00\xec\x02\x0a\x03\x00\x03\x52\x02\x98\x02\xc9\x02\xfa\x02\x3b\x00\x9a\x02\xe6\x02\xd4\x02\xc6\x02\xca\x02\x3d\x00\x3e\x00\x3f\x00\x40\x00\x95\x01\x0f\x00\x10\x00\xb8\x02\xe0\x01\x81\x02\x63\x02\x1f\x02\x11\x00\x0c\x02\x7c\x00\x7d\x00\x6f\x02\x41\x00\xa5\x00\x43\x00\x44\x00\x07\x02\x45\x00\x46\x00\x04\x02\x47\x00\x48\x00\x49\x00\xc1\x03\xc0\x03\x11\x03\xbf\x03\x4c\x03\xac\x03\x61\x02\x4a\x00\x4b\x00\x4c\x00\x47\x03\x45\x03\xa5\x03\x40\x00\x43\x00\x44\x00\x43\x03\x45\x00\x46\x00\x4d\x00\x47\x00\x48\x00\x49\x00\x3b\x03\x56\x03\x86\x03\x56\x03\x41\x00\x25\x03\x22\x03\x4a\x00\x4b\x00\x4c\x00\x7c\x03\x20\x03\x13\x00\x18\x03\x17\x03\x14\x03\x36\x04\x35\x04\x2d\x03\x4d\x00\x14\x00\x7b\x03\x34\x04\x33\x04\x30\x04\x23\x04\x32\x04\x43\x00\x44\x00\x18\x04\x45\x00\x46\x00\x15\x00\x47\x00\x48\x00\x49\x00\x15\x04\x12\x04\x17\x00\x18\x00\x19\x00\x0a\x04\x06\x04\x4a\x00\x4b\x00\x4c\x00\xcb\x02\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x08\x04\x02\x04\x24\x00\x4d\x00\xec\x03\xe5\x03\xde\x03\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x43\x00\x44\x00\xc5\x03\x45\x00\x46\x00\xc4\x03\x47\x00\x48\x00\x49\x00\xc2\x03\x83\x04\x85\x04\x81\x00\x73\x04\x61\x02\x6e\x04\x4a\x00\x4b\x00\x4c\x00\xcf\x01\x3c\x04\xd0\x01\x57\x04\x82\x00\x83\x00\x84\x00\x97\x02\x4c\x04\x4d\x00\x37\x00\x85\x00\xeb\x04\xe8\x04\xe6\x04\x98\x02\x99\x02\xdb\x04\xd9\x04\x9a\x02\xd8\x04\x9d\x02\x69\x01\x9b\x02\x3d\x00\x3e\x00\x3f\x00\xd6\x04\x6a\x01\xd3\x04\xd1\x04\xc2\x04\xba\x04\x8b\x00\x8c\x00\xa8\x04\x2c\x03\x8e\x00\x8f\x00\x37\x00\xc1\x04\x15\x02\x16\x02\xb0\x04\x98\x02\x99\x02\x98\x04\x2f\x05\x9a\x02\x2e\x05\x23\x05\x20\x05\x9b\x02\x3d\x00\x3e\x00\x3f\x00\x07\x05\x1f\x05\x8f\x00\x56\x03\x0f\x05\xff\x04\xcd\x02\xf6\x04\x58\x05\x40\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\xee\x04\x67\x05\x55\x05\x45\x05\x44\x05\x41\x00\xee\x03\x60\x05\x5f\x05\x37\x00\x76\x05\x75\x05\x6e\x05\x8f\x05\x98\x02\x99\x02\x86\x05\x81\x00\x9a\x02\x84\x05\x40\x00\x94\x05\x9b\x02\x3d\x00\x3e\x00\x3f\x00\x93\x05\x92\x05\x82\x00\x83\x00\x84\x00\x00\x00\x00\x00\x00\x00\x41\x00\x85\x00\x97\x05\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x69\x01\x9c\x02\x00\x00\x00\x00\xa3\x00\x72\x00\x6a\x01\x00\x00\x73\x00\x74\x00\x00\x00\x8b\x00\x8c\x00\x00\x00\x00\x00\x8e\x00\x8f\x00\x00\x00\x40\x00\x00\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x9c\x02\x00\x00\x41\x00\xa4\x00\x0f\x00\x10\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x00\x00\x9d\x02\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8f\x00\x9c\x02\x91\x01\x72\x00\x4d\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\xa4\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x02\x00\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x00\x00\x92\x01\x0f\x00\x10\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x72\x02\x73\x02\x00\x00\x46\x04\x00\x00\x4d\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x02\x99\x02\xa1\x00\xa2\x00\x9a\x02\x00\x00\x9d\x02\x00\x00\x9b\x02\x3d\x00\x3e\x00\x3f\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x00\x00\xe0\x04\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x02\x99\x02\x00\x00\x00\x00\x9a\x02\x00\x00\x00\x00\x00\x00\x9b\x02\x3d\x00\x3e\x00\x3f\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x40\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x81\x00\x52\x01\xaf\xfe\x00\x00\x00\x00\xaf\xfe\x41\x00\x57\x05\x00\x00\x00\x00\x37\x00\x82\x00\x83\x00\x84\x00\x00\x00\x98\x02\x99\x02\x00\x00\x85\x00\x9a\x02\x00\x00\x40\x00\x00\x00\x9b\x02\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x53\x01\x00\x00\x00\x00\x00\x00\x8b\x00\x8c\x00\x00\x00\x00\x00\x8e\x00\x8f\x00\x81\x00\xc4\x01\x9c\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x00\x83\x00\x84\x00\xc5\x01\xc6\x01\xc7\x01\xc8\x01\x85\x00\x40\x00\x00\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x9c\x02\x00\x00\x41\x00\x00\x00\x00\x00\x53\x01\x4a\x00\x4b\x00\x4c\x00\x8b\x00\x8c\x00\x00\x00\x00\x00\x8e\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x00\x00\x9d\x02\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x9c\x02\x00\x00\x00\x00\x4d\x00\x14\x05\x00\x00\x00\x00\x15\x05\x16\x05\x17\x05\x00\x00\x00\x00\x18\x05\x3f\x00\x00\x00\x9d\x02\x37\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x49\x05\x00\x00\x00\x00\x18\x05\x3f\x00\x00\x00\x19\x05\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4f\x05\x00\x00\x4d\x00\x37\x00\x00\x00\x00\x00\x00\x00\x40\x00\x98\x02\x99\x02\x00\x00\x00\x00\x9a\x02\x00\x00\x9d\x02\x13\x00\x9b\x02\x3d\x00\x3e\x00\x3f\x00\x00\x00\x41\x00\x37\x00\x14\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x72\x05\x17\x05\x15\x00\x00\x00\x18\x05\x3f\x00\x16\x00\x41\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x40\x00\x73\x05\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x9c\x02\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x1a\x05\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x1a\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4d\x00\x00\x00\x00\x00\x81\x00\x81\x01\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x9d\x02\x00\x00\x82\x00\x83\x00\x84\x00\x00\x00\x00\x00\x4d\x00\x37\x00\x85\x00\x00\x00\x00\x00\x1b\x02\xe9\x03\xc9\x02\x00\x00\x3b\x00\x9a\x02\x00\x00\x00\x00\x1a\x05\xca\x02\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x53\x01\x00\x00\x00\x00\x00\x00\x8b\x00\x8c\x00\x00\x00\x00\x00\x8e\x00\x8f\x00\x37\x00\x00\x00\x00\x00\x00\x00\x1a\x02\xe8\x03\xc9\x02\x00\x00\x3b\x00\x9a\x02\x00\x00\x00\x00\x00\x00\xca\x02\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\xbb\x03\x61\x04\xc9\x02\x00\x00\x3b\x00\x9a\x02\x00\x00\x41\x00\x00\x00\xca\x02\x3d\x00\x3e\x00\x3f\x00\x00\x00\x6d\x01\x6e\x01\x6f\x01\x70\x01\x71\x01\x00\x00\x72\x01\x00\x00\x40\x00\x00\x00\x1d\x01\x37\x00\x73\x00\x1e\x01\x37\x03\x00\x00\x38\x03\x99\x02\x00\x00\x00\x00\x9a\x02\x00\x00\x41\x00\x00\x00\x9b\x02\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcb\x02\x1f\x01\x40\x00\x00\x00\x20\x01\x00\x00\x6b\x03\x6f\x01\x70\x01\x71\x01\x11\x00\x72\x01\x00\x00\x21\x01\x00\x00\x1d\x01\x41\x00\x73\x00\x1e\x01\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\xcb\x02\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x1f\x01\x00\x00\x00\x00\x20\x01\x41\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x11\x00\x45\x00\x46\x00\x21\x01\x47\x00\x48\x00\x49\x00\x00\x00\xcb\x02\x9d\x02\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x9c\x02\x9d\x02\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x00\x00\x9d\x02\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x03\x99\x02\x00\x00\x4d\x00\x9a\x02\x00\x00\x00\x00\x00\x00\x9b\x02\x3d\x00\x3e\x00\x3f\x00\x1e\x03\x28\x01\x00\x00\x9d\x02\x00\x00\x1d\x01\x00\x00\x73\x00\x1e\x01\x00\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe8\x03\x99\x02\x00\x00\x00\x00\x9a\x02\x00\x00\x00\x00\x00\x00\x9b\x02\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x1f\x01\x00\x00\x00\x00\x20\x01\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x11\x00\x37\x00\x00\x00\x21\x01\x00\x00\x00\x00\x79\x04\x99\x02\x00\x00\x00\x00\x9a\x02\x00\x00\x41\x00\x00\x00\x9b\x02\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x4d\x01\x61\x04\x99\x02\x00\x00\x00\x00\x9a\x02\x00\x00\x41\x00\x00\x00\x9b\x02\x3d\x00\x3e\x00\x3f\x00\xc2\x01\x00\x00\x4f\x01\x50\x01\x00\x00\x00\x00\x00\x00\x9c\x02\x00\x00\x40\x00\x00\x00\x00\x00\x77\x00\x00\x00\x78\x00\x79\x00\x7a\x00\x00\x00\x7b\x00\x00\x00\x00\x00\x7e\x00\x7f\x00\x41\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x9c\x02\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x9c\x02\x9d\x02\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x9c\x02\x9d\x02\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x00\x00\x9d\x02\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x04\x99\x02\x00\x00\x4d\x00\x9a\x02\x00\x00\x00\x00\x00\x00\x9b\x02\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x37\x00\x9d\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbd\x04\x00\x00\x00\x00\x00\x00\xbe\x04\x3d\x00\x3e\x00\x3f\x00\x00\x00\xbf\x04\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbd\x04\x00\x00\x00\x00\x00\x00\xbe\x04\x3d\x00\x3e\x00\x3f\x00\x40\x00\x4d\x05\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x04\x00\x00\xb8\x04\x00\x00\x00\x00\x00\x00\x41\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x37\x00\x00\x00\x37\x02\x40\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x41\x00\x00\x00\x00\x00\x00\x00\x9c\x02\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x4a\x00\x4b\x00\x4c\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4d\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x43\x00\x44\x00\x9d\x02\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x43\x00\x44\x00\x9d\x02\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x4d\x00\x00\x00\x00\x00\x81\x00\x52\x01\x42\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x9d\x02\x00\x00\x82\x00\x83\x00\x84\x00\x00\x00\x00\x00\x4d\x00\x00\x00\x85\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x01\x4a\x00\x4b\x00\x4c\x00\x8b\x00\x8c\x00\x00\x00\x00\x00\x8e\x00\x8f\x00\x00\x00\x38\x02\x7a\x00\x4d\x00\x7b\x00\x00\x00\x00\x00\xcc\x01\x7f\x00\x37\x00\x00\x00\xdd\x01\xcd\x01\x39\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x81\x00\x05\x05\x00\x00\xde\x01\xdf\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x00\x83\x00\x84\x00\x00\x00\x37\x00\x00\x00\xe2\x01\x85\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x01\x00\x00\x40\x00\x00\x00\x8b\x00\x8c\x00\x00\x00\x00\x00\x8e\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x37\x00\x00\x00\xe2\x01\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x02\x00\x00\x00\x00\x41\x00\x37\x00\x00\x00\x00\x00\x00\x00\x52\x02\x00\x00\x3a\x00\x00\x00\x3b\x00\x42\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xde\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x41\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\xe0\x01\x47\x00\xe3\x01\x49\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x01\x00\x00\x00\x00\xe4\x01\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\xe3\x01\x49\x00\x4e\x01\x00\x00\x4f\x01\x50\x01\x42\x00\x00\x00\x00\x00\x6f\x05\x4b\x00\x4c\x00\x00\x00\x00\x00\x77\x00\x00\x00\x78\x00\x79\x00\x7a\x00\x00\x00\x7b\x00\x4d\x00\x00\x00\x7e\x00\x7f\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\xe4\x01\x47\x00\x48\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x02\x4a\x00\x4b\x00\x4c\x00\x37\x00\x00\x00\x00\x00\x00\x00\x52\x02\x00\x00\x3a\x00\x00\x00\x3b\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xac\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x02\x00\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x52\x02\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x11\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf3\x03\x40\x00\x00\x00\xf6\x03\x37\x00\x00\x00\x00\x00\x00\x00\x52\x02\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x41\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x01\x00\x00\xf3\x03\x40\x00\x00\x00\xf4\x03\x37\x00\x00\x00\x00\x00\x00\x00\x52\x02\x00\x00\x3a\x00\xc3\x02\x3b\x00\x4f\x01\x50\x01\x41\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x77\x00\x00\x00\x78\x00\x79\x00\x7a\x00\x42\x00\x7b\x00\x40\x00\x00\x00\x7e\x00\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x42\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\xf3\x03\x00\x00\x00\x00\xb6\x04\x37\x00\x00\x00\x00\x00\x00\x00\x52\x02\x4d\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x51\x02\x00\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x52\x02\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x37\x00\x00\x00\x41\x02\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x41\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\xd7\x02\x43\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x37\x00\x00\x00\x41\x02\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x41\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x42\x02\x43\x02\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x42\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x37\x00\x00\x00\x41\x02\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\xb8\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x00\x00\x41\x02\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\xb7\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x37\x00\x00\x00\xb5\x03\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x41\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x03\x00\x00\x4d\x01\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x37\x00\x00\x00\x41\x02\x00\x00\x39\x00\x00\x00\x3a\x00\xc2\x01\x3b\x00\x4f\x01\x50\x01\x41\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x77\x00\xb4\x03\x78\x00\x79\x00\x7a\x00\x42\x00\x7b\x00\x40\x00\x00\x00\x7e\x00\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x42\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x37\x00\x00\x00\x41\x02\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x4d\x00\x00\x00\x8f\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\xcf\x03\xa4\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x37\x00\x00\x00\x1a\x04\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x51\x05\x00\x00\xa5\x01\x40\x00\x00\x00\x00\x00\x37\x00\x00\x00\x38\x00\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\xa1\x00\xa2\x00\x41\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x40\x00\x00\x00\x00\x00\x37\x00\x00\x00\xe7\x01\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x41\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x42\x00\x00\x00\x40\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x42\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x52\x05\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x37\x00\x00\x00\x8e\x01\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x4d\x00\x00\x00\x8f\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\xa2\x01\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x18\x02\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x19\x02\x37\x00\x00\x00\x1a\x04\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\xa1\x00\xa2\x00\x41\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x40\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x18\x02\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x41\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x42\x00\x00\x00\x40\x00\x11\x00\x17\x04\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x42\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x37\x00\x00\x00\x00\x00\x00\x00\x18\x02\x00\x00\x3a\x00\x00\x00\x3b\x00\x4d\x00\x00\x00\x8f\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbe\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x10\x04\x37\x00\x00\x00\x00\x00\x00\x00\x18\x02\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\xfc\x03\x37\x00\x00\x00\x00\x00\x00\x00\x18\x02\x00\x00\x3a\x00\x00\x00\x3b\x00\xa1\x00\xa2\x00\x41\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x40\x00\x00\x00\xc9\x03\x37\x00\x00\x00\x00\x00\x00\x00\x18\x02\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x41\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x42\x00\x00\x00\x40\x00\x11\x00\x48\x04\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x42\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x37\x00\x00\x00\xf7\x04\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x4d\x00\x00\x00\x8f\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x18\x02\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x54\x05\x37\x00\x00\x00\x00\x00\x00\x00\x1b\x02\x00\x00\x3a\x00\x00\x00\x3b\x00\xa1\x00\xa2\x00\x41\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x40\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x1a\x02\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x41\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x42\x00\x00\x00\x40\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x42\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x37\x00\x00\x00\x00\x00\x00\x00\xbb\x03\x00\x00\x3a\x00\x00\x00\x3b\x00\x4d\x00\x00\x00\x8f\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\xac\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\xca\x03\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\xf3\x04\x00\x00\x3a\x00\x00\x00\x3b\x00\xa1\x00\xa2\x00\x41\x00\x00\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x40\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x01\x00\x00\x00\x00\x41\x00\x00\x00\x38\x01\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x42\x00\x00\x00\x40\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x42\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\xe1\x02\x47\x00\x48\x00\x49\x00\x00\x00\x38\x01\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\xd8\x02\x47\x00\x48\x00\x49\x00\x00\x00\x38\x01\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x37\x00\x00\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd6\x02\x00\x00\x00\x00\x41\x00\x00\x00\x38\x01\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x02\x00\x00\x00\x00\x41\x00\x00\x00\x38\x01\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x4e\x03\x47\x00\x48\x00\x49\x00\x00\x00\x38\x01\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x05\x04\x47\x00\x48\x00\x49\x00\x00\x00\x38\x01\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x37\x00\x00\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xea\x03\x00\x00\x00\x00\x41\x00\x00\x00\x38\x01\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\x04\x00\x00\x00\x00\x41\x00\x00\x00\x38\x01\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x49\x04\x47\x00\x48\x00\x49\x00\x00\x00\x38\x01\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x05\x05\x47\x00\x48\x00\x49\x00\x00\x00\x38\x01\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x37\x00\x00\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x05\x00\x00\x00\x00\x41\x00\x00\x00\x38\x01\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x48\x05\x00\x00\x00\x00\x41\x00\x00\x00\x38\x01\x3d\x00\x3e\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x37\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x00\x00\x80\x03\x3d\x00\x3e\x00\x3f\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x41\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x44\x00\x00\x00\x45\x00\x46\x00\x00\x00\x47\x00\x48\x00\x49\x00\x00\x00\x00\x00\x0e\x02\xa7\x00\x13\x00\xa8\x00\x00\x00\x4a\x00\x4b\x00\x4c\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x15\x02\x16\x02\x8a\x05\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x17\x02\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\xe4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0f\x02\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x9f\x03\x00\x00\x00\x00\xbb\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\xd6\x00\xd7\x00\xd8\x00\xfc\x00\xd9\x00\x00\x00\xfd\x00\x00\x00\x15\x00\x00\x00\xfe\x00\x00\x00\x16\x00\xff\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x01\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xdb\x00\xdc\x00\xdd\x00\x00\x00\x01\x01\xb0\x00\xde\x00\xb2\x00\x02\x01\x03\x01\x00\x00\x00\x00\x04\x01\xdf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x05\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xe1\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x06\x01\x07\x01\x08\x01\x09\x01\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x5d\x04\x5e\x04\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\xd6\x00\xd7\x00\xd8\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x5f\x04\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x01\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xdb\x00\xdc\x00\xdd\x00\x00\x00\x00\x00\xb0\x00\xde\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x05\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xe1\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x06\x01\x07\x01\x08\x01\x09\x01\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x54\x04\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\xd6\x00\xd7\x00\xd8\x00\x00\x00\xd9\x00\x00\x00\xfd\x00\x00\x00\x15\x00\x00\x00\x55\x04\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x01\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xdb\x00\xdc\x00\xdd\x00\x00\x00\x00\x00\xb0\x00\xde\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x05\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xe1\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x06\x01\x07\x01\x08\x01\x09\x01\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x5d\x04\x5e\x04\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\xd6\x00\xd7\x00\xd8\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x5f\x04\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x01\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xdb\x00\xdc\x00\xdd\x00\x00\x00\x00\x00\xb0\x00\xde\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x05\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xe1\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x06\x01\x07\x01\x08\x01\x09\x01\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x54\x04\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\xd6\x00\xd7\x00\xd8\x00\x00\x00\xd9\x00\x00\x00\xfd\x00\x00\x00\x15\x00\x00\x00\x55\x04\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x01\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xdb\x00\xdc\x00\xdd\x00\x00\x00\x00\x00\xb0\x00\xde\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x05\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xe1\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x06\x01\x07\x01\x08\x01\x09\x01\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\xd6\x00\xd7\x00\xd8\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x01\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xdb\x00\xdc\x00\xdd\x00\x00\x00\x00\x00\xb0\x00\xde\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x05\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xe1\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x06\x01\x07\x01\x08\x01\x09\x01\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x67\x01\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\x68\x01\x83\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x69\x01\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x6a\x01\x6b\x01\xbb\x00\x2c\x00\x8a\x00\x8b\x00\x8c\x00\x2d\x00\x8d\x00\x8e\x00\x8f\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x67\x01\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x83\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x9c\x01\xba\x00\x00\x00\x00\x00\x6a\x01\x6b\x01\xbb\x00\x2c\x00\x8a\x00\x8b\x00\x8c\x00\x2d\x00\x8d\x00\x8e\x00\x8f\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x67\x01\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\x68\x01\x83\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x69\x01\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x6a\x01\x6b\x01\xbb\x00\x2c\x00\x8a\x00\x8b\x00\x8c\x00\x2d\x00\x8d\x00\x8e\x00\x8f\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x83\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x48\x02\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x2c\x02\x6b\x01\xbb\x00\x2c\x00\x8a\x00\x8b\x00\x8c\x00\x2d\x00\x8d\x00\x8e\x00\x8f\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x83\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x4b\x02\xba\x00\x00\x00\x00\x00\x2c\x02\x6b\x01\xbb\x00\x2c\x00\x8a\x00\x8b\x00\x8c\x00\x2d\x00\x8d\x00\x8e\x00\x8f\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x83\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\xa1\x01\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x6b\x01\xbb\x00\x2c\x00\x8a\x00\x8b\x00\x8c\x00\x2d\x00\x8d\x00\x8e\x00\x8f\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x00\x00\x00\x00\xb3\x00\x00\x00\xbf\x02\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x83\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x6b\x01\xbb\x00\x2c\x00\x8a\x00\x8b\x00\x8c\x00\x2d\x00\x8d\x00\x8e\x00\x8f\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x83\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x2c\x02\x6b\x01\xbb\x00\x2c\x00\x8a\x00\x8b\x00\x8c\x00\x2d\x00\x8d\x00\x8e\x00\x8f\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xdb\xfd\xdb\xfd\xdb\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xdb\xfd\x00\x00\xdb\xfd\xdb\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\xfd\x00\x00\x00\x00\x00\x00\xdb\xfd\x00\x00\x00\x00\x00\x00\xdb\xfd\x00\x00\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\x00\x00\xdb\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\x00\x00\xdb\xfd\x00\x00\x00\x00\x00\x00\xdb\xfd\x00\x00\xdb\xfd\xdb\xfd\xdb\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xdb\xfd\xdb\xfd\xdb\xfd\x00\x00\x00\x00\x00\x00\xdb\xfd\x00\x00\x00\x00\x00\x00\xdb\xfd\x00\x00\xdb\xfd\x00\x00\xdb\xfd\x00\x00\x00\x00\x00\x00\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\x00\x00\xdb\xfd\x00\x00\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xdb\xfd\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\xd6\x00\xd7\x00\xd8\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\xda\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xdb\x00\xdc\x00\xdd\x00\x00\x00\x00\x00\xb0\x00\xde\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xe1\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x83\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x6b\x01\xbb\x00\x2c\x00\x8a\x00\x8b\x00\x8c\x00\x2d\x00\x8d\x00\x8e\x00\x8f\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\xe4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x03\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x9f\x03\x00\x00\x00\x00\xbb\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\xae\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\xb8\x01\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb9\x01\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\xae\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\x00\x00\x00\x00\x00\x00\x15\x00\x95\x03\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\xe4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x9f\x03\x00\x00\x00\x00\xbb\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\xae\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\x00\x00\x00\x00\x00\x00\x15\x00\x95\x03\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\xe4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\xe4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\xe4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\xe2\x03\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb1\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\xa7\x01\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\x00\x00\xa8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x01\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x01\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\x00\x00\xa8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x00\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\xa7\x00\x13\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x14\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\xac\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xad\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\xa7\x00\x13\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x14\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x13\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x8b\x03\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\xa7\x00\x13\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x14\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x63\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\xb9\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x00\x00\x6a\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x00\x00\x4f\x00\x13\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x14\x00\x6d\x00\x6e\x00\xcc\x00\xcd\x00\xce\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x50\x00\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe6\x01\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\xe7\x01\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x01\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\x50\x00\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\xe2\x01\x00\x00\x00\x00\x00\x00\x6a\x01\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\x50\x00\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x3b\x02\x3c\x02\x3d\x02\x00\x00\x00\x00\x00\x00\x00\x00\x3e\x02\x5c\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x69\x01\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x01\x61\x00\x62\x00\x63\x00\x64\x00\x3f\x02\x40\x02\x00\x00\x67\x00\x68\x00\x41\x02\x6a\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\xa4\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\x50\x00\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x72\x02\x98\x03\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\xa4\x00\x0f\x00\x10\x00\x5e\x00\xe9\x01\x00\x00\x00\x00\x5f\x00\x11\x00\x60\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x00\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x3b\x01\x3c\x01\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\xa3\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\xcd\x02\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\xa4\x00\x0f\x00\x10\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x11\x00\x60\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x01\x00\x00\x14\x00\x00\x00\x00\x00\xa1\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\x9f\x02\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\xa4\x00\x0f\x00\x10\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x11\x00\x60\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x01\x00\x00\x14\x00\x00\x00\x00\x00\x56\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\xcd\x02\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\xa4\x00\x0f\x00\x10\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x11\x00\x60\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x01\x00\x00\x14\x00\x00\x00\x00\x00\x1b\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\x9f\x02\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\xa4\x00\x0f\x00\x10\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x11\x00\x60\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x01\x00\x00\x14\x00\x00\x00\x00\x00\x05\x03\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\xcd\x02\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\xa4\x00\x0f\x00\x10\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x11\x00\x60\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x01\x00\x00\x14\x00\x00\x00\x00\x00\x04\x03\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\x9f\x02\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\xa4\x00\x0f\x00\x10\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x11\x00\x60\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x01\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x04\x00\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\xe5\x02\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\xd0\x04\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\xbe\x01\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\x9f\x02\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\xa4\x00\x0f\x00\x10\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x11\x00\x60\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x01\x00\x00\x14\x00\x00\x00\x00\x00\x6e\x02\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\x50\x00\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\xa4\x00\x0f\x00\x10\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x11\x00\x60\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\xc1\x04\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x01\x00\x00\x14\x00\x00\x00\x00\x00\x5b\x02\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\x50\x00\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\xa4\x00\x0f\x00\x10\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x11\x00\x60\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x1c\x03\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\xe5\x02\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\xff\x04\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\xa4\x00\x0f\x00\x10\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x11\x00\x60\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\xe5\x02\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfd\x04\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\x50\x00\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\x50\x00\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x54\x05\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x8b\xfe\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x01\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\xe5\x02\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\x61\x03\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x01\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\xe5\x02\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\x61\x03\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x01\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x01\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\xe5\x02\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x01\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x58\x00\x59\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5c\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x00\x00\x67\x00\x68\x00\x69\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x4f\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x00\x00\x15\x00\x00\x00\x6f\x00\x70\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x13\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x14\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x33\x03\x34\x03\x35\x03\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf0\x01\x63\x00\x64\x00\x00\x00\x00\x00\x00\x00\x67\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x25\x02\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6e\x00\x2c\x00\x00\x00\x00\x00\x6f\x00\x70\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x36\x03\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x13\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x13\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x2c\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x03\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x13\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\xae\x04\x2a\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x15\x02\x16\x02\x00\x00\x17\x00\x18\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x02\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x02\x16\x02\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x17\x02\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x02\x16\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x02\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x00\x83\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x13\x00\x00\x00\x87\x00\x00\x00\x88\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x89\x00\x00\x00\x2c\x00\x8a\x00\x8b\x00\x8c\x00\x2d\x00\x8d\x00\x8e\x00\x8f\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x00\x83\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x01\xbd\x02\x13\x00\x00\x00\xda\x01\x00\x00\x88\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\xdb\x01\x00\x00\x2c\x00\x8a\x00\x8b\x00\x8c\x00\x00\x00\x8d\x00\x00\x00\x8f\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x13\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x04\x00\x00\x00\x00\x15\x00\x00\x00\xa4\x04\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\xa5\x04\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\xa3\x04\x00\x00\x00\x00\x15\x00\x00\x00\xa4\x04\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\xa5\x04\xa6\x04\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xa7\x04\x00\x00\x00\x00\x2c\x00\x64\x00\x13\x00\x00\x00\x2d\x00\x67\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\xa6\x04\x13\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x14\x00\x2c\x00\x64\x00\x00\x00\x00\x00\x2d\x00\x67\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\xa4\x04\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x86\x00\x00\x00\x00\x00\x00\x00\x94\x01\x13\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x00\x00\x3a\x05\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\xa6\x04\x13\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x14\x00\x2c\x00\x64\x00\x00\x00\x00\x00\x2d\x00\x67\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xd9\x01\x13\x00\x00\x00\x00\x00\xda\x01\x00\x00\x88\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x13\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x2d\x00\x8d\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x87\x01\x13\x00\x00\x00\x00\x00\x88\x01\x00\x00\x89\x01\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\x00\x64\x00\x00\x00\x00\x00\x00\x00\x67\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x13\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\x00\x00\x63\x00\x64\x00\x00\x00\x00\x00\x00\x00\x67\x00\x5a\x02\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x13\x00\x2b\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x00\x00\x00\x00\x2c\x00\x00\x00\x00\x00\x00\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x8f\x00\x57\x01\x58\x01\x2d\x00\x92\x00\x93\x00\x81\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x82\x00\x83\x00\x84\x00\x59\x01\x5a\x01\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x74\x01\x69\x01\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x01\x00\x00\x00\x00\x2c\x00\x8a\x00\x8b\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x5b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x01\x5d\x01\x00\x00\x5e\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x5f\x01\x60\x01\x9c\x01\x62\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x63\x01\x7f\x00\xa5\x00\x00\x00\x00\x00\x64\x01\x13\x00\x65\x01\x8f\x00\x57\x01\x58\x01\x00\x00\x92\x00\x93\x00\x14\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x15\x00\x00\x00\x59\x01\x5a\x01\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x5b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0f\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x01\x5d\x01\x00\x00\x5e\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x5f\x01\x60\x01\x61\x01\x62\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x63\x01\x7f\x00\xa5\x00\x00\x00\x63\x00\x64\x01\x00\x00\x65\x01\x8f\x00\x57\x01\x58\x01\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x96\x01\x97\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x5b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x01\x5d\x01\x00\x00\x5e\x01\x00\x00\x00\x00\x13\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x5f\x01\x98\x01\x14\x00\x99\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xa5\x00\x23\x01\x00\x00\x9a\x01\x15\x00\x65\x01\x24\x01\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x13\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x25\x01\x13\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x86\x00\x00\x00\x24\x00\x00\x00\x74\x01\x13\x00\x88\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x34\x01\x13\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x86\x00\x00\x00\x24\x00\x00\x00\x25\x01\x13\x00\x88\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x74\x01\x13\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x86\x00\x00\x00\x24\x00\x00\x00\x25\x01\x13\x00\x88\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x2c\x00\x8a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x8a\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\xff\x14\x00\x00\x00\x00\x00\x06\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\xf3\x02\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xbb\x02\x00\x00\x24\x00\x2c\x00\x00\x00\x13\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x13\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x2c\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x13\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x29\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x2c\x00\x16\x00\x00\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x00\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x13\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x2c\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x13\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x29\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x00\x00\x00\x00\x2c\x00\x00\x00\x00\x00\x17\x00\x18\x00\x19\x00\x51\x00\x52\x00\x53\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf6\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8f\x00\xe1\x00\x91\x00\x63\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x99\x03\x9a\x03\x9b\x03\x00\x00\x00\x00\xf6\x01\x00\x00\x00\x00\x9c\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x8f\x00\x57\x01\x58\x01\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9d\x01\xa4\x00\x0f\x00\x10\x00\x9e\x01\x9f\x01\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x9d\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x5b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x01\x5d\x01\x00\x00\x5e\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x5f\x01\x98\x01\x00\x00\x99\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xa5\x00\x8f\x00\x57\x01\x58\x01\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7a\x02\x00\x00\x00\x00\x7b\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x5b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x01\x5d\x01\x00\x00\x5e\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x5f\x01\x98\x01\x00\x00\x99\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xa5\x00\x8f\x00\x57\x01\x58\x01\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7a\x02\x00\x00\x00\x00\x8b\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x5b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x01\x5d\x01\x00\x00\x5e\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x5f\x01\x98\x01\x00\x00\x99\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xa5\x00\x8f\x00\x57\x01\x58\x01\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbd\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x5b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x01\x5d\x01\x00\x00\x5e\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x5f\x01\x98\x01\x00\x00\x99\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xa5\x00\x8f\x00\x57\x01\x58\x01\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x96\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x5b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x01\x5d\x01\x00\x00\x5e\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x5f\x01\x98\x01\x00\x00\x99\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xa5\x00\x8f\x00\x8d\x03\x58\x01\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8e\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x5b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x01\x5d\x01\x00\x00\x5e\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x5f\x01\x98\x01\x00\x00\x99\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xa5\x00\x8f\x00\x57\x01\x58\x01\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x5b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x01\x5d\x01\x00\x00\x5e\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x5f\x01\x98\x01\x00\x00\x99\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xa5\x00\x8f\x00\x57\x01\x58\x01\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd1\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x5b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x01\x5d\x01\x00\x00\x5e\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x5f\x01\x98\x01\x00\x00\x99\x01\x11\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xa5\x00\x8f\x00\x90\x00\x91\x00\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8f\x03\x90\x03\x91\x03\x92\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x93\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x90\x00\x91\x00\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x7d\x04\x91\x03\x92\x03\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x93\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x90\x00\x91\x00\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x01\x0a\x01\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x90\x00\x91\x00\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x90\x00\x91\x00\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x69\x02\x00\x00\x00\x00\x68\x02\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x90\x00\x91\x00\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x67\x02\x00\x00\x00\x00\x68\x02\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8f\x00\x90\x00\x91\x00\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x5e\x02\x5f\x02\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8f\x00\xe1\x00\x91\x00\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x9f\x03\x9a\x03\x9b\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8f\x00\x90\x00\x91\x00\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x4f\x03\x5f\x02\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8f\x00\xe1\x00\x91\x00\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\xd8\x03\x9a\x03\x9b\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xb3\x01\x91\x00\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\xb4\x01\xb5\x01\xb6\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x90\x00\x91\x00\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd5\x03\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x90\x00\x91\x00\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x7b\x04\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x90\x00\x91\x00\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd3\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xe1\x00\x91\x00\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x81\x04\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x9c\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xe1\x00\x91\x00\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\xe2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xe1\x00\x91\x00\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x28\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xe1\x00\x91\x00\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x27\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xe4\x00\x91\x00\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xd0\x01\x91\x00\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xc1\x01\x91\x00\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xc0\x01\x91\x00\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xba\x01\x91\x00\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x90\x01\x91\x00\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x8a\x01\x91\x00\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x89\x01\x91\x00\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x5a\x02\x91\x00\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x50\x02\x91\x00\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x4f\x02\x91\x00\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x4e\x02\x91\x00\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x4d\x02\x91\x00\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xa7\x03\x91\x00\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xa6\x03\x91\x00\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xa2\x03\x91\x00\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x95\x03\x91\x00\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x50\x03\x91\x00\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xef\x03\x91\x00\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xe0\x03\x91\x00\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xdf\x03\x91\x00\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xd4\x03\x91\x00\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xd2\x03\x91\x00\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x82\x04\x91\x00\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x7a\x04\x91\x00\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x60\x04\x91\x00\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xe5\x04\x91\x00\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xb5\x04\x91\x00\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xb4\x04\x91\x00\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\xb3\x04\x91\x00\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x1e\x05\x91\x00\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x47\x05\x91\x00\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x00\x00\x8f\x01\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x00\x00\xc0\x02\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x00\x00\x29\x04\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x8f\x00\x00\x00\xd0\x04\x00\x00\x92\x00\x93\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x8f\x00\x00\x00\x73\x00\x74\x00\x92\x00\x53\x02\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x72\x00\x00\x00\x00\x00\x73\x00\x74\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x0f\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x7c\x00\x7d\x00\x00\x00\x00\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# + +happyReduceArr = Happy_Data_Array.array (13, 830) [ + (13 , happyReduce_13), + (14 , happyReduce_14), + (15 , happyReduce_15), + (16 , happyReduce_16), + (17 , happyReduce_17), + (18 , happyReduce_18), + (19 , happyReduce_19), + (20 , happyReduce_20), + (21 , happyReduce_21), + (22 , happyReduce_22), + (23 , happyReduce_23), + (24 , happyReduce_24), + (25 , happyReduce_25), + (26 , happyReduce_26), + (27 , happyReduce_27), + (28 , happyReduce_28), + (29 , happyReduce_29), + (30 , happyReduce_30), + (31 , happyReduce_31), + (32 , happyReduce_32), + (33 , happyReduce_33), + (34 , happyReduce_34), + (35 , happyReduce_35), + (36 , happyReduce_36), + (37 , happyReduce_37), + (38 , happyReduce_38), + (39 , happyReduce_39), + (40 , happyReduce_40), + (41 , happyReduce_41), + (42 , happyReduce_42), + (43 , happyReduce_43), + (44 , happyReduce_44), + (45 , happyReduce_45), + (46 , happyReduce_46), + (47 , happyReduce_47), + (48 , happyReduce_48), + (49 , happyReduce_49), + (50 , happyReduce_50), + (51 , happyReduce_51), + (52 , happyReduce_52), + (53 , happyReduce_53), + (54 , happyReduce_54), + (55 , happyReduce_55), + (56 , happyReduce_56), + (57 , happyReduce_57), + (58 , happyReduce_58), + (59 , happyReduce_59), + (60 , happyReduce_60), + (61 , happyReduce_61), + (62 , happyReduce_62), + (63 , happyReduce_63), + (64 , happyReduce_64), + (65 , happyReduce_65), + (66 , happyReduce_66), + (67 , happyReduce_67), + (68 , happyReduce_68), + (69 , happyReduce_69), + (70 , happyReduce_70), + (71 , happyReduce_71), + (72 , happyReduce_72), + (73 , happyReduce_73), + (74 , happyReduce_74), + (75 , happyReduce_75), + (76 , happyReduce_76), + (77 , happyReduce_77), + (78 , happyReduce_78), + (79 , happyReduce_79), + (80 , happyReduce_80), + (81 , happyReduce_81), + (82 , happyReduce_82), + (83 , happyReduce_83), + (84 , happyReduce_84), + (85 , happyReduce_85), + (86 , happyReduce_86), + (87 , happyReduce_87), + (88 , happyReduce_88), + (89 , happyReduce_89), + (90 , happyReduce_90), + (91 , happyReduce_91), + (92 , happyReduce_92), + (93 , happyReduce_93), + (94 , happyReduce_94), + (95 , happyReduce_95), + (96 , happyReduce_96), + (97 , happyReduce_97), + (98 , happyReduce_98), + (99 , happyReduce_99), + (100 , happyReduce_100), + (101 , happyReduce_101), + (102 , happyReduce_102), + (103 , happyReduce_103), + (104 , happyReduce_104), + (105 , happyReduce_105), + (106 , happyReduce_106), + (107 , happyReduce_107), + (108 , happyReduce_108), + (109 , happyReduce_109), + (110 , happyReduce_110), + (111 , happyReduce_111), + (112 , happyReduce_112), + (113 , happyReduce_113), + (114 , happyReduce_114), + (115 , happyReduce_115), + (116 , happyReduce_116), + (117 , happyReduce_117), + (118 , happyReduce_118), + (119 , happyReduce_119), + (120 , happyReduce_120), + (121 , happyReduce_121), + (122 , happyReduce_122), + (123 , happyReduce_123), + (124 , happyReduce_124), + (125 , happyReduce_125), + (126 , happyReduce_126), + (127 , happyReduce_127), + (128 , happyReduce_128), + (129 , happyReduce_129), + (130 , happyReduce_130), + (131 , happyReduce_131), + (132 , happyReduce_132), + (133 , happyReduce_133), + (134 , happyReduce_134), + (135 , happyReduce_135), + (136 , happyReduce_136), + (137 , happyReduce_137), + (138 , happyReduce_138), + (139 , happyReduce_139), + (140 , happyReduce_140), + (141 , happyReduce_141), + (142 , happyReduce_142), + (143 , happyReduce_143), + (144 , happyReduce_144), + (145 , happyReduce_145), + (146 , happyReduce_146), + (147 , happyReduce_147), + (148 , happyReduce_148), + (149 , happyReduce_149), + (150 , happyReduce_150), + (151 , happyReduce_151), + (152 , happyReduce_152), + (153 , happyReduce_153), + (154 , happyReduce_154), + (155 , happyReduce_155), + (156 , happyReduce_156), + (157 , happyReduce_157), + (158 , happyReduce_158), + (159 , happyReduce_159), + (160 , happyReduce_160), + (161 , happyReduce_161), + (162 , happyReduce_162), + (163 , happyReduce_163), + (164 , happyReduce_164), + (165 , happyReduce_165), + (166 , happyReduce_166), + (167 , happyReduce_167), + (168 , happyReduce_168), + (169 , happyReduce_169), + (170 , happyReduce_170), + (171 , happyReduce_171), + (172 , happyReduce_172), + (173 , happyReduce_173), + (174 , happyReduce_174), + (175 , happyReduce_175), + (176 , happyReduce_176), + (177 , happyReduce_177), + (178 , happyReduce_178), + (179 , happyReduce_179), + (180 , happyReduce_180), + (181 , happyReduce_181), + (182 , happyReduce_182), + (183 , happyReduce_183), + (184 , happyReduce_184), + (185 , happyReduce_185), + (186 , happyReduce_186), + (187 , happyReduce_187), + (188 , happyReduce_188), + (189 , happyReduce_189), + (190 , happyReduce_190), + (191 , happyReduce_191), + (192 , happyReduce_192), + (193 , happyReduce_193), + (194 , happyReduce_194), + (195 , happyReduce_195), + (196 , happyReduce_196), + (197 , happyReduce_197), + (198 , happyReduce_198), + (199 , happyReduce_199), + (200 , happyReduce_200), + (201 , happyReduce_201), + (202 , happyReduce_202), + (203 , happyReduce_203), + (204 , happyReduce_204), + (205 , happyReduce_205), + (206 , happyReduce_206), + (207 , happyReduce_207), + (208 , happyReduce_208), + (209 , happyReduce_209), + (210 , happyReduce_210), + (211 , happyReduce_211), + (212 , happyReduce_212), + (213 , happyReduce_213), + (214 , happyReduce_214), + (215 , happyReduce_215), + (216 , happyReduce_216), + (217 , happyReduce_217), + (218 , happyReduce_218), + (219 , happyReduce_219), + (220 , happyReduce_220), + (221 , happyReduce_221), + (222 , happyReduce_222), + (223 , happyReduce_223), + (224 , happyReduce_224), + (225 , happyReduce_225), + (226 , happyReduce_226), + (227 , happyReduce_227), + (228 , happyReduce_228), + (229 , happyReduce_229), + (230 , happyReduce_230), + (231 , happyReduce_231), + (232 , happyReduce_232), + (233 , happyReduce_233), + (234 , happyReduce_234), + (235 , happyReduce_235), + (236 , happyReduce_236), + (237 , happyReduce_237), + (238 , happyReduce_238), + (239 , happyReduce_239), + (240 , happyReduce_240), + (241 , happyReduce_241), + (242 , happyReduce_242), + (243 , happyReduce_243), + (244 , happyReduce_244), + (245 , happyReduce_245), + (246 , happyReduce_246), + (247 , happyReduce_247), + (248 , happyReduce_248), + (249 , happyReduce_249), + (250 , happyReduce_250), + (251 , happyReduce_251), + (252 , happyReduce_252), + (253 , happyReduce_253), + (254 , happyReduce_254), + (255 , happyReduce_255), + (256 , happyReduce_256), + (257 , happyReduce_257), + (258 , happyReduce_258), + (259 , happyReduce_259), + (260 , happyReduce_260), + (261 , happyReduce_261), + (262 , happyReduce_262), + (263 , happyReduce_263), + (264 , happyReduce_264), + (265 , happyReduce_265), + (266 , happyReduce_266), + (267 , happyReduce_267), + (268 , happyReduce_268), + (269 , happyReduce_269), + (270 , happyReduce_270), + (271 , happyReduce_271), + (272 , happyReduce_272), + (273 , happyReduce_273), + (274 , happyReduce_274), + (275 , happyReduce_275), + (276 , happyReduce_276), + (277 , happyReduce_277), + (278 , happyReduce_278), + (279 , happyReduce_279), + (280 , happyReduce_280), + (281 , happyReduce_281), + (282 , happyReduce_282), + (283 , happyReduce_283), + (284 , happyReduce_284), + (285 , happyReduce_285), + (286 , happyReduce_286), + (287 , happyReduce_287), + (288 , happyReduce_288), + (289 , happyReduce_289), + (290 , happyReduce_290), + (291 , happyReduce_291), + (292 , happyReduce_292), + (293 , happyReduce_293), + (294 , happyReduce_294), + (295 , happyReduce_295), + (296 , happyReduce_296), + (297 , happyReduce_297), + (298 , happyReduce_298), + (299 , happyReduce_299), + (300 , happyReduce_300), + (301 , happyReduce_301), + (302 , happyReduce_302), + (303 , happyReduce_303), + (304 , happyReduce_304), + (305 , happyReduce_305), + (306 , happyReduce_306), + (307 , happyReduce_307), + (308 , happyReduce_308), + (309 , happyReduce_309), + (310 , happyReduce_310), + (311 , happyReduce_311), + (312 , happyReduce_312), + (313 , happyReduce_313), + (314 , happyReduce_314), + (315 , happyReduce_315), + (316 , happyReduce_316), + (317 , happyReduce_317), + (318 , happyReduce_318), + (319 , happyReduce_319), + (320 , happyReduce_320), + (321 , happyReduce_321), + (322 , happyReduce_322), + (323 , happyReduce_323), + (324 , happyReduce_324), + (325 , happyReduce_325), + (326 , happyReduce_326), + (327 , happyReduce_327), + (328 , happyReduce_328), + (329 , happyReduce_329), + (330 , happyReduce_330), + (331 , happyReduce_331), + (332 , happyReduce_332), + (333 , happyReduce_333), + (334 , happyReduce_334), + (335 , happyReduce_335), + (336 , happyReduce_336), + (337 , happyReduce_337), + (338 , happyReduce_338), + (339 , happyReduce_339), + (340 , happyReduce_340), + (341 , happyReduce_341), + (342 , happyReduce_342), + (343 , happyReduce_343), + (344 , happyReduce_344), + (345 , happyReduce_345), + (346 , happyReduce_346), + (347 , happyReduce_347), + (348 , happyReduce_348), + (349 , happyReduce_349), + (350 , happyReduce_350), + (351 , happyReduce_351), + (352 , happyReduce_352), + (353 , happyReduce_353), + (354 , happyReduce_354), + (355 , happyReduce_355), + (356 , happyReduce_356), + (357 , happyReduce_357), + (358 , happyReduce_358), + (359 , happyReduce_359), + (360 , happyReduce_360), + (361 , happyReduce_361), + (362 , happyReduce_362), + (363 , happyReduce_363), + (364 , happyReduce_364), + (365 , happyReduce_365), + (366 , happyReduce_366), + (367 , happyReduce_367), + (368 , happyReduce_368), + (369 , happyReduce_369), + (370 , happyReduce_370), + (371 , happyReduce_371), + (372 , happyReduce_372), + (373 , happyReduce_373), + (374 , happyReduce_374), + (375 , happyReduce_375), + (376 , happyReduce_376), + (377 , happyReduce_377), + (378 , happyReduce_378), + (379 , happyReduce_379), + (380 , happyReduce_380), + (381 , happyReduce_381), + (382 , happyReduce_382), + (383 , happyReduce_383), + (384 , happyReduce_384), + (385 , happyReduce_385), + (386 , happyReduce_386), + (387 , happyReduce_387), + (388 , happyReduce_388), + (389 , happyReduce_389), + (390 , happyReduce_390), + (391 , happyReduce_391), + (392 , happyReduce_392), + (393 , happyReduce_393), + (394 , happyReduce_394), + (395 , happyReduce_395), + (396 , happyReduce_396), + (397 , happyReduce_397), + (398 , happyReduce_398), + (399 , happyReduce_399), + (400 , happyReduce_400), + (401 , happyReduce_401), + (402 , happyReduce_402), + (403 , happyReduce_403), + (404 , happyReduce_404), + (405 , happyReduce_405), + (406 , happyReduce_406), + (407 , happyReduce_407), + (408 , happyReduce_408), + (409 , happyReduce_409), + (410 , happyReduce_410), + (411 , happyReduce_411), + (412 , happyReduce_412), + (413 , happyReduce_413), + (414 , happyReduce_414), + (415 , happyReduce_415), + (416 , happyReduce_416), + (417 , happyReduce_417), + (418 , happyReduce_418), + (419 , happyReduce_419), + (420 , happyReduce_420), + (421 , happyReduce_421), + (422 , happyReduce_422), + (423 , happyReduce_423), + (424 , happyReduce_424), + (425 , happyReduce_425), + (426 , happyReduce_426), + (427 , happyReduce_427), + (428 , happyReduce_428), + (429 , happyReduce_429), + (430 , happyReduce_430), + (431 , happyReduce_431), + (432 , happyReduce_432), + (433 , happyReduce_433), + (434 , happyReduce_434), + (435 , happyReduce_435), + (436 , happyReduce_436), + (437 , happyReduce_437), + (438 , happyReduce_438), + (439 , happyReduce_439), + (440 , happyReduce_440), + (441 , happyReduce_441), + (442 , happyReduce_442), + (443 , happyReduce_443), + (444 , happyReduce_444), + (445 , happyReduce_445), + (446 , happyReduce_446), + (447 , happyReduce_447), + (448 , happyReduce_448), + (449 , happyReduce_449), + (450 , happyReduce_450), + (451 , happyReduce_451), + (452 , happyReduce_452), + (453 , happyReduce_453), + (454 , happyReduce_454), + (455 , happyReduce_455), + (456 , happyReduce_456), + (457 , happyReduce_457), + (458 , happyReduce_458), + (459 , happyReduce_459), + (460 , happyReduce_460), + (461 , happyReduce_461), + (462 , happyReduce_462), + (463 , happyReduce_463), + (464 , happyReduce_464), + (465 , happyReduce_465), + (466 , happyReduce_466), + (467 , happyReduce_467), + (468 , happyReduce_468), + (469 , happyReduce_469), + (470 , happyReduce_470), + (471 , happyReduce_471), + (472 , happyReduce_472), + (473 , happyReduce_473), + (474 , happyReduce_474), + (475 , happyReduce_475), + (476 , happyReduce_476), + (477 , happyReduce_477), + (478 , happyReduce_478), + (479 , happyReduce_479), + (480 , happyReduce_480), + (481 , happyReduce_481), + (482 , happyReduce_482), + (483 , happyReduce_483), + (484 , happyReduce_484), + (485 , happyReduce_485), + (486 , happyReduce_486), + (487 , happyReduce_487), + (488 , happyReduce_488), + (489 , happyReduce_489), + (490 , happyReduce_490), + (491 , happyReduce_491), + (492 , happyReduce_492), + (493 , happyReduce_493), + (494 , happyReduce_494), + (495 , happyReduce_495), + (496 , happyReduce_496), + (497 , happyReduce_497), + (498 , happyReduce_498), + (499 , happyReduce_499), + (500 , happyReduce_500), + (501 , happyReduce_501), + (502 , happyReduce_502), + (503 , happyReduce_503), + (504 , happyReduce_504), + (505 , happyReduce_505), + (506 , happyReduce_506), + (507 , happyReduce_507), + (508 , happyReduce_508), + (509 , happyReduce_509), + (510 , happyReduce_510), + (511 , happyReduce_511), + (512 , happyReduce_512), + (513 , happyReduce_513), + (514 , happyReduce_514), + (515 , happyReduce_515), + (516 , happyReduce_516), + (517 , happyReduce_517), + (518 , happyReduce_518), + (519 , happyReduce_519), + (520 , happyReduce_520), + (521 , happyReduce_521), + (522 , happyReduce_522), + (523 , happyReduce_523), + (524 , happyReduce_524), + (525 , happyReduce_525), + (526 , happyReduce_526), + (527 , happyReduce_527), + (528 , happyReduce_528), + (529 , happyReduce_529), + (530 , happyReduce_530), + (531 , happyReduce_531), + (532 , happyReduce_532), + (533 , happyReduce_533), + (534 , happyReduce_534), + (535 , happyReduce_535), + (536 , happyReduce_536), + (537 , happyReduce_537), + (538 , happyReduce_538), + (539 , happyReduce_539), + (540 , happyReduce_540), + (541 , happyReduce_541), + (542 , happyReduce_542), + (543 , happyReduce_543), + (544 , happyReduce_544), + (545 , happyReduce_545), + (546 , happyReduce_546), + (547 , happyReduce_547), + (548 , happyReduce_548), + (549 , happyReduce_549), + (550 , happyReduce_550), + (551 , happyReduce_551), + (552 , happyReduce_552), + (553 , happyReduce_553), + (554 , happyReduce_554), + (555 , happyReduce_555), + (556 , happyReduce_556), + (557 , happyReduce_557), + (558 , happyReduce_558), + (559 , happyReduce_559), + (560 , happyReduce_560), + (561 , happyReduce_561), + (562 , happyReduce_562), + (563 , happyReduce_563), + (564 , happyReduce_564), + (565 , happyReduce_565), + (566 , happyReduce_566), + (567 , happyReduce_567), + (568 , happyReduce_568), + (569 , happyReduce_569), + (570 , happyReduce_570), + (571 , happyReduce_571), + (572 , happyReduce_572), + (573 , happyReduce_573), + (574 , happyReduce_574), + (575 , happyReduce_575), + (576 , happyReduce_576), + (577 , happyReduce_577), + (578 , happyReduce_578), + (579 , happyReduce_579), + (580 , happyReduce_580), + (581 , happyReduce_581), + (582 , happyReduce_582), + (583 , happyReduce_583), + (584 , happyReduce_584), + (585 , happyReduce_585), + (586 , happyReduce_586), + (587 , happyReduce_587), + (588 , happyReduce_588), + (589 , happyReduce_589), + (590 , happyReduce_590), + (591 , happyReduce_591), + (592 , happyReduce_592), + (593 , happyReduce_593), + (594 , happyReduce_594), + (595 , happyReduce_595), + (596 , happyReduce_596), + (597 , happyReduce_597), + (598 , happyReduce_598), + (599 , happyReduce_599), + (600 , happyReduce_600), + (601 , happyReduce_601), + (602 , happyReduce_602), + (603 , happyReduce_603), + (604 , happyReduce_604), + (605 , happyReduce_605), + (606 , happyReduce_606), + (607 , happyReduce_607), + (608 , happyReduce_608), + (609 , happyReduce_609), + (610 , happyReduce_610), + (611 , happyReduce_611), + (612 , happyReduce_612), + (613 , happyReduce_613), + (614 , happyReduce_614), + (615 , happyReduce_615), + (616 , happyReduce_616), + (617 , happyReduce_617), + (618 , happyReduce_618), + (619 , happyReduce_619), + (620 , happyReduce_620), + (621 , happyReduce_621), + (622 , happyReduce_622), + (623 , happyReduce_623), + (624 , happyReduce_624), + (625 , happyReduce_625), + (626 , happyReduce_626), + (627 , happyReduce_627), + (628 , happyReduce_628), + (629 , happyReduce_629), + (630 , happyReduce_630), + (631 , happyReduce_631), + (632 , happyReduce_632), + (633 , happyReduce_633), + (634 , happyReduce_634), + (635 , happyReduce_635), + (636 , happyReduce_636), + (637 , happyReduce_637), + (638 , happyReduce_638), + (639 , happyReduce_639), + (640 , happyReduce_640), + (641 , happyReduce_641), + (642 , happyReduce_642), + (643 , happyReduce_643), + (644 , happyReduce_644), + (645 , happyReduce_645), + (646 , happyReduce_646), + (647 , happyReduce_647), + (648 , happyReduce_648), + (649 , happyReduce_649), + (650 , happyReduce_650), + (651 , happyReduce_651), + (652 , happyReduce_652), + (653 , happyReduce_653), + (654 , happyReduce_654), + (655 , happyReduce_655), + (656 , happyReduce_656), + (657 , happyReduce_657), + (658 , happyReduce_658), + (659 , happyReduce_659), + (660 , happyReduce_660), + (661 , happyReduce_661), + (662 , happyReduce_662), + (663 , happyReduce_663), + (664 , happyReduce_664), + (665 , happyReduce_665), + (666 , happyReduce_666), + (667 , happyReduce_667), + (668 , happyReduce_668), + (669 , happyReduce_669), + (670 , happyReduce_670), + (671 , happyReduce_671), + (672 , happyReduce_672), + (673 , happyReduce_673), + (674 , happyReduce_674), + (675 , happyReduce_675), + (676 , happyReduce_676), + (677 , happyReduce_677), + (678 , happyReduce_678), + (679 , happyReduce_679), + (680 , happyReduce_680), + (681 , happyReduce_681), + (682 , happyReduce_682), + (683 , happyReduce_683), + (684 , happyReduce_684), + (685 , happyReduce_685), + (686 , happyReduce_686), + (687 , happyReduce_687), + (688 , happyReduce_688), + (689 , happyReduce_689), + (690 , happyReduce_690), + (691 , happyReduce_691), + (692 , happyReduce_692), + (693 , happyReduce_693), + (694 , happyReduce_694), + (695 , happyReduce_695), + (696 , happyReduce_696), + (697 , happyReduce_697), + (698 , happyReduce_698), + (699 , happyReduce_699), + (700 , happyReduce_700), + (701 , happyReduce_701), + (702 , happyReduce_702), + (703 , happyReduce_703), + (704 , happyReduce_704), + (705 , happyReduce_705), + (706 , happyReduce_706), + (707 , happyReduce_707), + (708 , happyReduce_708), + (709 , happyReduce_709), + (710 , happyReduce_710), + (711 , happyReduce_711), + (712 , happyReduce_712), + (713 , happyReduce_713), + (714 , happyReduce_714), + (715 , happyReduce_715), + (716 , happyReduce_716), + (717 , happyReduce_717), + (718 , happyReduce_718), + (719 , happyReduce_719), + (720 , happyReduce_720), + (721 , happyReduce_721), + (722 , happyReduce_722), + (723 , happyReduce_723), + (724 , happyReduce_724), + (725 , happyReduce_725), + (726 , happyReduce_726), + (727 , happyReduce_727), + (728 , happyReduce_728), + (729 , happyReduce_729), + (730 , happyReduce_730), + (731 , happyReduce_731), + (732 , happyReduce_732), + (733 , happyReduce_733), + (734 , happyReduce_734), + (735 , happyReduce_735), + (736 , happyReduce_736), + (737 , happyReduce_737), + (738 , happyReduce_738), + (739 , happyReduce_739), + (740 , happyReduce_740), + (741 , happyReduce_741), + (742 , happyReduce_742), + (743 , happyReduce_743), + (744 , happyReduce_744), + (745 , happyReduce_745), + (746 , happyReduce_746), + (747 , happyReduce_747), + (748 , happyReduce_748), + (749 , happyReduce_749), + (750 , happyReduce_750), + (751 , happyReduce_751), + (752 , happyReduce_752), + (753 , happyReduce_753), + (754 , happyReduce_754), + (755 , happyReduce_755), + (756 , happyReduce_756), + (757 , happyReduce_757), + (758 , happyReduce_758), + (759 , happyReduce_759), + (760 , happyReduce_760), + (761 , happyReduce_761), + (762 , happyReduce_762), + (763 , happyReduce_763), + (764 , happyReduce_764), + (765 , happyReduce_765), + (766 , happyReduce_766), + (767 , happyReduce_767), + (768 , happyReduce_768), + (769 , happyReduce_769), + (770 , happyReduce_770), + (771 , happyReduce_771), + (772 , happyReduce_772), + (773 , happyReduce_773), + (774 , happyReduce_774), + (775 , happyReduce_775), + (776 , happyReduce_776), + (777 , happyReduce_777), + (778 , happyReduce_778), + (779 , happyReduce_779), + (780 , happyReduce_780), + (781 , happyReduce_781), + (782 , happyReduce_782), + (783 , happyReduce_783), + (784 , happyReduce_784), + (785 , happyReduce_785), + (786 , happyReduce_786), + (787 , happyReduce_787), + (788 , happyReduce_788), + (789 , happyReduce_789), + (790 , happyReduce_790), + (791 , happyReduce_791), + (792 , happyReduce_792), + (793 , happyReduce_793), + (794 , happyReduce_794), + (795 , happyReduce_795), + (796 , happyReduce_796), + (797 , happyReduce_797), + (798 , happyReduce_798), + (799 , happyReduce_799), + (800 , happyReduce_800), + (801 , happyReduce_801), + (802 , happyReduce_802), + (803 , happyReduce_803), + (804 , happyReduce_804), + (805 , happyReduce_805), + (806 , happyReduce_806), + (807 , happyReduce_807), + (808 , happyReduce_808), + (809 , happyReduce_809), + (810 , happyReduce_810), + (811 , happyReduce_811), + (812 , happyReduce_812), + (813 , happyReduce_813), + (814 , happyReduce_814), + (815 , happyReduce_815), + (816 , happyReduce_816), + (817 , happyReduce_817), + (818 , happyReduce_818), + (819 , happyReduce_819), + (820 , happyReduce_820), + (821 , happyReduce_821), + (822 , happyReduce_822), + (823 , happyReduce_823), + (824 , happyReduce_824), + (825 , happyReduce_825), + (826 , happyReduce_826), + (827 , happyReduce_827), + (828 , happyReduce_828), + (829 , happyReduce_829), + (830 , happyReduce_830) + ] + +happy_n_terms = 154 :: Int +happy_n_nonterms = 312 :: Int + +happyReduce_13 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_13 = happySpecReduce_1 0# happyReduction_13 +happyReduction_13 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn16 + (happy_var_1 + ) +happyReduction_13 _ = notHappyAtAll + +happyReduce_14 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_14 = happySpecReduce_1 0# happyReduction_14 +happyReduction_14 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn16 + (happy_var_1 + ) +happyReduction_14 _ = notHappyAtAll + +happyReduce_15 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_15 = happySpecReduce_1 0# happyReduction_15 +happyReduction_15 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn16 + (happy_var_1 + ) +happyReduction_15 _ = notHappyAtAll + +happyReduce_16 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_16 = happySpecReduce_1 0# happyReduction_16 +happyReduction_16 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn16 + (happy_var_1 + ) +happyReduction_16 _ = notHappyAtAll + +happyReduce_17 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_17 = happyMonadReduce 3# 0# happyReduction_17 +happyReduction_17 ((HappyTerminal happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_3 $ getRdrName funTyCon) + [mop happy_var_1,mu AnnRarrow happy_var_2,mcp happy_var_3])) + ) (\r -> happyReturn (HappyAbsSyn16 r)) + +happyReduce_18 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_18 = happyMonadReduce 3# 0# happyReduction_18 +happyReduction_18 ((HappyTerminal happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_3 $ eqTyCon_RDR) + [mop happy_var_1,mj AnnTilde happy_var_2,mcp happy_var_3])) + ) (\r -> happyReturn (HappyAbsSyn16 r)) + +happyReduce_19 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_19 = happySpecReduce_3 1# happyReduction_19 +happyReduction_19 _ + (HappyAbsSyn18 happy_var_2) + _ + = HappyAbsSyn17 + (fromOL happy_var_2 + ) +happyReduction_19 _ _ _ = notHappyAtAll + +happyReduce_20 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_20 = happySpecReduce_3 1# happyReduction_20 +happyReduction_20 _ + (HappyAbsSyn18 happy_var_2) + _ + = HappyAbsSyn17 + (fromOL happy_var_2 + ) +happyReduction_20 _ _ _ = notHappyAtAll + +happyReduce_21 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_21 = happySpecReduce_3 2# happyReduction_21 +happyReduction_21 (HappyAbsSyn19 happy_var_3) + _ + (HappyAbsSyn18 happy_var_1) + = HappyAbsSyn18 + (happy_var_1 `appOL` unitOL happy_var_3 + ) +happyReduction_21 _ _ _ = notHappyAtAll + +happyReduce_22 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_22 = happySpecReduce_2 2# happyReduction_22 +happyReduction_22 _ + (HappyAbsSyn18 happy_var_1) + = HappyAbsSyn18 + (happy_var_1 + ) +happyReduction_22 _ _ = notHappyAtAll + +happyReduce_23 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_23 = happySpecReduce_1 2# happyReduction_23 +happyReduction_23 (HappyAbsSyn19 happy_var_1) + = HappyAbsSyn18 + (unitOL happy_var_1 + ) +happyReduction_23 _ = notHappyAtAll + +happyReduce_24 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_24 = happyReduce 4# 3# happyReduction_24 +happyReduction_24 ((HappyAbsSyn30 happy_var_4) `HappyStk` + _ `HappyStk` + (HappyAbsSyn24 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) + = HappyAbsSyn19 + (sL1 happy_var_1 $ HsUnit { hsunitName = happy_var_2 + , hsunitBody = fromOL happy_var_4 } + ) `HappyStk` happyRest + +happyReduce_25 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_25 = happySpecReduce_1 4# happyReduction_25 +happyReduction_25 (HappyAbsSyn24 happy_var_1) + = HappyAbsSyn20 + (sL1 happy_var_1 $ HsUnitId happy_var_1 [] + ) +happyReduction_25 _ = notHappyAtAll + +happyReduce_26 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_26 = happyReduce 4# 4# happyReduction_26 +happyReduction_26 ((HappyTerminal happy_var_4) `HappyStk` + (HappyAbsSyn21 happy_var_3) `HappyStk` + _ `HappyStk` + (HappyAbsSyn24 happy_var_1) `HappyStk` + happyRest) + = HappyAbsSyn20 + (sLL happy_var_1 happy_var_4 $ HsUnitId happy_var_1 (fromOL happy_var_3) + ) `HappyStk` happyRest + +happyReduce_27 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_27 = happySpecReduce_3 5# happyReduction_27 +happyReduction_27 (HappyAbsSyn22 happy_var_3) + _ + (HappyAbsSyn21 happy_var_1) + = HappyAbsSyn21 + (happy_var_1 `appOL` unitOL happy_var_3 + ) +happyReduction_27 _ _ _ = notHappyAtAll + +happyReduce_28 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_28 = happySpecReduce_2 5# happyReduction_28 +happyReduction_28 _ + (HappyAbsSyn21 happy_var_1) + = HappyAbsSyn21 + (happy_var_1 + ) +happyReduction_28 _ _ = notHappyAtAll + +happyReduce_29 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_29 = happySpecReduce_1 5# happyReduction_29 +happyReduction_29 (HappyAbsSyn22 happy_var_1) + = HappyAbsSyn21 + (unitOL happy_var_1 + ) +happyReduction_29 _ = notHappyAtAll + +happyReduce_30 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_30 = happySpecReduce_3 6# happyReduction_30 +happyReduction_30 (HappyAbsSyn23 happy_var_3) + _ + (HappyAbsSyn317 happy_var_1) + = HappyAbsSyn22 + (sLL happy_var_1 happy_var_3 $ (happy_var_1, happy_var_3) + ) +happyReduction_30 _ _ _ = notHappyAtAll + +happyReduce_31 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_31 = happyReduce 4# 6# happyReduction_31 +happyReduction_31 ((HappyTerminal happy_var_4) `HappyStk` + (HappyAbsSyn317 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn317 happy_var_1) `HappyStk` + happyRest) + = HappyAbsSyn22 + (sLL happy_var_1 happy_var_4 $ (happy_var_1, sLL happy_var_2 happy_var_4 $ HsModuleVar happy_var_3) + ) `HappyStk` happyRest + +happyReduce_32 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_32 = happySpecReduce_3 7# happyReduction_32 +happyReduction_32 (HappyTerminal happy_var_3) + (HappyAbsSyn317 happy_var_2) + (HappyTerminal happy_var_1) + = HappyAbsSyn23 + (sLL happy_var_1 happy_var_3 $ HsModuleVar happy_var_2 + ) +happyReduction_32 _ _ _ = notHappyAtAll + +happyReduce_33 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_33 = happySpecReduce_3 7# happyReduction_33 +happyReduction_33 (HappyAbsSyn317 happy_var_3) + _ + (HappyAbsSyn20 happy_var_1) + = HappyAbsSyn23 + (sLL happy_var_1 happy_var_3 $ HsModuleId happy_var_1 happy_var_3 + ) +happyReduction_33 _ _ _ = notHappyAtAll + +happyReduce_34 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_34 = happySpecReduce_1 8# happyReduction_34 +happyReduction_34 (HappyTerminal happy_var_1) + = HappyAbsSyn24 + (sL1 happy_var_1 $ PackageName (getSTRING happy_var_1) + ) +happyReduction_34 _ = notHappyAtAll + +happyReduce_35 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_35 = happySpecReduce_1 8# happyReduction_35 +happyReduction_35 (HappyAbsSyn25 happy_var_1) + = HappyAbsSyn24 + (sL1 happy_var_1 $ PackageName (unLoc happy_var_1) + ) +happyReduction_35 _ = notHappyAtAll + +happyReduce_36 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_36 = happySpecReduce_1 9# happyReduction_36 +happyReduction_36 (HappyTerminal happy_var_1) + = HappyAbsSyn25 + (sL1 happy_var_1 $ getVARID happy_var_1 + ) +happyReduction_36 _ = notHappyAtAll + +happyReduce_37 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_37 = happySpecReduce_1 9# happyReduction_37 +happyReduction_37 (HappyTerminal happy_var_1) + = HappyAbsSyn25 + (sL1 happy_var_1 $ getCONID happy_var_1 + ) +happyReduction_37 _ = notHappyAtAll + +happyReduce_38 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_38 = happySpecReduce_1 9# happyReduction_38 +happyReduction_38 (HappyAbsSyn25 happy_var_1) + = HappyAbsSyn25 + (happy_var_1 + ) +happyReduction_38 _ = notHappyAtAll + +happyReduce_39 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_39 = happySpecReduce_1 10# happyReduction_39 +happyReduction_39 (HappyAbsSyn25 happy_var_1) + = HappyAbsSyn25 + (happy_var_1 + ) +happyReduction_39 _ = notHappyAtAll + +happyReduce_40 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_40 = happySpecReduce_3 10# happyReduction_40 +happyReduction_40 (HappyAbsSyn25 happy_var_3) + _ + (HappyAbsSyn25 happy_var_1) + = HappyAbsSyn25 + (sLL happy_var_1 happy_var_3 $ appendFS (unLoc happy_var_1) (consFS '-' (unLoc happy_var_3)) + ) +happyReduction_40 _ _ _ = notHappyAtAll + +happyReduce_41 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_41 = happySpecReduce_0 11# happyReduction_41 +happyReduction_41 = HappyAbsSyn27 + (Nothing + ) + +happyReduce_42 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_42 = happySpecReduce_3 11# happyReduction_42 +happyReduction_42 _ + (HappyAbsSyn28 happy_var_2) + _ + = HappyAbsSyn27 + (Just (fromOL happy_var_2) + ) +happyReduction_42 _ _ _ = notHappyAtAll + +happyReduce_43 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_43 = happySpecReduce_3 12# happyReduction_43 +happyReduction_43 (HappyAbsSyn29 happy_var_3) + _ + (HappyAbsSyn28 happy_var_1) + = HappyAbsSyn28 + (happy_var_1 `appOL` unitOL happy_var_3 + ) +happyReduction_43 _ _ _ = notHappyAtAll + +happyReduce_44 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_44 = happySpecReduce_2 12# happyReduction_44 +happyReduction_44 _ + (HappyAbsSyn28 happy_var_1) + = HappyAbsSyn28 + (happy_var_1 + ) +happyReduction_44 _ _ = notHappyAtAll + +happyReduce_45 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_45 = happySpecReduce_1 12# happyReduction_45 +happyReduction_45 (HappyAbsSyn29 happy_var_1) + = HappyAbsSyn28 + (unitOL happy_var_1 + ) +happyReduction_45 _ = notHappyAtAll + +happyReduce_46 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_46 = happySpecReduce_3 13# happyReduction_46 +happyReduction_46 (HappyAbsSyn317 happy_var_3) + _ + (HappyAbsSyn317 happy_var_1) + = HappyAbsSyn29 + (sLL happy_var_1 happy_var_3 $ Renaming happy_var_1 (Just happy_var_3) + ) +happyReduction_46 _ _ _ = notHappyAtAll + +happyReduce_47 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_47 = happySpecReduce_1 13# happyReduction_47 +happyReduction_47 (HappyAbsSyn317 happy_var_1) + = HappyAbsSyn29 + (sL1 happy_var_1 $ Renaming happy_var_1 Nothing + ) +happyReduction_47 _ = notHappyAtAll + +happyReduce_48 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_48 = happySpecReduce_3 14# happyReduction_48 +happyReduction_48 _ + (HappyAbsSyn30 happy_var_2) + _ + = HappyAbsSyn30 + (happy_var_2 + ) +happyReduction_48 _ _ _ = notHappyAtAll + +happyReduce_49 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_49 = happySpecReduce_3 14# happyReduction_49 +happyReduction_49 _ + (HappyAbsSyn30 happy_var_2) + _ + = HappyAbsSyn30 + (happy_var_2 + ) +happyReduction_49 _ _ _ = notHappyAtAll + +happyReduce_50 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_50 = happySpecReduce_3 15# happyReduction_50 +happyReduction_50 (HappyAbsSyn32 happy_var_3) + _ + (HappyAbsSyn30 happy_var_1) + = HappyAbsSyn30 + (happy_var_1 `appOL` unitOL happy_var_3 + ) +happyReduction_50 _ _ _ = notHappyAtAll + +happyReduce_51 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_51 = happySpecReduce_2 15# happyReduction_51 +happyReduction_51 _ + (HappyAbsSyn30 happy_var_1) + = HappyAbsSyn30 + (happy_var_1 + ) +happyReduction_51 _ _ = notHappyAtAll + +happyReduce_52 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_52 = happySpecReduce_1 15# happyReduction_52 +happyReduction_52 (HappyAbsSyn32 happy_var_1) + = HappyAbsSyn30 + (unitOL happy_var_1 + ) +happyReduction_52 _ = notHappyAtAll + +happyReduce_53 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_53 = happyReduce 7# 16# happyReduction_53 +happyReduction_53 ((HappyAbsSyn39 happy_var_7) `HappyStk` + _ `HappyStk` + (HappyAbsSyn48 happy_var_5) `HappyStk` + (HappyAbsSyn38 happy_var_4) `HappyStk` + (HappyAbsSyn317 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn35 happy_var_1) `HappyStk` + happyRest) + = HappyAbsSyn32 + (sL1 happy_var_2 $ DeclD ModuleD happy_var_3 (Just (sL1 happy_var_2 (HsModule (Just happy_var_3) happy_var_5 (fst $ snd happy_var_7) (snd $ snd happy_var_7) happy_var_4 happy_var_1))) + ) `HappyStk` happyRest + +happyReduce_54 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_54 = happyReduce 7# 16# happyReduction_54 +happyReduction_54 ((HappyAbsSyn39 happy_var_7) `HappyStk` + _ `HappyStk` + (HappyAbsSyn48 happy_var_5) `HappyStk` + (HappyAbsSyn38 happy_var_4) `HappyStk` + (HappyAbsSyn317 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn35 happy_var_1) `HappyStk` + happyRest) + = HappyAbsSyn32 + (sL1 happy_var_2 $ DeclD SignatureD happy_var_3 (Just (sL1 happy_var_2 (HsModule (Just happy_var_3) happy_var_5 (fst $ snd happy_var_7) (snd $ snd happy_var_7) happy_var_4 happy_var_1))) + ) `HappyStk` happyRest + +happyReduce_55 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_55 = happySpecReduce_3 16# happyReduction_55 +happyReduction_55 (HappyAbsSyn317 happy_var_3) + (HappyTerminal happy_var_2) + _ + = HappyAbsSyn32 + (sL1 happy_var_2 $ DeclD ModuleD happy_var_3 Nothing + ) +happyReduction_55 _ _ _ = notHappyAtAll + +happyReduce_56 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_56 = happySpecReduce_3 16# happyReduction_56 +happyReduction_56 (HappyAbsSyn317 happy_var_3) + (HappyTerminal happy_var_2) + _ + = HappyAbsSyn32 + (sL1 happy_var_2 $ DeclD SignatureD happy_var_3 Nothing + ) +happyReduction_56 _ _ _ = notHappyAtAll + +happyReduce_57 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_57 = happySpecReduce_3 16# happyReduction_57 +happyReduction_57 (HappyAbsSyn27 happy_var_3) + (HappyAbsSyn20 happy_var_2) + (HappyTerminal happy_var_1) + = HappyAbsSyn32 + (sL1 happy_var_1 $ IncludeD (IncludeDecl { idUnitId = happy_var_2 + , idModRenaming = happy_var_3 + , idSignatureInclude = False }) + ) +happyReduction_57 _ _ _ = notHappyAtAll + +happyReduce_58 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_58 = happySpecReduce_3 16# happyReduction_58 +happyReduction_58 (HappyAbsSyn20 happy_var_3) + _ + (HappyTerminal happy_var_1) + = HappyAbsSyn32 + (sL1 happy_var_1 $ IncludeD (IncludeDecl { idUnitId = happy_var_3 + , idModRenaming = Nothing + , idSignatureInclude = True }) + ) +happyReduction_58 _ _ _ = notHappyAtAll + +happyReduce_59 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_59 = happyMonadReduce 7# 17# happyReduction_59 +happyReduction_59 ((HappyAbsSyn39 happy_var_7) `HappyStk` + (HappyTerminal happy_var_6) `HappyStk` + (HappyAbsSyn48 happy_var_5) `HappyStk` + (HappyAbsSyn38 happy_var_4) `HappyStk` + (HappyAbsSyn317 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn35 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( fileSrcSpan >>= \ loc -> + ams (cL loc (HsModule (Just happy_var_3) happy_var_5 (fst $ snd happy_var_7) + (snd $ snd happy_var_7) happy_var_4 happy_var_1) + ) + ([mj AnnSignature happy_var_2, mj AnnWhere happy_var_6] ++ fst happy_var_7))) + ) (\r -> happyReturn (HappyAbsSyn33 r)) + +happyReduce_60 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_60 = happyMonadReduce 7# 18# happyReduction_60 +happyReduction_60 ((HappyAbsSyn39 happy_var_7) `HappyStk` + (HappyTerminal happy_var_6) `HappyStk` + (HappyAbsSyn48 happy_var_5) `HappyStk` + (HappyAbsSyn38 happy_var_4) `HappyStk` + (HappyAbsSyn317 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn35 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( fileSrcSpan >>= \ loc -> + ams (cL loc (HsModule (Just happy_var_3) happy_var_5 (fst $ snd happy_var_7) + (snd $ snd happy_var_7) happy_var_4 happy_var_1) + ) + ([mj AnnModule happy_var_2, mj AnnWhere happy_var_6] ++ fst happy_var_7))) + ) (\r -> happyReturn (HappyAbsSyn33 r)) + +happyReduce_61 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_61 = happyMonadReduce 1# 18# happyReduction_61 +happyReduction_61 ((HappyAbsSyn39 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( fileSrcSpan >>= \ loc -> + ams (cL loc (HsModule Nothing Nothing + (fst $ snd happy_var_1) (snd $ snd happy_var_1) Nothing Nothing)) + (fst happy_var_1))) + ) (\r -> happyReturn (HappyAbsSyn33 r)) + +happyReduce_62 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_62 = happySpecReduce_1 19# happyReduction_62 +happyReduction_62 (HappyAbsSyn35 happy_var_1) + = HappyAbsSyn35 + (happy_var_1 + ) +happyReduction_62 _ = notHappyAtAll + +happyReduce_63 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_63 = happySpecReduce_0 19# happyReduction_63 +happyReduction_63 = HappyAbsSyn35 + (Nothing + ) + +happyReduce_64 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_64 = happyMonadReduce 0# 20# happyReduction_64 +happyReduction_64 (happyRest) tk + = happyThen ((( pushModuleContext)) + ) (\r -> happyReturn (HappyAbsSyn36 r)) + +happyReduce_65 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_65 = happyMonadReduce 0# 21# happyReduction_65 +happyReduction_65 (happyRest) tk + = happyThen ((( pushModuleContext)) + ) (\r -> happyReturn (HappyAbsSyn36 r)) + +happyReduce_66 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_66 = happyMonadReduce 3# 22# happyReduction_66 +happyReduction_66 ((HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn138 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ajs (Just (sLL happy_var_1 happy_var_3 $ DeprecatedTxt (sL1 happy_var_1 (getDEPRECATED_PRAGs happy_var_1)) (snd $ unLoc happy_var_2))) + (mo happy_var_1:mc happy_var_3: (fst $ unLoc happy_var_2)))) + ) (\r -> happyReturn (HappyAbsSyn38 r)) + +happyReduce_67 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_67 = happyMonadReduce 3# 22# happyReduction_67 +happyReduction_67 ((HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn138 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ajs (Just (sLL happy_var_1 happy_var_3 $ WarningTxt (sL1 happy_var_1 (getWARNING_PRAGs happy_var_1)) (snd $ unLoc happy_var_2))) + (mo happy_var_1:mc happy_var_3 : (fst $ unLoc happy_var_2)))) + ) (\r -> happyReturn (HappyAbsSyn38 r)) + +happyReduce_68 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_68 = happySpecReduce_0 22# happyReduction_68 +happyReduction_68 = HappyAbsSyn38 + (Nothing + ) + +happyReduce_69 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_69 = happySpecReduce_3 23# happyReduction_69 +happyReduction_69 (HappyTerminal happy_var_3) + (HappyAbsSyn39 happy_var_2) + (HappyTerminal happy_var_1) + = HappyAbsSyn39 + ((moc happy_var_1:mcc happy_var_3:(fst happy_var_2) + , snd happy_var_2) + ) +happyReduction_69 _ _ _ = notHappyAtAll + +happyReduce_70 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_70 = happySpecReduce_3 23# happyReduction_70 +happyReduction_70 _ + (HappyAbsSyn39 happy_var_2) + _ + = HappyAbsSyn39 + ((fst happy_var_2, snd happy_var_2) + ) +happyReduction_70 _ _ _ = notHappyAtAll + +happyReduce_71 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_71 = happySpecReduce_3 24# happyReduction_71 +happyReduction_71 (HappyTerminal happy_var_3) + (HappyAbsSyn39 happy_var_2) + (HappyTerminal happy_var_1) + = HappyAbsSyn39 + ((moc happy_var_1:mcc happy_var_3 + :(fst happy_var_2), snd happy_var_2) + ) +happyReduction_71 _ _ _ = notHappyAtAll + +happyReduce_72 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_72 = happySpecReduce_3 24# happyReduction_72 +happyReduction_72 _ + (HappyAbsSyn39 happy_var_2) + _ + = HappyAbsSyn39 + (([],snd happy_var_2) + ) +happyReduction_72 _ _ _ = notHappyAtAll + +happyReduce_73 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_73 = happySpecReduce_2 25# happyReduction_73 +happyReduction_73 (HappyAbsSyn42 happy_var_2) + (HappyAbsSyn60 happy_var_1) + = HappyAbsSyn39 + ((happy_var_1, happy_var_2) + ) +happyReduction_73 _ _ = notHappyAtAll + +happyReduce_74 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_74 = happySpecReduce_2 26# happyReduction_74 +happyReduction_74 (HappyAbsSyn75 happy_var_2) + (HappyAbsSyn44 happy_var_1) + = HappyAbsSyn42 + ((reverse happy_var_1, cvTopDecls happy_var_2) + ) +happyReduction_74 _ _ = notHappyAtAll + +happyReduce_75 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_75 = happySpecReduce_2 26# happyReduction_75 +happyReduction_75 (HappyAbsSyn75 happy_var_2) + (HappyAbsSyn44 happy_var_1) + = HappyAbsSyn42 + ((reverse happy_var_1, cvTopDecls happy_var_2) + ) +happyReduction_75 _ _ = notHappyAtAll + +happyReduce_76 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_76 = happySpecReduce_1 26# happyReduction_76 +happyReduction_76 (HappyAbsSyn44 happy_var_1) + = HappyAbsSyn42 + ((reverse happy_var_1, []) + ) +happyReduction_76 _ = notHappyAtAll + +happyReduce_77 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_77 = happyMonadReduce 7# 27# happyReduction_77 +happyReduction_77 ((HappyAbsSyn44 happy_var_7) `HappyStk` + (HappyTerminal happy_var_6) `HappyStk` + (HappyAbsSyn48 happy_var_5) `HappyStk` + (HappyAbsSyn38 happy_var_4) `HappyStk` + (HappyAbsSyn317 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn35 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( fileSrcSpan >>= \ loc -> + ams (cL loc (HsModule (Just happy_var_3) happy_var_5 happy_var_7 [] happy_var_4 happy_var_1 + )) [mj AnnModule happy_var_2,mj AnnWhere happy_var_6])) + ) (\r -> happyReturn (HappyAbsSyn33 r)) + +happyReduce_78 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_78 = happyMonadReduce 7# 27# happyReduction_78 +happyReduction_78 ((HappyAbsSyn44 happy_var_7) `HappyStk` + (HappyTerminal happy_var_6) `HappyStk` + (HappyAbsSyn48 happy_var_5) `HappyStk` + (HappyAbsSyn38 happy_var_4) `HappyStk` + (HappyAbsSyn317 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn35 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( fileSrcSpan >>= \ loc -> + ams (cL loc (HsModule (Just happy_var_3) happy_var_5 happy_var_7 [] happy_var_4 happy_var_1 + )) [mj AnnModule happy_var_2,mj AnnWhere happy_var_6])) + ) (\r -> happyReturn (HappyAbsSyn33 r)) + +happyReduce_79 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_79 = happyMonadReduce 1# 27# happyReduction_79 +happyReduction_79 ((HappyAbsSyn44 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( fileSrcSpan >>= \ loc -> + return (cL loc (HsModule Nothing Nothing happy_var_1 [] Nothing + Nothing)))) + ) (\r -> happyReturn (HappyAbsSyn33 r)) + +happyReduce_80 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_80 = happySpecReduce_2 28# happyReduction_80 +happyReduction_80 (HappyAbsSyn44 happy_var_2) + _ + = HappyAbsSyn44 + (happy_var_2 + ) +happyReduction_80 _ _ = notHappyAtAll + +happyReduce_81 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_81 = happySpecReduce_2 28# happyReduction_81 +happyReduction_81 (HappyAbsSyn44 happy_var_2) + _ + = HappyAbsSyn44 + (happy_var_2 + ) +happyReduction_81 _ _ = notHappyAtAll + +happyReduce_82 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_82 = happySpecReduce_2 29# happyReduction_82 +happyReduction_82 (HappyAbsSyn44 happy_var_2) + _ + = HappyAbsSyn44 + (happy_var_2 + ) +happyReduction_82 _ _ = notHappyAtAll + +happyReduce_83 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_83 = happySpecReduce_2 29# happyReduction_83 +happyReduction_83 (HappyAbsSyn44 happy_var_2) + _ + = HappyAbsSyn44 + (happy_var_2 + ) +happyReduction_83 _ _ = notHappyAtAll + +happyReduce_84 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_84 = happySpecReduce_2 30# happyReduction_84 +happyReduction_84 (HappyAbsSyn44 happy_var_2) + _ + = HappyAbsSyn44 + (happy_var_2 + ) +happyReduction_84 _ _ = notHappyAtAll + +happyReduce_85 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_85 = happySpecReduce_1 31# happyReduction_85 +happyReduction_85 (HappyAbsSyn44 happy_var_1) + = HappyAbsSyn44 + (happy_var_1 + ) +happyReduction_85 _ = notHappyAtAll + +happyReduce_86 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_86 = happySpecReduce_1 31# happyReduction_86 +happyReduction_86 (HappyAbsSyn44 happy_var_1) + = HappyAbsSyn44 + (happy_var_1 + ) +happyReduction_86 _ = notHappyAtAll + +happyReduce_87 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_87 = happyMonadReduce 3# 32# happyReduction_87 +happyReduction_87 ((HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn49 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( amsL (comb2 happy_var_1 happy_var_3) [mop happy_var_1,mcp happy_var_3] >> + return (Just (sLL happy_var_1 happy_var_3 (fromOL happy_var_2))))) + ) (\r -> happyReturn (HappyAbsSyn48 r)) + +happyReduce_88 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_88 = happySpecReduce_0 32# happyReduction_88 +happyReduction_88 = HappyAbsSyn48 + (Nothing + ) + +happyReduce_89 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_89 = happyMonadReduce 3# 33# happyReduction_89 +happyReduction_89 ((HappyAbsSyn49 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn49 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( addAnnotation (oll happy_var_1) AnnComma (gl happy_var_2) + >> return (happy_var_1 `appOL` happy_var_3))) + ) (\r -> happyReturn (HappyAbsSyn49 r)) + +happyReduce_90 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_90 = happySpecReduce_1 33# happyReduction_90 +happyReduction_90 (HappyAbsSyn49 happy_var_1) + = HappyAbsSyn49 + (happy_var_1 + ) +happyReduction_90 _ = notHappyAtAll + +happyReduce_91 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_91 = happyMonadReduce 5# 34# happyReduction_91 +happyReduction_91 ((HappyAbsSyn49 happy_var_5) `HappyStk` + (HappyTerminal happy_var_4) `HappyStk` + (HappyAbsSyn49 happy_var_3) `HappyStk` + (HappyAbsSyn49 happy_var_2) `HappyStk` + (HappyAbsSyn49 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( (addAnnotation (oll (happy_var_1 `appOL` happy_var_2 `appOL` happy_var_3)) + AnnComma (gl happy_var_4) ) >> + return (happy_var_1 `appOL` happy_var_2 `appOL` happy_var_3 `appOL` happy_var_5))) + ) (\r -> happyReturn (HappyAbsSyn49 r)) + +happyReduce_92 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_92 = happySpecReduce_3 34# happyReduction_92 +happyReduction_92 (HappyAbsSyn49 happy_var_3) + (HappyAbsSyn49 happy_var_2) + (HappyAbsSyn49 happy_var_1) + = HappyAbsSyn49 + (happy_var_1 `appOL` happy_var_2 `appOL` happy_var_3 + ) +happyReduction_92 _ _ _ = notHappyAtAll + +happyReduce_93 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_93 = happySpecReduce_1 34# happyReduction_93 +happyReduction_93 (HappyAbsSyn49 happy_var_1) + = HappyAbsSyn49 + (happy_var_1 + ) +happyReduction_93 _ = notHappyAtAll + +happyReduce_94 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_94 = happySpecReduce_2 35# happyReduction_94 +happyReduction_94 (HappyAbsSyn49 happy_var_2) + (HappyAbsSyn49 happy_var_1) + = HappyAbsSyn49 + (happy_var_1 `appOL` happy_var_2 + ) +happyReduction_94 _ _ = notHappyAtAll + +happyReduce_95 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_95 = happySpecReduce_0 35# happyReduction_95 +happyReduction_95 = HappyAbsSyn49 + (nilOL + ) + +happyReduce_96 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_96 = happySpecReduce_1 36# happyReduction_96 +happyReduction_96 (HappyAbsSyn324 happy_var_1) + = HappyAbsSyn49 + (unitOL (sL1 happy_var_1 (case (unLoc happy_var_1) of (n, doc) -> IEGroup noExt n doc)) + ) +happyReduction_96 _ = notHappyAtAll + +happyReduce_97 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_97 = happySpecReduce_1 36# happyReduction_97 +happyReduction_97 (HappyAbsSyn323 happy_var_1) + = HappyAbsSyn49 + (unitOL (sL1 happy_var_1 (IEDocNamed noExt ((fst . unLoc) happy_var_1))) + ) +happyReduction_97 _ = notHappyAtAll + +happyReduce_98 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_98 = happySpecReduce_1 36# happyReduction_98 +happyReduction_98 (HappyAbsSyn321 happy_var_1) + = HappyAbsSyn49 + (unitOL (sL1 happy_var_1 (IEDoc noExt (unLoc happy_var_1))) + ) +happyReduction_98 _ = notHappyAtAll + +happyReduce_99 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_99 = happyMonadReduce 2# 37# happyReduction_99 +happyReduction_99 ((HappyAbsSyn54 happy_var_2) `HappyStk` + (HappyAbsSyn58 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( mkModuleImpExp happy_var_1 (snd $ unLoc happy_var_2) + >>= \ie -> amsu (sLL happy_var_1 happy_var_2 ie) (fst $ unLoc happy_var_2))) + ) (\r -> happyReturn (HappyAbsSyn49 r)) + +happyReduce_100 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_100 = happyMonadReduce 2# 37# happyReduction_100 +happyReduction_100 ((HappyAbsSyn317 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( amsu (sLL happy_var_1 happy_var_2 (IEModuleContents noExt happy_var_2)) + [mj AnnModule happy_var_1])) + ) (\r -> happyReturn (HappyAbsSyn49 r)) + +happyReduce_101 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_101 = happyMonadReduce 2# 37# happyReduction_101 +happyReduction_101 ((HappyAbsSyn16 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( amsu (sLL happy_var_1 happy_var_2 (IEVar noExt (sLL happy_var_1 happy_var_2 (IEPattern happy_var_2)))) + [mj AnnPattern happy_var_1])) + ) (\r -> happyReturn (HappyAbsSyn49 r)) + +happyReduce_102 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_102 = happySpecReduce_0 38# happyReduction_102 +happyReduction_102 = HappyAbsSyn54 + (sL0 ([],ImpExpAbs) + ) + +happyReduce_103 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_103 = happyMonadReduce 3# 38# happyReduction_103 +happyReduction_103 ((HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn55 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( mkImpExpSubSpec (reverse (snd happy_var_2)) + >>= \(as,ie) -> return $ sLL happy_var_1 happy_var_3 + (as ++ [mop happy_var_1,mcp happy_var_3] ++ fst happy_var_2, ie))) + ) (\r -> happyReturn (HappyAbsSyn54 r)) + +happyReduce_104 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_104 = happySpecReduce_0 39# happyReduction_104 +happyReduction_104 = HappyAbsSyn55 + (([],[]) + ) + +happyReduce_105 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_105 = happySpecReduce_1 39# happyReduction_105 +happyReduction_105 (HappyAbsSyn55 happy_var_1) + = HappyAbsSyn55 + (happy_var_1 + ) +happyReduction_105 _ = notHappyAtAll + +happyReduce_106 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_106 = happyMonadReduce 3# 40# happyReduction_106 +happyReduction_106 ((HappyAbsSyn57 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn55 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( case (head (snd happy_var_1)) of + l@(dL->L _ ImpExpQcWildcard) -> + return ([mj AnnComma happy_var_2, mj AnnDotdot l] + ,(snd (unLoc happy_var_3) : snd happy_var_1)) + l -> (ams (head (snd happy_var_1)) [mj AnnComma happy_var_2] >> + return (fst happy_var_1 ++ fst (unLoc happy_var_3), + snd (unLoc happy_var_3) : snd happy_var_1)))) + ) (\r -> happyReturn (HappyAbsSyn55 r)) + +happyReduce_107 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_107 = happySpecReduce_1 40# happyReduction_107 +happyReduction_107 (HappyAbsSyn57 happy_var_1) + = HappyAbsSyn55 + ((fst (unLoc happy_var_1),[snd (unLoc happy_var_1)]) + ) +happyReduction_107 _ = notHappyAtAll + +happyReduce_108 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_108 = happySpecReduce_1 41# happyReduction_108 +happyReduction_108 (HappyAbsSyn58 happy_var_1) + = HappyAbsSyn57 + (sL1 happy_var_1 ([],happy_var_1) + ) +happyReduction_108 _ = notHappyAtAll + +happyReduce_109 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_109 = happySpecReduce_1 41# happyReduction_109 +happyReduction_109 (HappyTerminal happy_var_1) + = HappyAbsSyn57 + (sL1 happy_var_1 ([mj AnnDotdot happy_var_1], sL1 happy_var_1 ImpExpQcWildcard) + ) +happyReduction_109 _ = notHappyAtAll + +happyReduce_110 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_110 = happySpecReduce_1 42# happyReduction_110 +happyReduction_110 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn58 + (sL1 happy_var_1 (ImpExpQcName happy_var_1) + ) +happyReduction_110 _ = notHappyAtAll + +happyReduce_111 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_111 = happyMonadReduce 2# 42# happyReduction_111 +happyReduction_111 ((HappyAbsSyn16 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( do { n <- mkTypeImpExp happy_var_2 + ; ams (sLL happy_var_1 happy_var_2 (ImpExpQcType n)) + [mj AnnType happy_var_1] })) + ) (\r -> happyReturn (HappyAbsSyn58 r)) + +happyReduce_112 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_112 = happySpecReduce_1 43# happyReduction_112 +happyReduction_112 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn16 + (happy_var_1 + ) +happyReduction_112 _ = notHappyAtAll + +happyReduce_113 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_113 = happySpecReduce_1 43# happyReduction_113 +happyReduction_113 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn16 + (happy_var_1 + ) +happyReduction_113 _ = notHappyAtAll + +happyReduce_114 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_114 = happySpecReduce_2 44# happyReduction_114 +happyReduction_114 (HappyTerminal happy_var_2) + (HappyAbsSyn60 happy_var_1) + = HappyAbsSyn60 + (mj AnnSemi happy_var_2 : happy_var_1 + ) +happyReduction_114 _ _ = notHappyAtAll + +happyReduce_115 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_115 = happySpecReduce_1 44# happyReduction_115 +happyReduction_115 (HappyTerminal happy_var_1) + = HappyAbsSyn60 + ([mj AnnSemi happy_var_1] + ) +happyReduction_115 _ = notHappyAtAll + +happyReduce_116 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_116 = happySpecReduce_2 45# happyReduction_116 +happyReduction_116 (HappyTerminal happy_var_2) + (HappyAbsSyn60 happy_var_1) + = HappyAbsSyn60 + (mj AnnSemi happy_var_2 : happy_var_1 + ) +happyReduction_116 _ _ = notHappyAtAll + +happyReduce_117 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_117 = happySpecReduce_0 45# happyReduction_117 +happyReduction_117 = HappyAbsSyn60 + ([] + ) + +happyReduce_118 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_118 = happySpecReduce_2 46# happyReduction_118 +happyReduction_118 (HappyAbsSyn64 happy_var_2) + (HappyAbsSyn44 happy_var_1) + = HappyAbsSyn44 + (happy_var_2 : happy_var_1 + ) +happyReduction_118 _ _ = notHappyAtAll + +happyReduce_119 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_119 = happyMonadReduce 3# 47# happyReduction_119 +happyReduction_119 ((HappyAbsSyn60 happy_var_3) `HappyStk` + (HappyAbsSyn64 happy_var_2) `HappyStk` + (HappyAbsSyn44 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams happy_var_2 happy_var_3 >> return (happy_var_2 : happy_var_1))) + ) (\r -> happyReturn (HappyAbsSyn44 r)) + +happyReduce_120 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_120 = happySpecReduce_0 47# happyReduction_120 +happyReduction_120 = HappyAbsSyn44 + ([] + ) + +happyReduce_121 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_121 = happyMonadReduce 8# 48# happyReduction_121 +happyReduction_121 ((HappyAbsSyn70 happy_var_8) `HappyStk` + (HappyAbsSyn69 happy_var_7) `HappyStk` + (HappyAbsSyn317 happy_var_6) `HappyStk` + (HappyAbsSyn67 happy_var_5) `HappyStk` + (HappyAbsSyn66 happy_var_4) `HappyStk` + (HappyAbsSyn66 happy_var_3) `HappyStk` + (HappyAbsSyn65 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (cL (comb4 happy_var_1 happy_var_6 (snd happy_var_7) happy_var_8) $ + ImportDecl { ideclExt = noExt + , ideclSourceSrc = snd $ fst happy_var_2 + , ideclName = happy_var_6, ideclPkgQual = snd happy_var_5 + , ideclSource = snd happy_var_2, ideclSafe = snd happy_var_3 + , ideclQualified = snd happy_var_4, ideclImplicit = False + , ideclAs = unLoc (snd happy_var_7) + , ideclHiding = unLoc happy_var_8 }) + ((mj AnnImport happy_var_1 : (fst $ fst happy_var_2) ++ fst happy_var_3 ++ fst happy_var_4 + ++ fst happy_var_5 ++ fst happy_var_7)))) + ) (\r -> happyReturn (HappyAbsSyn64 r)) + +happyReduce_122 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_122 = happySpecReduce_2 49# happyReduction_122 +happyReduction_122 (HappyTerminal happy_var_2) + (HappyTerminal happy_var_1) + = HappyAbsSyn65 + ((([mo happy_var_1,mc happy_var_2],getSOURCE_PRAGs happy_var_1) + ,True) + ) +happyReduction_122 _ _ = notHappyAtAll + +happyReduce_123 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_123 = happySpecReduce_0 49# happyReduction_123 +happyReduction_123 = HappyAbsSyn65 + ((([],NoSourceText),False) + ) + +happyReduce_124 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_124 = happySpecReduce_1 50# happyReduction_124 +happyReduction_124 (HappyTerminal happy_var_1) + = HappyAbsSyn66 + (([mj AnnSafe happy_var_1],True) + ) +happyReduction_124 _ = notHappyAtAll + +happyReduce_125 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_125 = happySpecReduce_0 50# happyReduction_125 +happyReduction_125 = HappyAbsSyn66 + (([],False) + ) + +happyReduce_126 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_126 = happyMonadReduce 1# 51# happyReduction_126 +happyReduction_126 ((HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( do { let { pkgFS = getSTRING happy_var_1 } + ; unless (looksLikePackageName (unpackFS pkgFS)) $ + addError (getLoc happy_var_1) $ vcat [ + text "Parse error" <> colon <+> quotes (ppr pkgFS), + text "Version number or non-alphanumeric" <+> + text "character in package name"] + ; return ([mj AnnPackageName happy_var_1], Just (StringLiteral (getSTRINGs happy_var_1) pkgFS)) })) + ) (\r -> happyReturn (HappyAbsSyn67 r)) + +happyReduce_127 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_127 = happySpecReduce_0 51# happyReduction_127 +happyReduction_127 = HappyAbsSyn67 + (([],Nothing) + ) + +happyReduce_128 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_128 = happySpecReduce_1 52# happyReduction_128 +happyReduction_128 (HappyTerminal happy_var_1) + = HappyAbsSyn66 + (([mj AnnQualified happy_var_1],True) + ) +happyReduction_128 _ = notHappyAtAll + +happyReduce_129 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_129 = happySpecReduce_0 52# happyReduction_129 +happyReduction_129 = HappyAbsSyn66 + (([],False) + ) + +happyReduce_130 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_130 = happySpecReduce_2 53# happyReduction_130 +happyReduction_130 (HappyAbsSyn317 happy_var_2) + (HappyTerminal happy_var_1) + = HappyAbsSyn69 + (([mj AnnAs happy_var_1] + ,sLL happy_var_1 happy_var_2 (Just happy_var_2)) + ) +happyReduction_130 _ _ = notHappyAtAll + +happyReduce_131 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_131 = happySpecReduce_0 53# happyReduction_131 +happyReduction_131 = HappyAbsSyn69 + (([],noLoc Nothing) + ) + +happyReduce_132 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_132 = happyMonadReduce 1# 54# happyReduction_132 +happyReduction_132 ((HappyAbsSyn71 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( let (b, ie) = unLoc happy_var_1 in + checkImportSpec ie + >>= \checkedIe -> + return (cL (gl happy_var_1) (Just (b, checkedIe))))) + ) (\r -> happyReturn (HappyAbsSyn70 r)) + +happyReduce_133 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_133 = happySpecReduce_0 54# happyReduction_133 +happyReduction_133 = HappyAbsSyn70 + (noLoc Nothing + ) + +happyReduce_134 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_134 = happyMonadReduce 3# 55# happyReduction_134 +happyReduction_134 ((HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn49 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_3 (False, + sLL happy_var_1 happy_var_3 $ fromOL happy_var_2)) + [mop happy_var_1,mcp happy_var_3])) + ) (\r -> happyReturn (HappyAbsSyn71 r)) + +happyReduce_135 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_135 = happyMonadReduce 4# 55# happyReduction_135 +happyReduction_135 ((HappyTerminal happy_var_4) `HappyStk` + (HappyAbsSyn49 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_4 (True, + sLL happy_var_1 happy_var_4 $ fromOL happy_var_3)) + [mj AnnHiding happy_var_1,mop happy_var_2,mcp happy_var_4])) + ) (\r -> happyReturn (HappyAbsSyn71 r)) + +happyReduce_136 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_136 = happySpecReduce_0 56# happyReduction_136 +happyReduction_136 = HappyAbsSyn72 + (noLoc (NoSourceText,9) + ) + +happyReduce_137 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_137 = happySpecReduce_1 56# happyReduction_137 +happyReduction_137 (HappyTerminal happy_var_1) + = HappyAbsSyn72 + (sL1 happy_var_1 (getINTEGERs happy_var_1,fromInteger (il_value (getINTEGER happy_var_1))) + ) +happyReduction_137 _ = notHappyAtAll + +happyReduce_138 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_138 = happySpecReduce_1 57# happyReduction_138 +happyReduction_138 (HappyTerminal happy_var_1) + = HappyAbsSyn73 + (sL1 happy_var_1 InfixN + ) +happyReduction_138 _ = notHappyAtAll + +happyReduce_139 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_139 = happySpecReduce_1 57# happyReduction_139 +happyReduction_139 (HappyTerminal happy_var_1) + = HappyAbsSyn73 + (sL1 happy_var_1 InfixL + ) +happyReduction_139 _ = notHappyAtAll + +happyReduce_140 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_140 = happySpecReduce_1 57# happyReduction_140 +happyReduction_140 (HappyTerminal happy_var_1) + = HappyAbsSyn73 + (sL1 happy_var_1 InfixR + ) +happyReduction_140 _ = notHappyAtAll + +happyReduce_141 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_141 = happyMonadReduce 3# 58# happyReduction_141 +happyReduction_141 ((HappyAbsSyn16 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn74 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( addAnnotation (oll $ unLoc happy_var_1) AnnComma (gl happy_var_2) >> + return (sLL happy_var_1 happy_var_3 ((unLoc happy_var_1) `appOL` unitOL happy_var_3)))) + ) (\r -> happyReturn (HappyAbsSyn74 r)) + +happyReduce_142 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_142 = happySpecReduce_1 58# happyReduction_142 +happyReduction_142 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn74 + (sL1 happy_var_1 (unitOL happy_var_1) + ) +happyReduction_142 _ = notHappyAtAll + +happyReduce_143 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_143 = happySpecReduce_2 59# happyReduction_143 +happyReduction_143 (HappyAbsSyn77 happy_var_2) + (HappyAbsSyn75 happy_var_1) + = HappyAbsSyn75 + (happy_var_1 `snocOL` happy_var_2 + ) +happyReduction_143 _ _ = notHappyAtAll + +happyReduce_144 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_144 = happyMonadReduce 3# 60# happyReduction_144 +happyReduction_144 ((HappyAbsSyn60 happy_var_3) `HappyStk` + (HappyAbsSyn77 happy_var_2) `HappyStk` + (HappyAbsSyn75 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams happy_var_2 happy_var_3 >> return (happy_var_1 `snocOL` happy_var_2))) + ) (\r -> happyReturn (HappyAbsSyn75 r)) + +happyReduce_145 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_145 = happySpecReduce_0 60# happyReduction_145 +happyReduction_145 = HappyAbsSyn75 + (nilOL + ) + +happyReduce_146 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_146 = happySpecReduce_1 61# happyReduction_146 +happyReduction_146 (HappyAbsSyn78 happy_var_1) + = HappyAbsSyn77 + (sL1 happy_var_1 (TyClD noExt (unLoc happy_var_1)) + ) +happyReduction_146 _ = notHappyAtAll + +happyReduce_147 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_147 = happySpecReduce_1 61# happyReduction_147 +happyReduction_147 (HappyAbsSyn78 happy_var_1) + = HappyAbsSyn77 + (sL1 happy_var_1 (TyClD noExt (unLoc happy_var_1)) + ) +happyReduction_147 _ = notHappyAtAll + +happyReduce_148 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_148 = happySpecReduce_1 61# happyReduction_148 +happyReduction_148 (HappyAbsSyn80 happy_var_1) + = HappyAbsSyn77 + (sL1 happy_var_1 (InstD noExt (unLoc happy_var_1)) + ) +happyReduction_148 _ = notHappyAtAll + +happyReduce_149 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_149 = happySpecReduce_1 61# happyReduction_149 +happyReduction_149 (HappyAbsSyn104 happy_var_1) + = HappyAbsSyn77 + (sLL happy_var_1 happy_var_1 (DerivD noExt (unLoc happy_var_1)) + ) +happyReduction_149 _ = notHappyAtAll + +happyReduce_150 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_150 = happySpecReduce_1 61# happyReduction_150 +happyReduction_150 (HappyAbsSyn105 happy_var_1) + = HappyAbsSyn77 + (sL1 happy_var_1 (RoleAnnotD noExt (unLoc happy_var_1)) + ) +happyReduction_150 _ = notHappyAtAll + +happyReduce_151 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_151 = happyMonadReduce 4# 61# happyReduction_151 +happyReduction_151 ((HappyTerminal happy_var_4) `HappyStk` + (HappyAbsSyn170 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_4 (DefD noExt (DefaultDecl noExt happy_var_3))) + [mj AnnDefault happy_var_1 + ,mop happy_var_2,mcp happy_var_4])) + ) (\r -> happyReturn (HappyAbsSyn77 r)) + +happyReduce_152 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_152 = happyMonadReduce 2# 61# happyReduction_152 +happyReduction_152 ((HappyAbsSyn141 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_2 (snd $ unLoc happy_var_2)) + (mj AnnForeign happy_var_1:(fst $ unLoc happy_var_2)))) + ) (\r -> happyReturn (HappyAbsSyn77 r)) + +happyReduce_153 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_153 = happyMonadReduce 3# 61# happyReduction_153 +happyReduction_153 ((HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn134 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_3 $ WarningD noExt (Warnings noExt (getDEPRECATED_PRAGs happy_var_1) (fromOL happy_var_2))) + [mo happy_var_1,mc happy_var_3])) + ) (\r -> happyReturn (HappyAbsSyn77 r)) + +happyReduce_154 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_154 = happyMonadReduce 3# 61# happyReduction_154 +happyReduction_154 ((HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn134 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_3 $ WarningD noExt (Warnings noExt (getWARNING_PRAGs happy_var_1) (fromOL happy_var_2))) + [mo happy_var_1,mc happy_var_3])) + ) (\r -> happyReturn (HappyAbsSyn77 r)) + +happyReduce_155 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_155 = happyMonadReduce 3# 61# happyReduction_155 +happyReduction_155 ((HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn127 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_3 $ RuleD noExt (HsRules noExt (getRULES_PRAGs happy_var_1) (fromOL happy_var_2))) + [mo happy_var_1,mc happy_var_3])) + ) (\r -> happyReturn (HappyAbsSyn77 r)) + +happyReduce_156 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_156 = happySpecReduce_1 61# happyReduction_156 +happyReduction_156 (HappyAbsSyn77 happy_var_1) + = HappyAbsSyn77 + (happy_var_1 + ) +happyReduction_156 _ = notHappyAtAll + +happyReduce_157 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_157 = happySpecReduce_1 61# happyReduction_157 +happyReduction_157 (HappyAbsSyn77 happy_var_1) + = HappyAbsSyn77 + (happy_var_1 + ) +happyReduction_157 _ = notHappyAtAll + +happyReduce_158 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_158 = happySpecReduce_1 61# happyReduction_158 +happyReduction_158 (HappyAbsSyn209 happy_var_1) + = HappyAbsSyn77 + (sLL happy_var_1 happy_var_1 $ mkSpliceDecl happy_var_1 + ) +happyReduction_158 _ = notHappyAtAll + +happyReduce_159 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_159 = happyMonadReduce 4# 62# happyReduction_159 +happyReduction_159 ((HappyAbsSyn118 happy_var_4) `HappyStk` + (HappyAbsSyn175 happy_var_3) `HappyStk` + (HappyAbsSyn101 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( amms (mkClassDecl (comb4 happy_var_1 happy_var_2 happy_var_3 happy_var_4) happy_var_2 happy_var_3 (snd $ unLoc happy_var_4)) + (mj AnnClass happy_var_1:(fst $ unLoc happy_var_3)++(fst $ unLoc happy_var_4)))) + ) (\r -> happyReturn (HappyAbsSyn78 r)) + +happyReduce_160 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_160 = happyMonadReduce 4# 63# happyReduction_160 +happyReduction_160 ((HappyAbsSyn147 happy_var_4) `HappyStk` + (HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn147 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( amms (mkTySynonym (comb2 happy_var_1 happy_var_4) happy_var_2 happy_var_4) + [mj AnnType happy_var_1,mj AnnEqual happy_var_3])) + ) (\r -> happyReturn (HappyAbsSyn78 r)) + +happyReduce_161 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_161 = happyMonadReduce 6# 63# happyReduction_161 +happyReduction_161 ((HappyAbsSyn88 happy_var_6) `HappyStk` + (HappyAbsSyn85 happy_var_5) `HappyStk` + (HappyAbsSyn98 happy_var_4) `HappyStk` + (HappyAbsSyn147 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( amms (mkFamDecl (comb4 happy_var_1 happy_var_3 happy_var_4 happy_var_5) (snd $ unLoc happy_var_6) happy_var_3 + (snd $ unLoc happy_var_4) (snd $ unLoc happy_var_5)) + (mj AnnType happy_var_1:mj AnnFamily happy_var_2:(fst $ unLoc happy_var_4) + ++ (fst $ unLoc happy_var_5) ++ (fst $ unLoc happy_var_6)))) + ) (\r -> happyReturn (HappyAbsSyn78 r)) + +happyReduce_162 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_162 = happyMonadReduce 5# 63# happyReduction_162 +happyReduction_162 ((HappyAbsSyn192 happy_var_5) `HappyStk` + (HappyAbsSyn184 happy_var_4) `HappyStk` + (HappyAbsSyn101 happy_var_3) `HappyStk` + (HappyAbsSyn103 happy_var_2) `HappyStk` + (HappyAbsSyn96 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( amms (mkTyData (comb4 happy_var_1 happy_var_3 happy_var_4 happy_var_5) (snd $ unLoc happy_var_1) happy_var_2 happy_var_3 + Nothing (reverse (snd $ unLoc happy_var_4)) + (fmap reverse happy_var_5)) + -- We need the location on tycl_hdr in case + -- constrs and deriving are both empty + ((fst $ unLoc happy_var_1):(fst $ unLoc happy_var_4)))) + ) (\r -> happyReturn (HappyAbsSyn78 r)) + +happyReduce_163 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_163 = happyMonadReduce 6# 63# happyReduction_163 +happyReduction_163 ((HappyAbsSyn192 happy_var_6) `HappyStk` + (HappyAbsSyn180 happy_var_5) `HappyStk` + (HappyAbsSyn97 happy_var_4) `HappyStk` + (HappyAbsSyn101 happy_var_3) `HappyStk` + (HappyAbsSyn103 happy_var_2) `HappyStk` + (HappyAbsSyn96 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( amms (mkTyData (comb4 happy_var_1 happy_var_3 happy_var_5 happy_var_6) (snd $ unLoc happy_var_1) happy_var_2 happy_var_3 + (snd $ unLoc happy_var_4) (snd $ unLoc happy_var_5) + (fmap reverse happy_var_6) ) + -- We need the location on tycl_hdr in case + -- constrs and deriving are both empty + ((fst $ unLoc happy_var_1):(fst $ unLoc happy_var_4)++(fst $ unLoc happy_var_5)))) + ) (\r -> happyReturn (HappyAbsSyn78 r)) + +happyReduce_164 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_164 = happyMonadReduce 4# 63# happyReduction_164 +happyReduction_164 ((HappyAbsSyn98 happy_var_4) `HappyStk` + (HappyAbsSyn147 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( amms (mkFamDecl (comb3 happy_var_1 happy_var_2 happy_var_4) DataFamily happy_var_3 + (snd $ unLoc happy_var_4) Nothing) + (mj AnnData happy_var_1:mj AnnFamily happy_var_2:(fst $ unLoc happy_var_4)))) + ) (\r -> happyReturn (HappyAbsSyn78 r)) + +happyReduce_165 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_165 = happyMonadReduce 4# 64# happyReduction_165 +happyReduction_165 ((HappyAbsSyn122 happy_var_4) `HappyStk` + (HappyAbsSyn168 happy_var_3) `HappyStk` + (HappyAbsSyn81 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( do { (binds, sigs, _, ats, adts, _) <- cvBindsAndSigs (snd $ unLoc happy_var_4) + ; let cid = ClsInstDecl { cid_ext = noExt + , cid_poly_ty = happy_var_3, cid_binds = binds + , cid_sigs = mkClassOpSigs sigs + , cid_tyfam_insts = ats + , cid_overlap_mode = happy_var_2 + , cid_datafam_insts = adts } + ; ams (cL (comb3 happy_var_1 (hsSigType happy_var_3) happy_var_4) (ClsInstD { cid_d_ext = noExt, cid_inst = cid })) + (mj AnnInstance happy_var_1 : (fst $ unLoc happy_var_4)) })) + ) (\r -> happyReturn (HappyAbsSyn80 r)) + +happyReduce_166 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_166 = happyMonadReduce 3# 64# happyReduction_166 +happyReduction_166 ((HappyAbsSyn91 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams happy_var_3 (fst $ unLoc happy_var_3) + >> amms (mkTyFamInst (comb2 happy_var_1 happy_var_3) (snd $ unLoc happy_var_3)) + (mj AnnType happy_var_1:mj AnnInstance happy_var_2:(fst $ unLoc happy_var_3)))) + ) (\r -> happyReturn (HappyAbsSyn80 r)) + +happyReduce_167 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_167 = happyMonadReduce 6# 64# happyReduction_167 +happyReduction_167 ((HappyAbsSyn192 happy_var_6) `HappyStk` + (HappyAbsSyn184 happy_var_5) `HappyStk` + (HappyAbsSyn102 happy_var_4) `HappyStk` + (HappyAbsSyn103 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn96 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( amms (mkDataFamInst (comb4 happy_var_1 happy_var_4 happy_var_5 happy_var_6) (snd $ unLoc happy_var_1) happy_var_3 (snd $ unLoc happy_var_4) + Nothing (reverse (snd $ unLoc happy_var_5)) + (fmap reverse happy_var_6)) + ((fst $ unLoc happy_var_1):mj AnnInstance happy_var_2:(fst $ unLoc happy_var_4)++(fst $ unLoc happy_var_5)))) + ) (\r -> happyReturn (HappyAbsSyn80 r)) + +happyReduce_168 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_168 = happyMonadReduce 7# 64# happyReduction_168 +happyReduction_168 ((HappyAbsSyn192 happy_var_7) `HappyStk` + (HappyAbsSyn180 happy_var_6) `HappyStk` + (HappyAbsSyn97 happy_var_5) `HappyStk` + (HappyAbsSyn102 happy_var_4) `HappyStk` + (HappyAbsSyn103 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn96 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( amms (mkDataFamInst (comb4 happy_var_1 happy_var_4 happy_var_6 happy_var_7) (snd $ unLoc happy_var_1) happy_var_3 (snd $ unLoc happy_var_4) + (snd $ unLoc happy_var_5) (snd $ unLoc happy_var_6) + (fmap reverse happy_var_7)) + ((fst $ unLoc happy_var_1):mj AnnInstance happy_var_2 + :(fst $ unLoc happy_var_4)++(fst $ unLoc happy_var_5)++(fst $ unLoc happy_var_6)))) + ) (\r -> happyReturn (HappyAbsSyn80 r)) + +happyReduce_169 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_169 = happyMonadReduce 2# 65# happyReduction_169 +happyReduction_169 ((HappyTerminal happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ajs (Just (sLL happy_var_1 happy_var_2 (Overlappable (getOVERLAPPABLE_PRAGs happy_var_1)))) + [mo happy_var_1,mc happy_var_2])) + ) (\r -> happyReturn (HappyAbsSyn81 r)) + +happyReduce_170 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_170 = happyMonadReduce 2# 65# happyReduction_170 +happyReduction_170 ((HappyTerminal happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ajs (Just (sLL happy_var_1 happy_var_2 (Overlapping (getOVERLAPPING_PRAGs happy_var_1)))) + [mo happy_var_1,mc happy_var_2])) + ) (\r -> happyReturn (HappyAbsSyn81 r)) + +happyReduce_171 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_171 = happyMonadReduce 2# 65# happyReduction_171 +happyReduction_171 ((HappyTerminal happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ajs (Just (sLL happy_var_1 happy_var_2 (Overlaps (getOVERLAPS_PRAGs happy_var_1)))) + [mo happy_var_1,mc happy_var_2])) + ) (\r -> happyReturn (HappyAbsSyn81 r)) + +happyReduce_172 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_172 = happyMonadReduce 2# 65# happyReduction_172 +happyReduction_172 ((HappyTerminal happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ajs (Just (sLL happy_var_1 happy_var_2 (Incoherent (getINCOHERENT_PRAGs happy_var_1)))) + [mo happy_var_1,mc happy_var_2])) + ) (\r -> happyReturn (HappyAbsSyn81 r)) + +happyReduce_173 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_173 = happySpecReduce_0 65# happyReduction_173 +happyReduction_173 = HappyAbsSyn81 + (Nothing + ) + +happyReduce_174 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_174 = happyMonadReduce 1# 66# happyReduction_174 +happyReduction_174 ((HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sL1 happy_var_1 StockStrategy) + [mj AnnStock happy_var_1])) + ) (\r -> happyReturn (HappyAbsSyn82 r)) + +happyReduce_175 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_175 = happyMonadReduce 1# 66# happyReduction_175 +happyReduction_175 ((HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sL1 happy_var_1 AnyclassStrategy) + [mj AnnAnyclass happy_var_1])) + ) (\r -> happyReturn (HappyAbsSyn82 r)) + +happyReduce_176 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_176 = happyMonadReduce 1# 66# happyReduction_176 +happyReduction_176 ((HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sL1 happy_var_1 NewtypeStrategy) + [mj AnnNewtype happy_var_1])) + ) (\r -> happyReturn (HappyAbsSyn82 r)) + +happyReduce_177 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_177 = happyMonadReduce 2# 67# happyReduction_177 +happyReduction_177 ((HappyAbsSyn147 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_2 (ViaStrategy (mkLHsSigType happy_var_2))) + [mj AnnVia happy_var_1])) + ) (\r -> happyReturn (HappyAbsSyn82 r)) + +happyReduce_178 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_178 = happyMonadReduce 1# 68# happyReduction_178 +happyReduction_178 ((HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ajs (Just (sL1 happy_var_1 StockStrategy)) + [mj AnnStock happy_var_1])) + ) (\r -> happyReturn (HappyAbsSyn84 r)) + +happyReduce_179 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_179 = happyMonadReduce 1# 68# happyReduction_179 +happyReduction_179 ((HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ajs (Just (sL1 happy_var_1 AnyclassStrategy)) + [mj AnnAnyclass happy_var_1])) + ) (\r -> happyReturn (HappyAbsSyn84 r)) + +happyReduce_180 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_180 = happyMonadReduce 1# 68# happyReduction_180 +happyReduction_180 ((HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ajs (Just (sL1 happy_var_1 NewtypeStrategy)) + [mj AnnNewtype happy_var_1])) + ) (\r -> happyReturn (HappyAbsSyn84 r)) + +happyReduce_181 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_181 = happySpecReduce_1 68# happyReduction_181 +happyReduction_181 (HappyAbsSyn82 happy_var_1) + = HappyAbsSyn84 + (Just happy_var_1 + ) +happyReduction_181 _ = notHappyAtAll + +happyReduce_182 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_182 = happySpecReduce_0 68# happyReduction_182 +happyReduction_182 = HappyAbsSyn84 + (Nothing + ) + +happyReduce_183 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_183 = happySpecReduce_0 69# happyReduction_183 +happyReduction_183 = HappyAbsSyn85 + (noLoc ([], Nothing) + ) + +happyReduce_184 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_184 = happySpecReduce_2 69# happyReduction_184 +happyReduction_184 (HappyAbsSyn86 happy_var_2) + (HappyTerminal happy_var_1) + = HappyAbsSyn85 + (sLL happy_var_1 happy_var_2 ([mj AnnVbar happy_var_1] + , Just (happy_var_2)) + ) +happyReduction_184 _ _ = notHappyAtAll + +happyReduce_185 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_185 = happyMonadReduce 3# 70# happyReduction_185 +happyReduction_185 ((HappyAbsSyn87 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn16 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_3 (InjectivityAnn happy_var_1 (reverse (unLoc happy_var_3)))) + [mu AnnRarrow happy_var_2])) + ) (\r -> happyReturn (HappyAbsSyn86 r)) + +happyReduce_186 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_186 = happySpecReduce_2 71# happyReduction_186 +happyReduction_186 (HappyAbsSyn16 happy_var_2) + (HappyAbsSyn87 happy_var_1) + = HappyAbsSyn87 + (sLL happy_var_1 happy_var_2 (happy_var_2 : unLoc happy_var_1) + ) +happyReduction_186 _ _ = notHappyAtAll + +happyReduce_187 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_187 = happySpecReduce_1 71# happyReduction_187 +happyReduction_187 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn87 + (sLL happy_var_1 happy_var_1 [happy_var_1] + ) +happyReduction_187 _ = notHappyAtAll + +happyReduce_188 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_188 = happySpecReduce_0 72# happyReduction_188 +happyReduction_188 = HappyAbsSyn88 + (noLoc ([],OpenTypeFamily) + ) + +happyReduce_189 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_189 = happySpecReduce_2 72# happyReduction_189 +happyReduction_189 (HappyAbsSyn89 happy_var_2) + (HappyTerminal happy_var_1) + = HappyAbsSyn88 + (sLL happy_var_1 happy_var_2 (mj AnnWhere happy_var_1:(fst $ unLoc happy_var_2) + ,ClosedTypeFamily (fmap reverse $ snd $ unLoc happy_var_2)) + ) +happyReduction_189 _ _ = notHappyAtAll + +happyReduce_190 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_190 = happySpecReduce_3 73# happyReduction_190 +happyReduction_190 (HappyTerminal happy_var_3) + (HappyAbsSyn90 happy_var_2) + (HappyTerminal happy_var_1) + = HappyAbsSyn89 + (sLL happy_var_1 happy_var_3 ([moc happy_var_1,mcc happy_var_3] + ,Just (unLoc happy_var_2)) + ) +happyReduction_190 _ _ _ = notHappyAtAll + +happyReduce_191 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_191 = happySpecReduce_3 73# happyReduction_191 +happyReduction_191 _ + (HappyAbsSyn90 happy_var_2) + _ + = HappyAbsSyn89 + (let (dL->L loc _) = happy_var_2 in + cL loc ([],Just (unLoc happy_var_2)) + ) +happyReduction_191 _ _ _ = notHappyAtAll + +happyReduce_192 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_192 = happySpecReduce_3 73# happyReduction_192 +happyReduction_192 (HappyTerminal happy_var_3) + (HappyTerminal happy_var_2) + (HappyTerminal happy_var_1) + = HappyAbsSyn89 + (sLL happy_var_1 happy_var_3 ([moc happy_var_1,mj AnnDotdot happy_var_2 + ,mcc happy_var_3],Nothing) + ) +happyReduction_192 _ _ _ = notHappyAtAll + +happyReduce_193 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_193 = happySpecReduce_3 73# happyReduction_193 +happyReduction_193 _ + (HappyTerminal happy_var_2) + _ + = HappyAbsSyn89 + (let (dL->L loc _) = happy_var_2 in + cL loc ([mj AnnDotdot happy_var_2],Nothing) + ) +happyReduction_193 _ _ _ = notHappyAtAll + +happyReduce_194 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_194 = happyMonadReduce 3# 74# happyReduction_194 +happyReduction_194 ((HappyAbsSyn91 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn90 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( let (dL->L loc (anns, eqn)) = happy_var_3 in + asl (unLoc happy_var_1) happy_var_2 (cL loc eqn) + >> ams happy_var_3 anns + >> return (sLL happy_var_1 happy_var_3 (cL loc eqn : unLoc happy_var_1)))) + ) (\r -> happyReturn (HappyAbsSyn90 r)) + +happyReduce_195 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_195 = happyMonadReduce 2# 74# happyReduction_195 +happyReduction_195 ((HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn90 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( addAnnotation (gl happy_var_1) AnnSemi (gl happy_var_2) + >> return (sLL happy_var_1 happy_var_2 (unLoc happy_var_1)))) + ) (\r -> happyReturn (HappyAbsSyn90 r)) + +happyReduce_196 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_196 = happyMonadReduce 1# 74# happyReduction_196 +happyReduction_196 ((HappyAbsSyn91 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( let (dL->L loc (anns, eqn)) = happy_var_1 in + ams happy_var_1 anns + >> return (sLL happy_var_1 happy_var_1 [cL loc eqn]))) + ) (\r -> happyReturn (HappyAbsSyn90 r)) + +happyReduce_197 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_197 = happySpecReduce_0 74# happyReduction_197 +happyReduction_197 = HappyAbsSyn90 + (noLoc [] + ) + +happyReduce_198 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_198 = happyMonadReduce 6# 75# happyReduction_198 +happyReduction_198 ((HappyAbsSyn147 happy_var_6) `HappyStk` + (HappyTerminal happy_var_5) `HappyStk` + (HappyAbsSyn147 happy_var_4) `HappyStk` + (HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn173 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( do { hintExplicitForall happy_var_1 + ; (eqn,ann) <- mkTyFamInstEqn (Just happy_var_2) happy_var_4 happy_var_6 + ; return (sLL happy_var_1 happy_var_6 + (mu AnnForall happy_var_1:mj AnnDot happy_var_3:mj AnnEqual happy_var_5:ann,eqn)) })) + ) (\r -> happyReturn (HappyAbsSyn91 r)) + +happyReduce_199 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_199 = happyMonadReduce 3# 75# happyReduction_199 +happyReduction_199 ((HappyAbsSyn147 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn147 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( do { (eqn,ann) <- mkTyFamInstEqn Nothing happy_var_1 happy_var_3 + ; return (sLL happy_var_1 happy_var_3 (mj AnnEqual happy_var_2:ann, eqn)) })) + ) (\r -> happyReturn (HappyAbsSyn91 r)) + +happyReduce_200 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_200 = happyMonadReduce 4# 76# happyReduction_200 +happyReduction_200 ((HappyAbsSyn98 happy_var_4) `HappyStk` + (HappyAbsSyn147 happy_var_3) `HappyStk` + (HappyAbsSyn60 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( amms (liftM mkTyClD (mkFamDecl (comb3 happy_var_1 happy_var_3 happy_var_4) DataFamily happy_var_3 + (snd $ unLoc happy_var_4) Nothing)) + (mj AnnData happy_var_1:happy_var_2++(fst $ unLoc happy_var_4)))) + ) (\r -> happyReturn (HappyAbsSyn77 r)) + +happyReduce_201 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_201 = happyMonadReduce 3# 76# happyReduction_201 +happyReduction_201 ((HappyAbsSyn100 happy_var_3) `HappyStk` + (HappyAbsSyn147 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( amms (liftM mkTyClD + (mkFamDecl (comb3 happy_var_1 happy_var_2 happy_var_3) OpenTypeFamily happy_var_2 + (fst . snd $ unLoc happy_var_3) + (snd . snd $ unLoc happy_var_3))) + (mj AnnType happy_var_1:(fst $ unLoc happy_var_3)))) + ) (\r -> happyReturn (HappyAbsSyn77 r)) + +happyReduce_202 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_202 = happyMonadReduce 4# 76# happyReduction_202 +happyReduction_202 ((HappyAbsSyn100 happy_var_4) `HappyStk` + (HappyAbsSyn147 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( amms (liftM mkTyClD + (mkFamDecl (comb3 happy_var_1 happy_var_3 happy_var_4) OpenTypeFamily happy_var_3 + (fst . snd $ unLoc happy_var_4) + (snd . snd $ unLoc happy_var_4))) + (mj AnnType happy_var_1:mj AnnFamily happy_var_2:(fst $ unLoc happy_var_4)))) + ) (\r -> happyReturn (HappyAbsSyn77 r)) + +happyReduce_203 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_203 = happyMonadReduce 2# 76# happyReduction_203 +happyReduction_203 ((HappyAbsSyn91 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams happy_var_2 (fst $ unLoc happy_var_2) >> + amms (liftM mkInstD (mkTyFamInst (comb2 happy_var_1 happy_var_2) (snd $ unLoc happy_var_2))) + (mj AnnType happy_var_1:(fst $ unLoc happy_var_2)))) + ) (\r -> happyReturn (HappyAbsSyn77 r)) + +happyReduce_204 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_204 = happyMonadReduce 3# 76# happyReduction_204 +happyReduction_204 ((HappyAbsSyn91 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams happy_var_3 (fst $ unLoc happy_var_3) >> + amms (liftM mkInstD (mkTyFamInst (comb2 happy_var_1 happy_var_3) (snd $ unLoc happy_var_3))) + (mj AnnType happy_var_1:mj AnnInstance happy_var_2:(fst $ unLoc happy_var_3)))) + ) (\r -> happyReturn (HappyAbsSyn77 r)) + +happyReduce_205 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_205 = happySpecReduce_0 77# happyReduction_205 +happyReduction_205 = HappyAbsSyn60 + ([] + ) + +happyReduce_206 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_206 = happySpecReduce_1 77# happyReduction_206 +happyReduction_206 (HappyTerminal happy_var_1) + = HappyAbsSyn60 + ([mj AnnFamily happy_var_1] + ) +happyReduction_206 _ = notHappyAtAll + +happyReduce_207 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_207 = happySpecReduce_0 78# happyReduction_207 +happyReduction_207 = HappyAbsSyn60 + ([] + ) + +happyReduce_208 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_208 = happySpecReduce_1 78# happyReduction_208 +happyReduction_208 (HappyTerminal happy_var_1) + = HappyAbsSyn60 + ([mj AnnInstance happy_var_1] + ) +happyReduction_208 _ = notHappyAtAll + +happyReduce_209 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_209 = happyMonadReduce 3# 79# happyReduction_209 +happyReduction_209 ((HappyAbsSyn91 happy_var_3) `HappyStk` + (HappyAbsSyn60 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams happy_var_3 (fst $ unLoc happy_var_3) >> + amms (mkTyFamInst (comb2 happy_var_1 happy_var_3) (snd $ unLoc happy_var_3)) + (mj AnnType happy_var_1:happy_var_2++(fst $ unLoc happy_var_3)))) + ) (\r -> happyReturn (HappyAbsSyn80 r)) + +happyReduce_210 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_210 = happyMonadReduce 5# 79# happyReduction_210 +happyReduction_210 ((HappyAbsSyn192 happy_var_5) `HappyStk` + (HappyAbsSyn184 happy_var_4) `HappyStk` + (HappyAbsSyn102 happy_var_3) `HappyStk` + (HappyAbsSyn103 happy_var_2) `HappyStk` + (HappyAbsSyn96 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( amms (mkDataFamInst (comb4 happy_var_1 happy_var_3 happy_var_4 happy_var_5) (snd $ unLoc happy_var_1) happy_var_2 (snd $ unLoc happy_var_3) + Nothing (reverse (snd $ unLoc happy_var_4)) + (fmap reverse happy_var_5)) + ((fst $ unLoc happy_var_1):(fst $ unLoc happy_var_3) ++ (fst $ unLoc happy_var_4)))) + ) (\r -> happyReturn (HappyAbsSyn80 r)) + +happyReduce_211 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_211 = happyMonadReduce 6# 79# happyReduction_211 +happyReduction_211 ((HappyAbsSyn192 happy_var_6) `HappyStk` + (HappyAbsSyn184 happy_var_5) `HappyStk` + (HappyAbsSyn102 happy_var_4) `HappyStk` + (HappyAbsSyn103 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn96 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( amms (mkDataFamInst (comb4 happy_var_1 happy_var_4 happy_var_5 happy_var_6) (snd $ unLoc happy_var_1) happy_var_3 (snd $ unLoc happy_var_4) + Nothing (reverse (snd $ unLoc happy_var_5)) + (fmap reverse happy_var_6)) + ((fst $ unLoc happy_var_1):mj AnnInstance happy_var_2:(fst $ unLoc happy_var_4)++(fst $ unLoc happy_var_5)))) + ) (\r -> happyReturn (HappyAbsSyn80 r)) + +happyReduce_212 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_212 = happyMonadReduce 6# 79# happyReduction_212 +happyReduction_212 ((HappyAbsSyn192 happy_var_6) `HappyStk` + (HappyAbsSyn180 happy_var_5) `HappyStk` + (HappyAbsSyn97 happy_var_4) `HappyStk` + (HappyAbsSyn102 happy_var_3) `HappyStk` + (HappyAbsSyn103 happy_var_2) `HappyStk` + (HappyAbsSyn96 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( amms (mkDataFamInst (comb4 happy_var_1 happy_var_3 happy_var_5 happy_var_6) (snd $ unLoc happy_var_1) happy_var_2 + (snd $ unLoc happy_var_3) (snd $ unLoc happy_var_4) (snd $ unLoc happy_var_5) + (fmap reverse happy_var_6)) + ((fst $ unLoc happy_var_1):(fst $ unLoc happy_var_3)++(fst $ unLoc happy_var_4)++(fst $ unLoc happy_var_5)))) + ) (\r -> happyReturn (HappyAbsSyn80 r)) + +happyReduce_213 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_213 = happyMonadReduce 7# 79# happyReduction_213 +happyReduction_213 ((HappyAbsSyn192 happy_var_7) `HappyStk` + (HappyAbsSyn180 happy_var_6) `HappyStk` + (HappyAbsSyn97 happy_var_5) `HappyStk` + (HappyAbsSyn102 happy_var_4) `HappyStk` + (HappyAbsSyn103 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn96 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( amms (mkDataFamInst (comb4 happy_var_1 happy_var_4 happy_var_6 happy_var_7) (snd $ unLoc happy_var_1) happy_var_3 + (snd $ unLoc happy_var_4) (snd $ unLoc happy_var_5) (snd $ unLoc happy_var_6) + (fmap reverse happy_var_7)) + ((fst $ unLoc happy_var_1):mj AnnInstance happy_var_2:(fst $ unLoc happy_var_4)++(fst $ unLoc happy_var_5)++(fst $ unLoc happy_var_6)))) + ) (\r -> happyReturn (HappyAbsSyn80 r)) + +happyReduce_214 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_214 = happySpecReduce_1 80# happyReduction_214 +happyReduction_214 (HappyTerminal happy_var_1) + = HappyAbsSyn96 + (sL1 happy_var_1 (mj AnnData happy_var_1,DataType) + ) +happyReduction_214 _ = notHappyAtAll + +happyReduce_215 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_215 = happySpecReduce_1 80# happyReduction_215 +happyReduction_215 (HappyTerminal happy_var_1) + = HappyAbsSyn96 + (sL1 happy_var_1 (mj AnnNewtype happy_var_1,NewType) + ) +happyReduction_215 _ = notHappyAtAll + +happyReduce_216 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_216 = happySpecReduce_0 81# happyReduction_216 +happyReduction_216 = HappyAbsSyn97 + (noLoc ([] , Nothing) + ) + +happyReduce_217 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_217 = happySpecReduce_2 81# happyReduction_217 +happyReduction_217 (HappyAbsSyn179 happy_var_2) + (HappyTerminal happy_var_1) + = HappyAbsSyn97 + (sLL happy_var_1 happy_var_2 ([mu AnnDcolon happy_var_1], Just happy_var_2) + ) +happyReduction_217 _ _ = notHappyAtAll + +happyReduce_218 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_218 = happySpecReduce_0 82# happyReduction_218 +happyReduction_218 = HappyAbsSyn98 + (noLoc ([] , noLoc (NoSig noExt) ) + ) + +happyReduce_219 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_219 = happySpecReduce_2 82# happyReduction_219 +happyReduction_219 (HappyAbsSyn179 happy_var_2) + (HappyTerminal happy_var_1) + = HappyAbsSyn98 + (sLL happy_var_1 happy_var_2 ([mu AnnDcolon happy_var_1], sLL happy_var_1 happy_var_2 (KindSig noExt happy_var_2)) + ) +happyReduction_219 _ _ = notHappyAtAll + +happyReduce_220 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_220 = happySpecReduce_0 83# happyReduction_220 +happyReduction_220 = HappyAbsSyn98 + (noLoc ([] , noLoc (NoSig noExt) ) + ) + +happyReduce_221 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_221 = happySpecReduce_2 83# happyReduction_221 +happyReduction_221 (HappyAbsSyn179 happy_var_2) + (HappyTerminal happy_var_1) + = HappyAbsSyn98 + (sLL happy_var_1 happy_var_2 ([mu AnnDcolon happy_var_1], sLL happy_var_1 happy_var_2 (KindSig noExt happy_var_2)) + ) +happyReduction_221 _ _ = notHappyAtAll + +happyReduce_222 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_222 = happySpecReduce_2 83# happyReduction_222 +happyReduction_222 (HappyAbsSyn174 happy_var_2) + (HappyTerminal happy_var_1) + = HappyAbsSyn98 + (sLL happy_var_1 happy_var_2 ([mj AnnEqual happy_var_1] , sLL happy_var_1 happy_var_2 (TyVarSig noExt happy_var_2)) + ) +happyReduction_222 _ _ = notHappyAtAll + +happyReduce_223 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_223 = happySpecReduce_0 84# happyReduction_223 +happyReduction_223 = HappyAbsSyn100 + (noLoc ([], (noLoc (NoSig noExt), Nothing)) + ) + +happyReduce_224 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_224 = happySpecReduce_2 84# happyReduction_224 +happyReduction_224 (HappyAbsSyn179 happy_var_2) + (HappyTerminal happy_var_1) + = HappyAbsSyn100 + (sLL happy_var_1 happy_var_2 ( [mu AnnDcolon happy_var_1] + , (sLL happy_var_2 happy_var_2 (KindSig noExt happy_var_2), Nothing)) + ) +happyReduction_224 _ _ = notHappyAtAll + +happyReduce_225 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_225 = happyReduce 4# 84# happyReduction_225 +happyReduction_225 ((HappyAbsSyn86 happy_var_4) `HappyStk` + (HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn174 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) + = HappyAbsSyn100 + (sLL happy_var_1 happy_var_4 ([mj AnnEqual happy_var_1, mj AnnVbar happy_var_3] + , (sLL happy_var_1 happy_var_2 (TyVarSig noExt happy_var_2), Just happy_var_4)) + ) `HappyStk` happyRest + +happyReduce_226 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_226 = happyMonadReduce 3# 85# happyReduction_226 +happyReduction_226 ((HappyAbsSyn147 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn157 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( addAnnotation (gl happy_var_1) (toUnicodeAnn AnnDarrow happy_var_2) (gl happy_var_2) + >> (return (sLL happy_var_1 happy_var_3 (Just happy_var_1, happy_var_3))))) + ) (\r -> happyReturn (HappyAbsSyn101 r)) + +happyReduce_227 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_227 = happySpecReduce_1 85# happyReduction_227 +happyReduction_227 (HappyAbsSyn147 happy_var_1) + = HappyAbsSyn101 + (sL1 happy_var_1 (Nothing, happy_var_1) + ) +happyReduction_227 _ = notHappyAtAll + +happyReduce_228 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_228 = happyMonadReduce 6# 86# happyReduction_228 +happyReduction_228 ((HappyAbsSyn147 happy_var_6) `HappyStk` + (HappyTerminal happy_var_5) `HappyStk` + (HappyAbsSyn157 happy_var_4) `HappyStk` + (HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn173 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( hintExplicitForall happy_var_1 + >> (addAnnotation (gl happy_var_4) (toUnicodeAnn AnnDarrow happy_var_5) (gl happy_var_5) + >> return (sLL happy_var_1 happy_var_6 ([mu AnnForall happy_var_1, mj AnnDot happy_var_3] + , (Just happy_var_4, Just happy_var_2, happy_var_6))) + ))) + ) (\r -> happyReturn (HappyAbsSyn102 r)) + +happyReduce_229 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_229 = happyMonadReduce 4# 86# happyReduction_229 +happyReduction_229 ((HappyAbsSyn147 happy_var_4) `HappyStk` + (HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn173 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( hintExplicitForall happy_var_1 + >> return (sLL happy_var_1 happy_var_4 ([mu AnnForall happy_var_1, mj AnnDot happy_var_3] + , (Nothing, Just happy_var_2, happy_var_4))))) + ) (\r -> happyReturn (HappyAbsSyn102 r)) + +happyReduce_230 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_230 = happyMonadReduce 3# 86# happyReduction_230 +happyReduction_230 ((HappyAbsSyn147 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn157 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( addAnnotation (gl happy_var_1) (toUnicodeAnn AnnDarrow happy_var_2) (gl happy_var_2) + >> (return (sLL happy_var_1 happy_var_3([], (Just happy_var_1, Nothing, happy_var_3)))))) + ) (\r -> happyReturn (HappyAbsSyn102 r)) + +happyReduce_231 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_231 = happySpecReduce_1 86# happyReduction_231 +happyReduction_231 (HappyAbsSyn147 happy_var_1) + = HappyAbsSyn102 + (sL1 happy_var_1 ([], (Nothing, Nothing, happy_var_1)) + ) +happyReduction_231 _ = notHappyAtAll + +happyReduce_232 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_232 = happyMonadReduce 4# 87# happyReduction_232 +happyReduction_232 ((HappyTerminal happy_var_4) `HappyStk` + (HappyTerminal happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ajs (Just (sLL happy_var_1 happy_var_4 (CType (getCTYPEs happy_var_1) (Just (Header (getSTRINGs happy_var_2) (getSTRING happy_var_2))) + (getSTRINGs happy_var_3,getSTRING happy_var_3)))) + [mo happy_var_1,mj AnnHeader happy_var_2,mj AnnVal happy_var_3,mc happy_var_4])) + ) (\r -> happyReturn (HappyAbsSyn103 r)) + +happyReduce_233 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_233 = happyMonadReduce 3# 87# happyReduction_233 +happyReduction_233 ((HappyTerminal happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ajs (Just (sLL happy_var_1 happy_var_3 (CType (getCTYPEs happy_var_1) Nothing (getSTRINGs happy_var_2, getSTRING happy_var_2)))) + [mo happy_var_1,mj AnnVal happy_var_2,mc happy_var_3])) + ) (\r -> happyReturn (HappyAbsSyn103 r)) + +happyReduce_234 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_234 = happySpecReduce_0 87# happyReduction_234 +happyReduction_234 = HappyAbsSyn103 + (Nothing + ) + +happyReduce_235 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_235 = happyMonadReduce 5# 88# happyReduction_235 +happyReduction_235 ((HappyAbsSyn168 happy_var_5) `HappyStk` + (HappyAbsSyn81 happy_var_4) `HappyStk` + (HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn84 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( do { let { err = text "in the stand-alone deriving instance" + <> colon <+> quotes (ppr happy_var_5) } + ; ams (sLL happy_var_1 (hsSigType happy_var_5) + (DerivDecl noExt (mkHsWildCardBndrs happy_var_5) happy_var_2 happy_var_4)) + [mj AnnDeriving happy_var_1, mj AnnInstance happy_var_3] })) + ) (\r -> happyReturn (HappyAbsSyn104 r)) + +happyReduce_236 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_236 = happyMonadReduce 4# 89# happyReduction_236 +happyReduction_236 ((HappyAbsSyn106 happy_var_4) `HappyStk` + (HappyAbsSyn16 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( amms (mkRoleAnnotDecl (comb3 happy_var_1 happy_var_3 happy_var_4) happy_var_3 (reverse (unLoc happy_var_4))) + [mj AnnType happy_var_1,mj AnnRole happy_var_2])) + ) (\r -> happyReturn (HappyAbsSyn105 r)) + +happyReduce_237 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_237 = happySpecReduce_0 90# happyReduction_237 +happyReduction_237 = HappyAbsSyn106 + (noLoc [] + ) + +happyReduce_238 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_238 = happySpecReduce_1 90# happyReduction_238 +happyReduction_238 (HappyAbsSyn106 happy_var_1) + = HappyAbsSyn106 + (happy_var_1 + ) +happyReduction_238 _ = notHappyAtAll + +happyReduce_239 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_239 = happySpecReduce_1 91# happyReduction_239 +happyReduction_239 (HappyAbsSyn108 happy_var_1) + = HappyAbsSyn106 + (sLL happy_var_1 happy_var_1 [happy_var_1] + ) +happyReduction_239 _ = notHappyAtAll + +happyReduce_240 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_240 = happySpecReduce_2 91# happyReduction_240 +happyReduction_240 (HappyAbsSyn108 happy_var_2) + (HappyAbsSyn106 happy_var_1) + = HappyAbsSyn106 + (sLL happy_var_1 happy_var_2 $ happy_var_2 : unLoc happy_var_1 + ) +happyReduction_240 _ _ = notHappyAtAll + +happyReduce_241 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_241 = happySpecReduce_1 92# happyReduction_241 +happyReduction_241 (HappyTerminal happy_var_1) + = HappyAbsSyn108 + (sL1 happy_var_1 $ Just $ getVARID happy_var_1 + ) +happyReduction_241 _ = notHappyAtAll + +happyReduce_242 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_242 = happySpecReduce_1 92# happyReduction_242 +happyReduction_242 (HappyTerminal happy_var_1) + = HappyAbsSyn108 + (sL1 happy_var_1 Nothing + ) +happyReduction_242 _ = notHappyAtAll + +happyReduce_243 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_243 = happyMonadReduce 4# 93# happyReduction_243 +happyReduction_243 ((HappyAbsSyn247 happy_var_4) `HappyStk` + (HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn110 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( let (name, args,as ) = happy_var_2 in + ams (sLL happy_var_1 happy_var_4 . ValD noExt $ mkPatSynBind name args happy_var_4 + ImplicitBidirectional) + (as ++ [mj AnnPattern happy_var_1, mj AnnEqual happy_var_3]))) + ) (\r -> happyReturn (HappyAbsSyn77 r)) + +happyReduce_244 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_244 = happyMonadReduce 4# 93# happyReduction_244 +happyReduction_244 ((HappyAbsSyn247 happy_var_4) `HappyStk` + (HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn110 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( let (name, args, as) = happy_var_2 in + ams (sLL happy_var_1 happy_var_4 . ValD noExt $ mkPatSynBind name args happy_var_4 Unidirectional) + (as ++ [mj AnnPattern happy_var_1,mu AnnLarrow happy_var_3]))) + ) (\r -> happyReturn (HappyAbsSyn77 r)) + +happyReduce_245 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_245 = happyMonadReduce 5# 93# happyReduction_245 +happyReduction_245 ((HappyAbsSyn113 happy_var_5) `HappyStk` + (HappyAbsSyn247 happy_var_4) `HappyStk` + (HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn110 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( do { let (name, args, as) = happy_var_2 + ; mg <- mkPatSynMatchGroup name (snd $ unLoc happy_var_5) + ; ams (sLL happy_var_1 happy_var_5 . ValD noExt $ + mkPatSynBind name args happy_var_4 (ExplicitBidirectional mg)) + (as ++ ((mj AnnPattern happy_var_1:mu AnnLarrow happy_var_3:(fst $ unLoc happy_var_5))) ) + })) + ) (\r -> happyReturn (HappyAbsSyn77 r)) + +happyReduce_246 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_246 = happySpecReduce_2 94# happyReduction_246 +happyReduction_246 (HappyAbsSyn111 happy_var_2) + (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn110 + ((happy_var_1, PrefixCon happy_var_2, []) + ) +happyReduction_246 _ _ = notHappyAtAll + +happyReduce_247 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_247 = happySpecReduce_3 94# happyReduction_247 +happyReduction_247 (HappyAbsSyn16 happy_var_3) + (HappyAbsSyn16 happy_var_2) + (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn110 + ((happy_var_2, InfixCon happy_var_1 happy_var_3, []) + ) +happyReduction_247 _ _ _ = notHappyAtAll + +happyReduce_248 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_248 = happyReduce 4# 94# happyReduction_248 +happyReduction_248 ((HappyTerminal happy_var_4) `HappyStk` + (HappyAbsSyn112 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn16 happy_var_1) `HappyStk` + happyRest) + = HappyAbsSyn110 + ((happy_var_1, RecCon happy_var_3, [moc happy_var_2, mcc happy_var_4] ) + ) `HappyStk` happyRest + +happyReduce_249 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_249 = happySpecReduce_0 95# happyReduction_249 +happyReduction_249 = HappyAbsSyn111 + ([] + ) + +happyReduce_250 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_250 = happySpecReduce_2 95# happyReduction_250 +happyReduction_250 (HappyAbsSyn111 happy_var_2) + (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn111 + (happy_var_1 : happy_var_2 + ) +happyReduction_250 _ _ = notHappyAtAll + +happyReduce_251 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_251 = happySpecReduce_1 96# happyReduction_251 +happyReduction_251 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn112 + ([RecordPatSynField happy_var_1 happy_var_1] + ) +happyReduction_251 _ = notHappyAtAll + +happyReduce_252 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_252 = happyMonadReduce 3# 96# happyReduction_252 +happyReduction_252 ((HappyAbsSyn112 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn16 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( addAnnotation (getLoc happy_var_1) AnnComma (getLoc happy_var_2) >> + return ((RecordPatSynField happy_var_1 happy_var_1) : happy_var_3 ))) + ) (\r -> happyReturn (HappyAbsSyn112 r)) + +happyReduce_253 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_253 = happyReduce 4# 97# happyReduction_253 +happyReduction_253 ((HappyTerminal happy_var_4) `HappyStk` + (HappyAbsSyn116 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) + = HappyAbsSyn113 + (sLL happy_var_1 happy_var_4 ((mj AnnWhere happy_var_1:moc happy_var_2 + :mcc happy_var_4:(fst $ unLoc happy_var_3)),sL1 happy_var_3 (snd $ unLoc happy_var_3)) + ) `HappyStk` happyRest + +happyReduce_254 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_254 = happyReduce 4# 97# happyReduction_254 +happyReduction_254 (_ `HappyStk` + (HappyAbsSyn116 happy_var_3) `HappyStk` + _ `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) + = HappyAbsSyn113 + (cL (comb2 happy_var_1 happy_var_3) ((mj AnnWhere happy_var_1:(fst $ unLoc happy_var_3)) + ,sL1 happy_var_3 (snd $ unLoc happy_var_3)) + ) `HappyStk` happyRest + +happyReduce_255 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_255 = happyMonadReduce 4# 98# happyReduction_255 +happyReduction_255 ((HappyAbsSyn147 happy_var_4) `HappyStk` + (HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn87 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_4 $ PatSynSig noExt (unLoc happy_var_2) (mkLHsSigType happy_var_4)) + [mj AnnPattern happy_var_1, mu AnnDcolon happy_var_3])) + ) (\r -> happyReturn (HappyAbsSyn114 r)) + +happyReduce_256 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_256 = happySpecReduce_1 99# happyReduction_256 +happyReduction_256 (HappyAbsSyn77 happy_var_1) + = HappyAbsSyn77 + (happy_var_1 + ) +happyReduction_256 _ = notHappyAtAll + +happyReduce_257 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_257 = happySpecReduce_1 99# happyReduction_257 +happyReduction_257 (HappyAbsSyn77 happy_var_1) + = HappyAbsSyn77 + (happy_var_1 + ) +happyReduction_257 _ = notHappyAtAll + +happyReduce_258 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_258 = happyMonadReduce 4# 99# happyReduction_258 +happyReduction_258 ((HappyAbsSyn147 happy_var_4) `HappyStk` + (HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn207 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_2 >>= \ happy_var_2 -> + do { v <- checkValSigLhs happy_var_2 + ; let err = text "in default signature" <> colon <+> + quotes (ppr happy_var_2) + ; ams (sLL happy_var_1 happy_var_4 $ SigD noExt $ ClassOpSig noExt True [v] $ mkLHsSigType happy_var_4) + [mj AnnDefault happy_var_1,mu AnnDcolon happy_var_3] })) + ) (\r -> happyReturn (HappyAbsSyn77 r)) + +happyReduce_259 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_259 = happyMonadReduce 3# 100# happyReduction_259 +happyReduction_259 ((HappyAbsSyn77 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn116 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( if isNilOL (snd $ unLoc happy_var_1) + then return (sLL happy_var_1 happy_var_3 (mj AnnSemi happy_var_2:(fst $ unLoc happy_var_1) + , unitOL happy_var_3)) + else ams (lastOL (snd $ unLoc happy_var_1)) [mj AnnSemi happy_var_2] + >> return (sLL happy_var_1 happy_var_3 (fst $ unLoc happy_var_1 + ,(snd $ unLoc happy_var_1) `appOL` unitOL happy_var_3)))) + ) (\r -> happyReturn (HappyAbsSyn116 r)) + +happyReduce_260 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_260 = happyMonadReduce 2# 100# happyReduction_260 +happyReduction_260 ((HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn116 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( if isNilOL (snd $ unLoc happy_var_1) + then return (sLL happy_var_1 happy_var_2 (mj AnnSemi happy_var_2:(fst $ unLoc happy_var_1) + ,snd $ unLoc happy_var_1)) + else ams (lastOL (snd $ unLoc happy_var_1)) [mj AnnSemi happy_var_2] + >> return (sLL happy_var_1 happy_var_2 (unLoc happy_var_1)))) + ) (\r -> happyReturn (HappyAbsSyn116 r)) + +happyReduce_261 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_261 = happySpecReduce_1 100# happyReduction_261 +happyReduction_261 (HappyAbsSyn77 happy_var_1) + = HappyAbsSyn116 + (sL1 happy_var_1 ([], unitOL happy_var_1) + ) +happyReduction_261 _ = notHappyAtAll + +happyReduce_262 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_262 = happySpecReduce_0 100# happyReduction_262 +happyReduction_262 = HappyAbsSyn116 + (noLoc ([],nilOL) + ) + +happyReduce_263 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_263 = happySpecReduce_3 101# happyReduction_263 +happyReduction_263 (HappyTerminal happy_var_3) + (HappyAbsSyn116 happy_var_2) + (HappyTerminal happy_var_1) + = HappyAbsSyn117 + (sLL happy_var_1 happy_var_3 (moc happy_var_1:mcc happy_var_3:(fst $ unLoc happy_var_2) + ,snd $ unLoc happy_var_2) + ) +happyReduction_263 _ _ _ = notHappyAtAll + +happyReduce_264 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_264 = happySpecReduce_3 101# happyReduction_264 +happyReduction_264 _ + (HappyAbsSyn116 happy_var_2) + _ + = HappyAbsSyn117 + (happy_var_2 + ) +happyReduction_264 _ _ _ = notHappyAtAll + +happyReduce_265 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_265 = happySpecReduce_2 102# happyReduction_265 +happyReduction_265 (HappyAbsSyn117 happy_var_2) + (HappyTerminal happy_var_1) + = HappyAbsSyn118 + (sLL happy_var_1 happy_var_2 (mj AnnWhere happy_var_1:(fst $ unLoc happy_var_2) + ,snd $ unLoc happy_var_2) + ) +happyReduction_265 _ _ = notHappyAtAll + +happyReduce_266 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_266 = happySpecReduce_0 102# happyReduction_266 +happyReduction_266 = HappyAbsSyn118 + (noLoc ([],nilOL) + ) + +happyReduce_267 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_267 = happySpecReduce_1 103# happyReduction_267 +happyReduction_267 (HappyAbsSyn80 happy_var_1) + = HappyAbsSyn119 + (sLL happy_var_1 happy_var_1 (unitOL (sL1 happy_var_1 (InstD noExt (unLoc happy_var_1)))) + ) +happyReduction_267 _ = notHappyAtAll + +happyReduce_268 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_268 = happySpecReduce_1 103# happyReduction_268 +happyReduction_268 (HappyAbsSyn77 happy_var_1) + = HappyAbsSyn119 + (sLL happy_var_1 happy_var_1 (unitOL happy_var_1) + ) +happyReduction_268 _ = notHappyAtAll + +happyReduce_269 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_269 = happyMonadReduce 3# 104# happyReduction_269 +happyReduction_269 ((HappyAbsSyn119 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn116 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( if isNilOL (snd $ unLoc happy_var_1) + then return (sLL happy_var_1 happy_var_3 (mj AnnSemi happy_var_2:(fst $ unLoc happy_var_1) + , unLoc happy_var_3)) + else ams (lastOL $ snd $ unLoc happy_var_1) [mj AnnSemi happy_var_2] + >> return + (sLL happy_var_1 happy_var_3 (fst $ unLoc happy_var_1 + ,(snd $ unLoc happy_var_1) `appOL` unLoc happy_var_3)))) + ) (\r -> happyReturn (HappyAbsSyn116 r)) + +happyReduce_270 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_270 = happyMonadReduce 2# 104# happyReduction_270 +happyReduction_270 ((HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn116 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( if isNilOL (snd $ unLoc happy_var_1) + then return (sLL happy_var_1 happy_var_2 (mj AnnSemi happy_var_2:(fst $ unLoc happy_var_1) + ,snd $ unLoc happy_var_1)) + else ams (lastOL $ snd $ unLoc happy_var_1) [mj AnnSemi happy_var_2] + >> return (sLL happy_var_1 happy_var_2 (unLoc happy_var_1)))) + ) (\r -> happyReturn (HappyAbsSyn116 r)) + +happyReduce_271 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_271 = happySpecReduce_1 104# happyReduction_271 +happyReduction_271 (HappyAbsSyn119 happy_var_1) + = HappyAbsSyn116 + (sL1 happy_var_1 ([],unLoc happy_var_1) + ) +happyReduction_271 _ = notHappyAtAll + +happyReduce_272 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_272 = happySpecReduce_0 104# happyReduction_272 +happyReduction_272 = HappyAbsSyn116 + (noLoc ([],nilOL) + ) + +happyReduce_273 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_273 = happySpecReduce_3 105# happyReduction_273 +happyReduction_273 (HappyTerminal happy_var_3) + (HappyAbsSyn116 happy_var_2) + (HappyTerminal happy_var_1) + = HappyAbsSyn117 + (sLL happy_var_1 happy_var_3 (moc happy_var_1:mcc happy_var_3:(fst $ unLoc happy_var_2),snd $ unLoc happy_var_2) + ) +happyReduction_273 _ _ _ = notHappyAtAll + +happyReduce_274 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_274 = happySpecReduce_3 105# happyReduction_274 +happyReduction_274 _ + (HappyAbsSyn116 happy_var_2) + _ + = HappyAbsSyn117 + (cL (gl happy_var_2) (unLoc happy_var_2) + ) +happyReduction_274 _ _ _ = notHappyAtAll + +happyReduce_275 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_275 = happySpecReduce_2 106# happyReduction_275 +happyReduction_275 (HappyAbsSyn117 happy_var_2) + (HappyTerminal happy_var_1) + = HappyAbsSyn122 + (sLL happy_var_1 happy_var_2 (mj AnnWhere happy_var_1:(fst $ unLoc happy_var_2) + ,(snd $ unLoc happy_var_2)) + ) +happyReduction_275 _ _ = notHappyAtAll + +happyReduce_276 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_276 = happySpecReduce_0 106# happyReduction_276 +happyReduction_276 = HappyAbsSyn122 + (noLoc ([],nilOL) + ) + +happyReduce_277 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_277 = happyMonadReduce 3# 107# happyReduction_277 +happyReduction_277 ((HappyAbsSyn77 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn116 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( if isNilOL (snd $ unLoc happy_var_1) + then return (sLL happy_var_1 happy_var_3 (mj AnnSemi happy_var_2:(fst $ unLoc happy_var_1) + , unitOL happy_var_3)) + else do ams (lastOL $ snd $ unLoc happy_var_1) [mj AnnSemi happy_var_2] + >> return ( + let { this = unitOL happy_var_3; + rest = snd $ unLoc happy_var_1; + these = rest `appOL` this } + in rest `seq` this `seq` these `seq` + (sLL happy_var_1 happy_var_3 (fst $ unLoc happy_var_1,these))))) + ) (\r -> happyReturn (HappyAbsSyn116 r)) + +happyReduce_278 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_278 = happyMonadReduce 2# 107# happyReduction_278 +happyReduction_278 ((HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn116 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( if isNilOL (snd $ unLoc happy_var_1) + then return (sLL happy_var_1 happy_var_2 ((mj AnnSemi happy_var_2:(fst $ unLoc happy_var_1) + ,snd $ unLoc happy_var_1))) + else ams (lastOL $ snd $ unLoc happy_var_1) [mj AnnSemi happy_var_2] + >> return (sLL happy_var_1 happy_var_2 (unLoc happy_var_1)))) + ) (\r -> happyReturn (HappyAbsSyn116 r)) + +happyReduce_279 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_279 = happySpecReduce_1 107# happyReduction_279 +happyReduction_279 (HappyAbsSyn77 happy_var_1) + = HappyAbsSyn116 + (sL1 happy_var_1 ([], unitOL happy_var_1) + ) +happyReduction_279 _ = notHappyAtAll + +happyReduce_280 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_280 = happySpecReduce_0 107# happyReduction_280 +happyReduction_280 = HappyAbsSyn116 + (noLoc ([],nilOL) + ) + +happyReduce_281 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_281 = happySpecReduce_3 108# happyReduction_281 +happyReduction_281 (HappyTerminal happy_var_3) + (HappyAbsSyn116 happy_var_2) + (HappyTerminal happy_var_1) + = HappyAbsSyn124 + (sLL happy_var_1 happy_var_3 (moc happy_var_1:mcc happy_var_3:(fst $ unLoc happy_var_2) + ,sL1 happy_var_2 $ snd $ unLoc happy_var_2) + ) +happyReduction_281 _ _ _ = notHappyAtAll + +happyReduce_282 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_282 = happySpecReduce_3 108# happyReduction_282 +happyReduction_282 _ + (HappyAbsSyn116 happy_var_2) + _ + = HappyAbsSyn124 + (cL (gl happy_var_2) (fst $ unLoc happy_var_2,sL1 happy_var_2 $ snd $ unLoc happy_var_2) + ) +happyReduction_282 _ _ _ = notHappyAtAll + +happyReduce_283 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_283 = happyMonadReduce 1# 109# happyReduction_283 +happyReduction_283 ((HappyAbsSyn124 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( do { val_binds <- cvBindGroup (unLoc $ snd $ unLoc happy_var_1) + ; return (sL1 happy_var_1 (fst $ unLoc happy_var_1 + ,sL1 happy_var_1 $ HsValBinds noExt val_binds)) })) + ) (\r -> happyReturn (HappyAbsSyn125 r)) + +happyReduce_284 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_284 = happySpecReduce_3 109# happyReduction_284 +happyReduction_284 (HappyTerminal happy_var_3) + (HappyAbsSyn260 happy_var_2) + (HappyTerminal happy_var_1) + = HappyAbsSyn125 + (sLL happy_var_1 happy_var_3 ([moc happy_var_1,mcc happy_var_3] + ,sL1 happy_var_2 $ HsIPBinds noExt (IPBinds noExt (reverse $ unLoc happy_var_2))) + ) +happyReduction_284 _ _ _ = notHappyAtAll + +happyReduce_285 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_285 = happySpecReduce_3 109# happyReduction_285 +happyReduction_285 _ + (HappyAbsSyn260 happy_var_2) + _ + = HappyAbsSyn125 + (cL (getLoc happy_var_2) ([] + ,sL1 happy_var_2 $ HsIPBinds noExt (IPBinds noExt (reverse $ unLoc happy_var_2))) + ) +happyReduction_285 _ _ _ = notHappyAtAll + +happyReduce_286 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_286 = happySpecReduce_2 110# happyReduction_286 +happyReduction_286 (HappyAbsSyn125 happy_var_2) + (HappyTerminal happy_var_1) + = HappyAbsSyn125 + (sLL happy_var_1 happy_var_2 (mj AnnWhere happy_var_1 : (fst $ unLoc happy_var_2) + ,snd $ unLoc happy_var_2) + ) +happyReduction_286 _ _ = notHappyAtAll + +happyReduce_287 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_287 = happySpecReduce_0 110# happyReduction_287 +happyReduction_287 = HappyAbsSyn125 + (noLoc ([],noLoc emptyLocalBinds) + ) + +happyReduce_288 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_288 = happyMonadReduce 3# 111# happyReduction_288 +happyReduction_288 ((HappyAbsSyn128 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn127 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( addAnnotation (oll happy_var_1) AnnSemi (gl happy_var_2) + >> return (happy_var_1 `snocOL` happy_var_3))) + ) (\r -> happyReturn (HappyAbsSyn127 r)) + +happyReduce_289 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_289 = happyMonadReduce 2# 111# happyReduction_289 +happyReduction_289 ((HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn127 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( addAnnotation (oll happy_var_1) AnnSemi (gl happy_var_2) + >> return happy_var_1)) + ) (\r -> happyReturn (HappyAbsSyn127 r)) + +happyReduce_290 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_290 = happySpecReduce_1 111# happyReduction_290 +happyReduction_290 (HappyAbsSyn128 happy_var_1) + = HappyAbsSyn127 + (unitOL happy_var_1 + ) +happyReduction_290 _ = notHappyAtAll + +happyReduce_291 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_291 = happySpecReduce_0 111# happyReduction_291 +happyReduction_291 = HappyAbsSyn127 + (nilOL + ) + +happyReduce_292 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_292 = happyMonadReduce 6# 112# happyReduction_292 +happyReduction_292 ((HappyAbsSyn207 happy_var_6) `HappyStk` + (HappyTerminal happy_var_5) `HappyStk` + (HappyAbsSyn207 happy_var_4) `HappyStk` + (HappyAbsSyn131 happy_var_3) `HappyStk` + (HappyAbsSyn129 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen (((runExpCmdP happy_var_4 >>= \ happy_var_4 -> + runExpCmdP happy_var_6 >>= \ happy_var_6 -> + ams (sLL happy_var_1 happy_var_6 $ HsRule { rd_ext = noExt + , rd_name = cL (gl happy_var_1) (getSTRINGs happy_var_1, getSTRING happy_var_1) + , rd_act = (snd happy_var_2) `orElse` AlwaysActive + , rd_tyvs = sndOf3 happy_var_3, rd_tmvs = thdOf3 happy_var_3 + , rd_lhs = happy_var_4, rd_rhs = happy_var_6 }) + (mj AnnEqual happy_var_5 : (fst happy_var_2) ++ (fstOf3 happy_var_3)))) + ) (\r -> happyReturn (HappyAbsSyn128 r)) + +happyReduce_293 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_293 = happySpecReduce_0 113# happyReduction_293 +happyReduction_293 = HappyAbsSyn129 + (([],Nothing) + ) + +happyReduce_294 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_294 = happySpecReduce_1 113# happyReduction_294 +happyReduction_294 (HappyAbsSyn130 happy_var_1) + = HappyAbsSyn129 + ((fst happy_var_1,Just (snd happy_var_1)) + ) +happyReduction_294 _ = notHappyAtAll + +happyReduce_295 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_295 = happySpecReduce_3 114# happyReduction_295 +happyReduction_295 (HappyTerminal happy_var_3) + (HappyTerminal happy_var_2) + (HappyTerminal happy_var_1) + = HappyAbsSyn130 + (([mos happy_var_1,mj AnnVal happy_var_2,mcs happy_var_3] + ,ActiveAfter (getINTEGERs happy_var_2) (fromInteger (il_value (getINTEGER happy_var_2)))) + ) +happyReduction_295 _ _ _ = notHappyAtAll + +happyReduce_296 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_296 = happyReduce 4# 114# happyReduction_296 +happyReduction_296 ((HappyTerminal happy_var_4) `HappyStk` + (HappyTerminal happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) + = HappyAbsSyn130 + (([mos happy_var_1,mj AnnTilde happy_var_2,mj AnnVal happy_var_3,mcs happy_var_4] + ,ActiveBefore (getINTEGERs happy_var_3) (fromInteger (il_value (getINTEGER happy_var_3)))) + ) `HappyStk` happyRest + +happyReduce_297 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_297 = happySpecReduce_3 114# happyReduction_297 +happyReduction_297 (HappyTerminal happy_var_3) + (HappyTerminal happy_var_2) + (HappyTerminal happy_var_1) + = HappyAbsSyn130 + (([mos happy_var_1,mj AnnTilde happy_var_2,mcs happy_var_3] + ,NeverActive) + ) +happyReduction_297 _ _ _ = notHappyAtAll + +happyReduce_298 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_298 = happyMonadReduce 6# 115# happyReduction_298 +happyReduction_298 ((HappyTerminal happy_var_6) `HappyStk` + (HappyAbsSyn132 happy_var_5) `HappyStk` + (HappyTerminal happy_var_4) `HappyStk` + (HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn132 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( let tyvs = mkRuleTyVarBndrs happy_var_2 + in hintExplicitForall happy_var_1 + >> checkRuleTyVarBndrNames (mkRuleTyVarBndrs happy_var_2) + >> return ([mu AnnForall happy_var_1,mj AnnDot happy_var_3, + mu AnnForall happy_var_4,mj AnnDot happy_var_6], + Just (mkRuleTyVarBndrs happy_var_2), mkRuleBndrs happy_var_5))) + ) (\r -> happyReturn (HappyAbsSyn131 r)) + +happyReduce_299 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_299 = happySpecReduce_3 115# happyReduction_299 +happyReduction_299 (HappyTerminal happy_var_3) + (HappyAbsSyn132 happy_var_2) + (HappyTerminal happy_var_1) + = HappyAbsSyn131 + (([mu AnnForall happy_var_1,mj AnnDot happy_var_3], + Nothing, mkRuleBndrs happy_var_2) + ) +happyReduction_299 _ _ _ = notHappyAtAll + +happyReduce_300 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_300 = happySpecReduce_0 115# happyReduction_300 +happyReduction_300 = HappyAbsSyn131 + (([], Nothing, []) + ) + +happyReduce_301 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_301 = happySpecReduce_2 116# happyReduction_301 +happyReduction_301 (HappyAbsSyn132 happy_var_2) + (HappyAbsSyn133 happy_var_1) + = HappyAbsSyn132 + (happy_var_1 : happy_var_2 + ) +happyReduction_301 _ _ = notHappyAtAll + +happyReduce_302 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_302 = happySpecReduce_0 116# happyReduction_302 +happyReduction_302 = HappyAbsSyn132 + ([] + ) + +happyReduce_303 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_303 = happySpecReduce_1 117# happyReduction_303 +happyReduction_303 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn133 + (sLL happy_var_1 happy_var_1 (RuleTyTmVar happy_var_1 Nothing) + ) +happyReduction_303 _ = notHappyAtAll + +happyReduce_304 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_304 = happyMonadReduce 5# 117# happyReduction_304 +happyReduction_304 ((HappyTerminal happy_var_5) `HappyStk` + (HappyAbsSyn147 happy_var_4) `HappyStk` + (HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn16 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_5 (RuleTyTmVar happy_var_2 (Just happy_var_4))) + [mop happy_var_1,mu AnnDcolon happy_var_3,mcp happy_var_5])) + ) (\r -> happyReturn (HappyAbsSyn133 r)) + +happyReduce_305 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_305 = happyMonadReduce 3# 118# happyReduction_305 +happyReduction_305 ((HappyAbsSyn134 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn134 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( addAnnotation (oll happy_var_1) AnnSemi (gl happy_var_2) + >> return (happy_var_1 `appOL` happy_var_3))) + ) (\r -> happyReturn (HappyAbsSyn134 r)) + +happyReduce_306 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_306 = happyMonadReduce 2# 118# happyReduction_306 +happyReduction_306 ((HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn134 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( addAnnotation (oll happy_var_1) AnnSemi (gl happy_var_2) + >> return happy_var_1)) + ) (\r -> happyReturn (HappyAbsSyn134 r)) + +happyReduce_307 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_307 = happySpecReduce_1 118# happyReduction_307 +happyReduction_307 (HappyAbsSyn134 happy_var_1) + = HappyAbsSyn134 + (happy_var_1 + ) +happyReduction_307 _ = notHappyAtAll + +happyReduce_308 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_308 = happySpecReduce_0 118# happyReduction_308 +happyReduction_308 = HappyAbsSyn134 + (nilOL + ) + +happyReduce_309 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_309 = happyMonadReduce 2# 119# happyReduction_309 +happyReduction_309 ((HappyAbsSyn138 happy_var_2) `HappyStk` + (HappyAbsSyn87 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( amsu (sLL happy_var_1 happy_var_2 (Warning noExt (unLoc happy_var_1) (WarningTxt (noLoc NoSourceText) $ snd $ unLoc happy_var_2))) + (fst $ unLoc happy_var_2))) + ) (\r -> happyReturn (HappyAbsSyn134 r)) + +happyReduce_310 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_310 = happyMonadReduce 3# 120# happyReduction_310 +happyReduction_310 ((HappyAbsSyn134 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn134 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( addAnnotation (oll happy_var_1) AnnSemi (gl happy_var_2) + >> return (happy_var_1 `appOL` happy_var_3))) + ) (\r -> happyReturn (HappyAbsSyn134 r)) + +happyReduce_311 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_311 = happyMonadReduce 2# 120# happyReduction_311 +happyReduction_311 ((HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn134 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( addAnnotation (oll happy_var_1) AnnSemi (gl happy_var_2) + >> return happy_var_1)) + ) (\r -> happyReturn (HappyAbsSyn134 r)) + +happyReduce_312 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_312 = happySpecReduce_1 120# happyReduction_312 +happyReduction_312 (HappyAbsSyn134 happy_var_1) + = HappyAbsSyn134 + (happy_var_1 + ) +happyReduction_312 _ = notHappyAtAll + +happyReduce_313 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_313 = happySpecReduce_0 120# happyReduction_313 +happyReduction_313 = HappyAbsSyn134 + (nilOL + ) + +happyReduce_314 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_314 = happyMonadReduce 2# 121# happyReduction_314 +happyReduction_314 ((HappyAbsSyn138 happy_var_2) `HappyStk` + (HappyAbsSyn87 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( amsu (sLL happy_var_1 happy_var_2 $ (Warning noExt (unLoc happy_var_1) (DeprecatedTxt (noLoc NoSourceText) $ snd $ unLoc happy_var_2))) + (fst $ unLoc happy_var_2))) + ) (\r -> happyReturn (HappyAbsSyn134 r)) + +happyReduce_315 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_315 = happySpecReduce_1 122# happyReduction_315 +happyReduction_315 (HappyTerminal happy_var_1) + = HappyAbsSyn138 + (sL1 happy_var_1 ([],[cL (gl happy_var_1) (getStringLiteral happy_var_1)]) + ) +happyReduction_315 _ = notHappyAtAll + +happyReduce_316 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_316 = happySpecReduce_3 122# happyReduction_316 +happyReduction_316 (HappyTerminal happy_var_3) + (HappyAbsSyn139 happy_var_2) + (HappyTerminal happy_var_1) + = HappyAbsSyn138 + (sLL happy_var_1 happy_var_3 $ ([mos happy_var_1,mcs happy_var_3],fromOL (unLoc happy_var_2)) + ) +happyReduction_316 _ _ _ = notHappyAtAll + +happyReduce_317 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_317 = happyMonadReduce 3# 123# happyReduction_317 +happyReduction_317 ((HappyTerminal happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn139 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( addAnnotation (oll $ unLoc happy_var_1) AnnComma (gl happy_var_2) >> + return (sLL happy_var_1 happy_var_3 (unLoc happy_var_1 `snocOL` + (cL (gl happy_var_3) (getStringLiteral happy_var_3)))))) + ) (\r -> happyReturn (HappyAbsSyn139 r)) + +happyReduce_318 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_318 = happySpecReduce_1 123# happyReduction_318 +happyReduction_318 (HappyTerminal happy_var_1) + = HappyAbsSyn139 + (sLL happy_var_1 happy_var_1 (unitOL (cL (gl happy_var_1) (getStringLiteral happy_var_1))) + ) +happyReduction_318 _ = notHappyAtAll + +happyReduce_319 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_319 = happySpecReduce_0 123# happyReduction_319 +happyReduction_319 = HappyAbsSyn139 + (noLoc nilOL + ) + +happyReduce_320 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_320 = happyMonadReduce 4# 124# happyReduction_320 +happyReduction_320 ((HappyTerminal happy_var_4) `HappyStk` + (HappyAbsSyn207 happy_var_3) `HappyStk` + (HappyAbsSyn16 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_3 >>= \ happy_var_3 -> + ams (sLL happy_var_1 happy_var_4 (AnnD noExt $ HsAnnotation noExt + (getANN_PRAGs happy_var_1) + (ValueAnnProvenance happy_var_2) happy_var_3)) + [mo happy_var_1,mc happy_var_4])) + ) (\r -> happyReturn (HappyAbsSyn77 r)) + +happyReduce_321 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_321 = happyMonadReduce 5# 124# happyReduction_321 +happyReduction_321 ((HappyTerminal happy_var_5) `HappyStk` + (HappyAbsSyn207 happy_var_4) `HappyStk` + (HappyAbsSyn16 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_4 >>= \ happy_var_4 -> + ams (sLL happy_var_1 happy_var_5 (AnnD noExt $ HsAnnotation noExt + (getANN_PRAGs happy_var_1) + (TypeAnnProvenance happy_var_3) happy_var_4)) + [mo happy_var_1,mj AnnType happy_var_2,mc happy_var_5])) + ) (\r -> happyReturn (HappyAbsSyn77 r)) + +happyReduce_322 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_322 = happyMonadReduce 4# 124# happyReduction_322 +happyReduction_322 ((HappyTerminal happy_var_4) `HappyStk` + (HappyAbsSyn207 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_3 >>= \ happy_var_3 -> + ams (sLL happy_var_1 happy_var_4 (AnnD noExt $ HsAnnotation noExt + (getANN_PRAGs happy_var_1) + ModuleAnnProvenance happy_var_3)) + [mo happy_var_1,mj AnnModule happy_var_2,mc happy_var_4])) + ) (\r -> happyReturn (HappyAbsSyn77 r)) + +happyReduce_323 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_323 = happyMonadReduce 4# 125# happyReduction_323 +happyReduction_323 ((HappyAbsSyn144 happy_var_4) `HappyStk` + (HappyAbsSyn143 happy_var_3) `HappyStk` + (HappyAbsSyn142 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( mkImport happy_var_2 happy_var_3 (snd $ unLoc happy_var_4) >>= \i -> + return (sLL happy_var_1 happy_var_4 (mj AnnImport happy_var_1 : (fst $ unLoc happy_var_4),i)))) + ) (\r -> happyReturn (HappyAbsSyn141 r)) + +happyReduce_324 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_324 = happyMonadReduce 3# 125# happyReduction_324 +happyReduction_324 ((HappyAbsSyn144 happy_var_3) `HappyStk` + (HappyAbsSyn142 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( do { d <- mkImport happy_var_2 (noLoc PlaySafe) (snd $ unLoc happy_var_3); + return (sLL happy_var_1 happy_var_3 (mj AnnImport happy_var_1 : (fst $ unLoc happy_var_3),d)) })) + ) (\r -> happyReturn (HappyAbsSyn141 r)) + +happyReduce_325 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_325 = happyMonadReduce 3# 125# happyReduction_325 +happyReduction_325 ((HappyAbsSyn144 happy_var_3) `HappyStk` + (HappyAbsSyn142 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( mkExport happy_var_2 (snd $ unLoc happy_var_3) >>= \i -> + return (sLL happy_var_1 happy_var_3 (mj AnnExport happy_var_1 : (fst $ unLoc happy_var_3),i) ))) + ) (\r -> happyReturn (HappyAbsSyn141 r)) + +happyReduce_326 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_326 = happySpecReduce_1 126# happyReduction_326 +happyReduction_326 (HappyTerminal happy_var_1) + = HappyAbsSyn142 + (sLL happy_var_1 happy_var_1 StdCallConv + ) +happyReduction_326 _ = notHappyAtAll + +happyReduce_327 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_327 = happySpecReduce_1 126# happyReduction_327 +happyReduction_327 (HappyTerminal happy_var_1) + = HappyAbsSyn142 + (sLL happy_var_1 happy_var_1 CCallConv + ) +happyReduction_327 _ = notHappyAtAll + +happyReduce_328 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_328 = happySpecReduce_1 126# happyReduction_328 +happyReduction_328 (HappyTerminal happy_var_1) + = HappyAbsSyn142 + (sLL happy_var_1 happy_var_1 CApiConv + ) +happyReduction_328 _ = notHappyAtAll + +happyReduce_329 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_329 = happySpecReduce_1 126# happyReduction_329 +happyReduction_329 (HappyTerminal happy_var_1) + = HappyAbsSyn142 + (sLL happy_var_1 happy_var_1 PrimCallConv + ) +happyReduction_329 _ = notHappyAtAll + +happyReduce_330 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_330 = happySpecReduce_1 126# happyReduction_330 +happyReduction_330 (HappyTerminal happy_var_1) + = HappyAbsSyn142 + (sLL happy_var_1 happy_var_1 JavaScriptCallConv + ) +happyReduction_330 _ = notHappyAtAll + +happyReduce_331 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_331 = happySpecReduce_1 127# happyReduction_331 +happyReduction_331 (HappyTerminal happy_var_1) + = HappyAbsSyn143 + (sLL happy_var_1 happy_var_1 PlayRisky + ) +happyReduction_331 _ = notHappyAtAll + +happyReduce_332 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_332 = happySpecReduce_1 127# happyReduction_332 +happyReduction_332 (HappyTerminal happy_var_1) + = HappyAbsSyn143 + (sLL happy_var_1 happy_var_1 PlaySafe + ) +happyReduction_332 _ = notHappyAtAll + +happyReduce_333 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_333 = happySpecReduce_1 127# happyReduction_333 +happyReduction_333 (HappyTerminal happy_var_1) + = HappyAbsSyn143 + (sLL happy_var_1 happy_var_1 PlayInterruptible + ) +happyReduction_333 _ = notHappyAtAll + +happyReduce_334 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_334 = happyReduce 4# 128# happyReduction_334 +happyReduction_334 ((HappyAbsSyn147 happy_var_4) `HappyStk` + (HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn16 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) + = HappyAbsSyn144 + (sLL happy_var_1 happy_var_4 ([mu AnnDcolon happy_var_3] + ,(cL (getLoc happy_var_1) + (getStringLiteral happy_var_1), happy_var_2, mkLHsSigType happy_var_4)) + ) `HappyStk` happyRest + +happyReduce_335 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_335 = happySpecReduce_3 128# happyReduction_335 +happyReduction_335 (HappyAbsSyn147 happy_var_3) + (HappyTerminal happy_var_2) + (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn144 + (sLL happy_var_1 happy_var_3 ([mu AnnDcolon happy_var_2] + ,(noLoc (StringLiteral NoSourceText nilFS), happy_var_1, mkLHsSigType happy_var_3)) + ) +happyReduction_335 _ _ _ = notHappyAtAll + +happyReduce_336 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_336 = happySpecReduce_0 129# happyReduction_336 +happyReduction_336 = HappyAbsSyn145 + (([],Nothing) + ) + +happyReduce_337 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_337 = happySpecReduce_2 129# happyReduction_337 +happyReduction_337 (HappyAbsSyn147 happy_var_2) + (HappyTerminal happy_var_1) + = HappyAbsSyn145 + (([mu AnnDcolon happy_var_1],Just happy_var_2) + ) +happyReduction_337 _ _ = notHappyAtAll + +happyReduce_338 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_338 = happySpecReduce_0 130# happyReduction_338 +happyReduction_338 = HappyAbsSyn146 + (([], Nothing) + ) + +happyReduce_339 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_339 = happySpecReduce_2 130# happyReduction_339 +happyReduction_339 (HappyAbsSyn16 happy_var_2) + (HappyTerminal happy_var_1) + = HappyAbsSyn146 + (([mu AnnDcolon happy_var_1], Just happy_var_2) + ) +happyReduction_339 _ _ = notHappyAtAll + +happyReduce_340 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_340 = happySpecReduce_1 131# happyReduction_340 +happyReduction_340 (HappyAbsSyn147 happy_var_1) + = HappyAbsSyn147 + (happy_var_1 + ) +happyReduction_340 _ = notHappyAtAll + +happyReduce_341 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_341 = happySpecReduce_1 132# happyReduction_341 +happyReduction_341 (HappyAbsSyn147 happy_var_1) + = HappyAbsSyn147 + (happy_var_1 + ) +happyReduction_341 _ = notHappyAtAll + +happyReduce_342 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_342 = happyMonadReduce 3# 133# happyReduction_342 +happyReduction_342 ((HappyAbsSyn16 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn87 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( addAnnotation (gl $ head $ unLoc happy_var_1) + AnnComma (gl happy_var_2) + >> return (sLL happy_var_1 happy_var_3 (happy_var_3 : unLoc happy_var_1)))) + ) (\r -> happyReturn (HappyAbsSyn87 r)) + +happyReduce_343 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_343 = happySpecReduce_1 133# happyReduction_343 +happyReduction_343 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn87 + (sL1 happy_var_1 [happy_var_1] + ) +happyReduction_343 _ = notHappyAtAll + +happyReduce_344 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_344 = happySpecReduce_1 134# happyReduction_344 +happyReduction_344 (HappyAbsSyn147 happy_var_1) + = HappyAbsSyn150 + (unitOL (mkLHsSigType happy_var_1) + ) +happyReduction_344 _ = notHappyAtAll + +happyReduce_345 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_345 = happyMonadReduce 3# 134# happyReduction_345 +happyReduction_345 ((HappyAbsSyn150 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn147 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( addAnnotation (gl happy_var_1) AnnComma (gl happy_var_2) + >> return (unitOL (mkLHsSigType happy_var_1) `appOL` happy_var_3))) + ) (\r -> happyReturn (HappyAbsSyn150 r)) + +happyReduce_346 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_346 = happySpecReduce_2 135# happyReduction_346 +happyReduction_346 (HappyTerminal happy_var_2) + (HappyTerminal happy_var_1) + = HappyAbsSyn151 + (sLL happy_var_1 happy_var_2 ([mo happy_var_1, mc happy_var_2], getUNPACK_PRAGs happy_var_1, SrcUnpack) + ) +happyReduction_346 _ _ = notHappyAtAll + +happyReduce_347 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_347 = happySpecReduce_2 135# happyReduction_347 +happyReduction_347 (HappyTerminal happy_var_2) + (HappyTerminal happy_var_1) + = HappyAbsSyn151 + (sLL happy_var_1 happy_var_2 ([mo happy_var_1, mc happy_var_2], getNOUNPACK_PRAGs happy_var_1, SrcNoUnpack) + ) +happyReduction_347 _ _ = notHappyAtAll + +happyReduce_348 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_348 = happySpecReduce_1 136# happyReduction_348 +happyReduction_348 (HappyTerminal happy_var_1) + = HappyAbsSyn152 + ((mj AnnDot happy_var_1, ForallInvis) + ) +happyReduction_348 _ = notHappyAtAll + +happyReduce_349 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_349 = happySpecReduce_1 136# happyReduction_349 +happyReduction_349 (HappyTerminal happy_var_1) + = HappyAbsSyn152 + ((mj AnnRarrow happy_var_1, ForallVis) + ) +happyReduction_349 _ = notHappyAtAll + +happyReduce_350 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_350 = happySpecReduce_1 137# happyReduction_350 +happyReduction_350 (HappyAbsSyn147 happy_var_1) + = HappyAbsSyn147 + (happy_var_1 + ) +happyReduction_350 _ = notHappyAtAll + +happyReduce_351 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_351 = happyMonadReduce 3# 137# happyReduction_351 +happyReduction_351 ((HappyAbsSyn179 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn147 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_3 $ HsKindSig noExt happy_var_1 happy_var_3) + [mu AnnDcolon happy_var_2])) + ) (\r -> happyReturn (HappyAbsSyn147 r)) + +happyReduce_352 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_352 = happySpecReduce_1 138# happyReduction_352 +happyReduction_352 (HappyAbsSyn147 happy_var_1) + = HappyAbsSyn147 + (happy_var_1 + ) +happyReduction_352 _ = notHappyAtAll + +happyReduce_353 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_353 = happyMonadReduce 3# 138# happyReduction_353 +happyReduction_353 ((HappyAbsSyn179 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn147 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_3 $ HsKindSig noExt happy_var_1 happy_var_3) + [mu AnnDcolon happy_var_2])) + ) (\r -> happyReturn (HappyAbsSyn147 r)) + +happyReduce_354 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_354 = happyMonadReduce 4# 139# happyReduction_354 +happyReduction_354 ((HappyAbsSyn147 happy_var_4) `HappyStk` + (HappyAbsSyn152 happy_var_3) `HappyStk` + (HappyAbsSyn173 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( let (fv_ann, fv_flag) = happy_var_3 in + hintExplicitForall happy_var_1 *> + ams (sLL happy_var_1 happy_var_4 $ + HsForAllTy { hst_fvf = fv_flag + , hst_bndrs = happy_var_2 + , hst_xforall = noExt + , hst_body = happy_var_4 }) + [mu AnnForall happy_var_1,fv_ann])) + ) (\r -> happyReturn (HappyAbsSyn147 r)) + +happyReduce_355 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_355 = happyMonadReduce 3# 139# happyReduction_355 +happyReduction_355 ((HappyAbsSyn147 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn157 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( addAnnotation (gl happy_var_1) (toUnicodeAnn AnnDarrow happy_var_2) (gl happy_var_2) + >> return (sLL happy_var_1 happy_var_3 $ + HsQualTy { hst_ctxt = happy_var_1 + , hst_xqual = noExt + , hst_body = happy_var_3 }))) + ) (\r -> happyReturn (HappyAbsSyn147 r)) + +happyReduce_356 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_356 = happyMonadReduce 3# 139# happyReduction_356 +happyReduction_356 ((HappyAbsSyn147 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn262 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_3 (HsIParamTy noExt happy_var_1 happy_var_3)) + [mu AnnDcolon happy_var_2])) + ) (\r -> happyReturn (HappyAbsSyn147 r)) + +happyReduce_357 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_357 = happySpecReduce_1 139# happyReduction_357 +happyReduction_357 (HappyAbsSyn147 happy_var_1) + = HappyAbsSyn147 + (happy_var_1 + ) +happyReduction_357 _ = notHappyAtAll + +happyReduce_358 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_358 = happyMonadReduce 4# 140# happyReduction_358 +happyReduction_358 ((HappyAbsSyn147 happy_var_4) `HappyStk` + (HappyAbsSyn152 happy_var_3) `HappyStk` + (HappyAbsSyn173 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( let (fv_ann, fv_flag) = happy_var_3 in + hintExplicitForall happy_var_1 *> + ams (sLL happy_var_1 happy_var_4 $ + HsForAllTy { hst_fvf = fv_flag + , hst_bndrs = happy_var_2 + , hst_xforall = noExt + , hst_body = happy_var_4 }) + [mu AnnForall happy_var_1,fv_ann])) + ) (\r -> happyReturn (HappyAbsSyn147 r)) + +happyReduce_359 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_359 = happyMonadReduce 3# 140# happyReduction_359 +happyReduction_359 ((HappyAbsSyn147 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn157 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( addAnnotation (gl happy_var_1) (toUnicodeAnn AnnDarrow happy_var_2) (gl happy_var_2) + >> return (sLL happy_var_1 happy_var_3 $ + HsQualTy { hst_ctxt = happy_var_1 + , hst_xqual = noExt + , hst_body = happy_var_3 }))) + ) (\r -> happyReturn (HappyAbsSyn147 r)) + +happyReduce_360 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_360 = happyMonadReduce 3# 140# happyReduction_360 +happyReduction_360 ((HappyAbsSyn147 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn262 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_3 (HsIParamTy noExt happy_var_1 happy_var_3)) + [mu AnnDcolon happy_var_2])) + ) (\r -> happyReturn (HappyAbsSyn147 r)) + +happyReduce_361 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_361 = happySpecReduce_1 140# happyReduction_361 +happyReduction_361 (HappyAbsSyn147 happy_var_1) + = HappyAbsSyn147 + (happy_var_1 + ) +happyReduction_361 _ = notHappyAtAll + +happyReduce_362 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_362 = happyMonadReduce 1# 141# happyReduction_362 +happyReduction_362 ((HappyAbsSyn147 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( do { (anns,ctx) <- checkContext happy_var_1 + ; if null (unLoc ctx) + then addAnnotation (gl happy_var_1) AnnUnit (gl happy_var_1) + else return () + ; ams ctx anns + })) + ) (\r -> happyReturn (HappyAbsSyn157 r)) + +happyReduce_363 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_363 = happyMonadReduce 1# 142# happyReduction_363 +happyReduction_363 ((HappyAbsSyn147 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( do { (anns,ctx) <- checkContext happy_var_1 + ; if null (unLoc ctx) + then addAnnotation (gl happy_var_1) AnnUnit (gl happy_var_1) + else return () + ; ams ctx anns + })) + ) (\r -> happyReturn (HappyAbsSyn157 r)) + +happyReduce_364 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_364 = happySpecReduce_1 143# happyReduction_364 +happyReduction_364 (HappyAbsSyn147 happy_var_1) + = HappyAbsSyn147 + (happy_var_1 + ) +happyReduction_364 _ = notHappyAtAll + +happyReduce_365 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_365 = happyMonadReduce 3# 143# happyReduction_365 +happyReduction_365 ((HappyAbsSyn147 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn147 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams happy_var_1 [mu AnnRarrow happy_var_2] -- See note [GADT decl discards annotations] + >> ams (sLL happy_var_1 happy_var_3 $ HsFunTy noExt happy_var_1 happy_var_3) + [mu AnnRarrow happy_var_2])) + ) (\r -> happyReturn (HappyAbsSyn147 r)) + +happyReduce_366 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_366 = happySpecReduce_1 144# happyReduction_366 +happyReduction_366 (HappyAbsSyn147 happy_var_1) + = HappyAbsSyn147 + (happy_var_1 + ) +happyReduction_366 _ = notHappyAtAll + +happyReduce_367 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_367 = happySpecReduce_2 144# happyReduction_367 +happyReduction_367 (HappyAbsSyn321 happy_var_2) + (HappyAbsSyn147 happy_var_1) + = HappyAbsSyn147 + (sLL happy_var_1 happy_var_2 $ HsDocTy noExt happy_var_1 happy_var_2 + ) +happyReduction_367 _ _ = notHappyAtAll + +happyReduce_368 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_368 = happySpecReduce_2 144# happyReduction_368 +happyReduction_368 (HappyAbsSyn147 happy_var_2) + (HappyAbsSyn321 happy_var_1) + = HappyAbsSyn147 + (sLL happy_var_1 happy_var_2 $ HsDocTy noExt happy_var_2 happy_var_1 + ) +happyReduction_368 _ _ = notHappyAtAll + +happyReduce_369 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_369 = happyMonadReduce 3# 144# happyReduction_369 +happyReduction_369 ((HappyAbsSyn147 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn147 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams happy_var_1 [mu AnnRarrow happy_var_2] -- See note [GADT decl discards annotations] + >> ams (sLL happy_var_1 happy_var_3 $ HsFunTy noExt happy_var_1 happy_var_3) + [mu AnnRarrow happy_var_2])) + ) (\r -> happyReturn (HappyAbsSyn147 r)) + +happyReduce_370 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_370 = happyMonadReduce 4# 144# happyReduction_370 +happyReduction_370 ((HappyAbsSyn147 happy_var_4) `HappyStk` + (HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn321 happy_var_2) `HappyStk` + (HappyAbsSyn147 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams happy_var_1 [mu AnnRarrow happy_var_3] -- See note [GADT decl discards annotations] + >> ams (sLL happy_var_1 happy_var_4 $ + HsFunTy noExt (cL (comb2 happy_var_1 happy_var_2) + (HsDocTy noExt happy_var_1 happy_var_2)) + happy_var_4) + [mu AnnRarrow happy_var_3])) + ) (\r -> happyReturn (HappyAbsSyn147 r)) + +happyReduce_371 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_371 = happyMonadReduce 4# 144# happyReduction_371 +happyReduction_371 ((HappyAbsSyn147 happy_var_4) `HappyStk` + (HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn147 happy_var_2) `HappyStk` + (HappyAbsSyn321 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams happy_var_2 [mu AnnRarrow happy_var_3] -- See note [GADT decl discards annotations] + >> ams (sLL happy_var_1 happy_var_4 $ + HsFunTy noExt (cL (comb2 happy_var_1 happy_var_2) + (HsDocTy noExt happy_var_2 happy_var_1)) + happy_var_4) + [mu AnnRarrow happy_var_3])) + ) (\r -> happyReturn (HappyAbsSyn147 r)) + +happyReduce_372 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_372 = happyMonadReduce 1# 145# happyReduction_372 +happyReduction_372 ((HappyAbsSyn162 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( mergeOps (unLoc happy_var_1))) + ) (\r -> happyReturn (HappyAbsSyn147 r)) + +happyReduce_373 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_373 = happySpecReduce_1 146# happyReduction_373 +happyReduction_373 (HappyAbsSyn163 happy_var_1) + = HappyAbsSyn162 + (sL1 happy_var_1 [happy_var_1] + ) +happyReduction_373 _ = notHappyAtAll + +happyReduce_374 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_374 = happySpecReduce_2 146# happyReduction_374 +happyReduction_374 (HappyAbsSyn163 happy_var_2) + (HappyAbsSyn162 happy_var_1) + = HappyAbsSyn162 + (sLL happy_var_1 happy_var_2 $ happy_var_2 : (unLoc happy_var_1) + ) +happyReduction_374 _ _ = notHappyAtAll + +happyReduce_375 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_375 = happySpecReduce_1 147# happyReduction_375 +happyReduction_375 (HappyAbsSyn163 happy_var_1) + = HappyAbsSyn163 + (happy_var_1 + ) +happyReduction_375 _ = notHappyAtAll + +happyReduce_376 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_376 = happySpecReduce_1 147# happyReduction_376 +happyReduction_376 (HappyAbsSyn321 happy_var_1) + = HappyAbsSyn163 + (sL1 happy_var_1 $ TyElDocPrev (unLoc happy_var_1) + ) +happyReduction_376 _ = notHappyAtAll + +happyReduce_377 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_377 = happyMonadReduce 1# 148# happyReduction_377 +happyReduction_377 ((HappyAbsSyn165 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( mergeOps happy_var_1)) + ) (\r -> happyReturn (HappyAbsSyn147 r)) + +happyReduce_378 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_378 = happySpecReduce_1 149# happyReduction_378 +happyReduction_378 (HappyAbsSyn163 happy_var_1) + = HappyAbsSyn165 + ([happy_var_1] + ) +happyReduction_378 _ = notHappyAtAll + +happyReduce_379 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_379 = happySpecReduce_2 149# happyReduction_379 +happyReduction_379 (HappyAbsSyn163 happy_var_2) + (HappyAbsSyn165 happy_var_1) + = HappyAbsSyn165 + (happy_var_2 : happy_var_1 + ) +happyReduction_379 _ _ = notHappyAtAll + +happyReduce_380 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_380 = happySpecReduce_1 150# happyReduction_380 +happyReduction_380 (HappyAbsSyn147 happy_var_1) + = HappyAbsSyn163 + (sL1 happy_var_1 $ TyElOpd (unLoc happy_var_1) + ) +happyReduction_380 _ = notHappyAtAll + +happyReduce_381 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_381 = happySpecReduce_2 150# happyReduction_381 +happyReduction_381 (HappyAbsSyn147 happy_var_2) + (HappyTerminal happy_var_1) + = HappyAbsSyn163 + (sLL happy_var_1 happy_var_2 $ (TyElKindApp (comb2 happy_var_1 happy_var_2) happy_var_2) + ) +happyReduction_381 _ _ = notHappyAtAll + +happyReduce_382 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_382 = happySpecReduce_1 150# happyReduction_382 +happyReduction_382 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn163 + (sL1 happy_var_1 $ if isBangRdr (unLoc happy_var_1) then TyElBang else + if isTildeRdr (unLoc happy_var_1) then TyElTilde else + TyElOpr (unLoc happy_var_1) + ) +happyReduction_382 _ = notHappyAtAll + +happyReduce_383 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_383 = happySpecReduce_1 150# happyReduction_383 +happyReduction_383 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn163 + (sL1 happy_var_1 $ TyElOpr (unLoc happy_var_1) + ) +happyReduction_383 _ = notHappyAtAll + +happyReduce_384 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_384 = happyMonadReduce 2# 150# happyReduction_384 +happyReduction_384 ((HappyAbsSyn16 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_2 $ TyElOpr (unLoc happy_var_2)) + [mj AnnSimpleQuote happy_var_1,mj AnnVal happy_var_2])) + ) (\r -> happyReturn (HappyAbsSyn163 r)) + +happyReduce_385 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_385 = happyMonadReduce 2# 150# happyReduction_385 +happyReduction_385 ((HappyAbsSyn16 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_2 $ TyElOpr (unLoc happy_var_2)) + [mj AnnSimpleQuote happy_var_1,mj AnnVal happy_var_2])) + ) (\r -> happyReturn (HappyAbsSyn163 r)) + +happyReduce_386 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_386 = happySpecReduce_1 150# happyReduction_386 +happyReduction_386 (HappyAbsSyn151 happy_var_1) + = HappyAbsSyn163 + (sL1 happy_var_1 $ TyElUnpackedness (unLoc happy_var_1) + ) +happyReduction_386 _ = notHappyAtAll + +happyReduce_387 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_387 = happySpecReduce_1 151# happyReduction_387 +happyReduction_387 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn147 + (sL1 happy_var_1 (HsTyVar noExt NotPromoted happy_var_1) + ) +happyReduction_387 _ = notHappyAtAll + +happyReduce_388 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_388 = happySpecReduce_1 151# happyReduction_388 +happyReduction_388 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn147 + (sL1 happy_var_1 (HsTyVar noExt NotPromoted happy_var_1) + ) +happyReduction_388 _ = notHappyAtAll + +happyReduce_389 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_389 = happyMonadReduce 1# 151# happyReduction_389 +happyReduction_389 ((HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( do { warnStarIsType (getLoc happy_var_1) + ; return $ sL1 happy_var_1 (HsStarTy noExt (isUnicode happy_var_1)) })) + ) (\r -> happyReturn (HappyAbsSyn147 r)) + +happyReduce_390 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_390 = happyMonadReduce 3# 151# happyReduction_390 +happyReduction_390 ((HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn189 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( amms (checkRecordSyntax + (sLL happy_var_1 happy_var_3 $ HsRecTy noExt happy_var_2)) + -- Constructor sigs only + [moc happy_var_1,mcc happy_var_3])) + ) (\r -> happyReturn (HappyAbsSyn147 r)) + +happyReduce_391 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_391 = happyMonadReduce 2# 151# happyReduction_391 +happyReduction_391 ((HappyTerminal happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_2 $ HsTupleTy noExt + HsBoxedOrConstraintTuple []) + [mop happy_var_1,mcp happy_var_2])) + ) (\r -> happyReturn (HappyAbsSyn147 r)) + +happyReduce_392 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_392 = happyMonadReduce 5# 151# happyReduction_392 +happyReduction_392 ((HappyTerminal happy_var_5) `HappyStk` + (HappyAbsSyn170 happy_var_4) `HappyStk` + (HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn147 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( addAnnotation (gl happy_var_2) AnnComma + (gl happy_var_3) >> + ams (sLL happy_var_1 happy_var_5 $ HsTupleTy noExt + + HsBoxedOrConstraintTuple (happy_var_2 : happy_var_4)) + [mop happy_var_1,mcp happy_var_5])) + ) (\r -> happyReturn (HappyAbsSyn147 r)) + +happyReduce_393 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_393 = happyMonadReduce 2# 151# happyReduction_393 +happyReduction_393 ((HappyTerminal happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_2 $ HsTupleTy noExt HsUnboxedTuple []) + [mo happy_var_1,mc happy_var_2])) + ) (\r -> happyReturn (HappyAbsSyn147 r)) + +happyReduce_394 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_394 = happyMonadReduce 3# 151# happyReduction_394 +happyReduction_394 ((HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn170 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_3 $ HsTupleTy noExt HsUnboxedTuple happy_var_2) + [mo happy_var_1,mc happy_var_3])) + ) (\r -> happyReturn (HappyAbsSyn147 r)) + +happyReduce_395 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_395 = happyMonadReduce 3# 151# happyReduction_395 +happyReduction_395 ((HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn170 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_3 $ HsSumTy noExt happy_var_2) + [mo happy_var_1,mc happy_var_3])) + ) (\r -> happyReturn (HappyAbsSyn147 r)) + +happyReduce_396 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_396 = happyMonadReduce 3# 151# happyReduction_396 +happyReduction_396 ((HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn147 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_3 $ HsListTy noExt happy_var_2) [mos happy_var_1,mcs happy_var_3])) + ) (\r -> happyReturn (HappyAbsSyn147 r)) + +happyReduce_397 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_397 = happyMonadReduce 3# 151# happyReduction_397 +happyReduction_397 ((HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn147 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_3 $ HsParTy noExt happy_var_2) [mop happy_var_1,mcp happy_var_3])) + ) (\r -> happyReturn (HappyAbsSyn147 r)) + +happyReduce_398 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_398 = happySpecReduce_1 151# happyReduction_398 +happyReduction_398 (HappyAbsSyn206 happy_var_1) + = HappyAbsSyn147 + (mapLoc (HsSpliceTy noExt) happy_var_1 + ) +happyReduction_398 _ = notHappyAtAll + +happyReduce_399 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_399 = happySpecReduce_1 151# happyReduction_399 +happyReduction_399 (HappyAbsSyn206 happy_var_1) + = HappyAbsSyn147 + (mapLoc (HsSpliceTy noExt) happy_var_1 + ) +happyReduction_399 _ = notHappyAtAll + +happyReduce_400 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_400 = happyMonadReduce 2# 151# happyReduction_400 +happyReduction_400 ((HappyAbsSyn16 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_2 $ HsTyVar noExt IsPromoted happy_var_2) [mj AnnSimpleQuote happy_var_1,mj AnnName happy_var_2])) + ) (\r -> happyReturn (HappyAbsSyn147 r)) + +happyReduce_401 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_401 = happyMonadReduce 6# 151# happyReduction_401 +happyReduction_401 ((HappyTerminal happy_var_6) `HappyStk` + (HappyAbsSyn170 happy_var_5) `HappyStk` + (HappyTerminal happy_var_4) `HappyStk` + (HappyAbsSyn147 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( addAnnotation (gl happy_var_3) AnnComma (gl happy_var_4) >> + ams (sLL happy_var_1 happy_var_6 $ HsExplicitTupleTy noExt (happy_var_3 : happy_var_5)) + [mj AnnSimpleQuote happy_var_1,mop happy_var_2,mcp happy_var_6])) + ) (\r -> happyReturn (HappyAbsSyn147 r)) + +happyReduce_402 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_402 = happyMonadReduce 4# 151# happyReduction_402 +happyReduction_402 ((HappyTerminal happy_var_4) `HappyStk` + (HappyAbsSyn170 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_4 $ HsExplicitListTy noExt IsPromoted happy_var_3) + [mj AnnSimpleQuote happy_var_1,mos happy_var_2,mcs happy_var_4])) + ) (\r -> happyReturn (HappyAbsSyn147 r)) + +happyReduce_403 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_403 = happyMonadReduce 2# 151# happyReduction_403 +happyReduction_403 ((HappyAbsSyn16 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_2 $ HsTyVar noExt IsPromoted happy_var_2) + [mj AnnSimpleQuote happy_var_1,mj AnnName happy_var_2])) + ) (\r -> happyReturn (HappyAbsSyn147 r)) + +happyReduce_404 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_404 = happyMonadReduce 5# 151# happyReduction_404 +happyReduction_404 ((HappyTerminal happy_var_5) `HappyStk` + (HappyAbsSyn170 happy_var_4) `HappyStk` + (HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn147 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( addAnnotation (gl happy_var_2) AnnComma + (gl happy_var_3) >> + ams (sLL happy_var_1 happy_var_5 $ HsExplicitListTy noExt NotPromoted (happy_var_2 : happy_var_4)) + [mos happy_var_1,mcs happy_var_5])) + ) (\r -> happyReturn (HappyAbsSyn147 r)) + +happyReduce_405 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_405 = happySpecReduce_1 151# happyReduction_405 +happyReduction_405 (HappyTerminal happy_var_1) + = HappyAbsSyn147 + (sLL happy_var_1 happy_var_1 $ HsTyLit noExt $ HsNumTy (getINTEGERs happy_var_1) + (il_value (getINTEGER happy_var_1)) + ) +happyReduction_405 _ = notHappyAtAll + +happyReduce_406 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_406 = happySpecReduce_1 151# happyReduction_406 +happyReduction_406 (HappyTerminal happy_var_1) + = HappyAbsSyn147 + (sLL happy_var_1 happy_var_1 $ HsTyLit noExt $ HsStrTy (getSTRINGs happy_var_1) + (getSTRING happy_var_1) + ) +happyReduction_406 _ = notHappyAtAll + +happyReduce_407 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_407 = happySpecReduce_1 151# happyReduction_407 +happyReduction_407 (HappyTerminal happy_var_1) + = HappyAbsSyn147 + (sL1 happy_var_1 $ mkAnonWildCardTy + ) +happyReduction_407 _ = notHappyAtAll + +happyReduce_408 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_408 = happySpecReduce_1 152# happyReduction_408 +happyReduction_408 (HappyAbsSyn147 happy_var_1) + = HappyAbsSyn168 + (mkLHsSigType happy_var_1 + ) +happyReduction_408 _ = notHappyAtAll + +happyReduce_409 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_409 = happySpecReduce_1 153# happyReduction_409 +happyReduction_409 (HappyAbsSyn147 happy_var_1) + = HappyAbsSyn169 + ([mkLHsSigType happy_var_1] + ) +happyReduction_409 _ = notHappyAtAll + +happyReduce_410 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_410 = happyMonadReduce 3# 153# happyReduction_410 +happyReduction_410 ((HappyAbsSyn169 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn147 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( addAnnotation (gl happy_var_1) AnnComma (gl happy_var_2) + >> return (mkLHsSigType happy_var_1 : happy_var_3))) + ) (\r -> happyReturn (HappyAbsSyn169 r)) + +happyReduce_411 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_411 = happySpecReduce_1 154# happyReduction_411 +happyReduction_411 (HappyAbsSyn170 happy_var_1) + = HappyAbsSyn170 + (happy_var_1 + ) +happyReduction_411 _ = notHappyAtAll + +happyReduce_412 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_412 = happySpecReduce_0 154# happyReduction_412 +happyReduction_412 = HappyAbsSyn170 + ([] + ) + +happyReduce_413 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_413 = happySpecReduce_1 155# happyReduction_413 +happyReduction_413 (HappyAbsSyn147 happy_var_1) + = HappyAbsSyn170 + ([happy_var_1] + ) +happyReduction_413 _ = notHappyAtAll + +happyReduce_414 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_414 = happyMonadReduce 3# 155# happyReduction_414 +happyReduction_414 ((HappyAbsSyn170 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn147 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( addAnnotation (gl happy_var_1) AnnComma (gl happy_var_2) + >> return (happy_var_1 : happy_var_3))) + ) (\r -> happyReturn (HappyAbsSyn170 r)) + +happyReduce_415 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_415 = happyMonadReduce 3# 156# happyReduction_415 +happyReduction_415 ((HappyAbsSyn147 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn147 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( addAnnotation (gl happy_var_1) AnnVbar (gl happy_var_2) + >> return [happy_var_1,happy_var_3])) + ) (\r -> happyReturn (HappyAbsSyn170 r)) + +happyReduce_416 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_416 = happyMonadReduce 3# 156# happyReduction_416 +happyReduction_416 ((HappyAbsSyn170 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn147 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( addAnnotation (gl happy_var_1) AnnVbar (gl happy_var_2) + >> return (happy_var_1 : happy_var_3))) + ) (\r -> happyReturn (HappyAbsSyn170 r)) + +happyReduce_417 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_417 = happySpecReduce_2 157# happyReduction_417 +happyReduction_417 (HappyAbsSyn173 happy_var_2) + (HappyAbsSyn174 happy_var_1) + = HappyAbsSyn173 + (happy_var_1 : happy_var_2 + ) +happyReduction_417 _ _ = notHappyAtAll + +happyReduce_418 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_418 = happySpecReduce_0 157# happyReduction_418 +happyReduction_418 = HappyAbsSyn173 + ([] + ) + +happyReduce_419 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_419 = happySpecReduce_1 158# happyReduction_419 +happyReduction_419 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn174 + (sL1 happy_var_1 (UserTyVar noExt happy_var_1) + ) +happyReduction_419 _ = notHappyAtAll + +happyReduce_420 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_420 = happyMonadReduce 5# 158# happyReduction_420 +happyReduction_420 ((HappyTerminal happy_var_5) `HappyStk` + (HappyAbsSyn179 happy_var_4) `HappyStk` + (HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn16 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_5 (KindedTyVar noExt happy_var_2 happy_var_4)) + [mop happy_var_1,mu AnnDcolon happy_var_3 + ,mcp happy_var_5])) + ) (\r -> happyReturn (HappyAbsSyn174 r)) + +happyReduce_421 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_421 = happySpecReduce_0 159# happyReduction_421 +happyReduction_421 = HappyAbsSyn175 + (noLoc ([],[]) + ) + +happyReduce_422 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_422 = happySpecReduce_2 159# happyReduction_422 +happyReduction_422 (HappyAbsSyn176 happy_var_2) + (HappyTerminal happy_var_1) + = HappyAbsSyn175 + ((sLL happy_var_1 happy_var_2 ([mj AnnVbar happy_var_1] + ,reverse (unLoc happy_var_2))) + ) +happyReduction_422 _ _ = notHappyAtAll + +happyReduce_423 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_423 = happyMonadReduce 3# 160# happyReduction_423 +happyReduction_423 ((HappyAbsSyn177 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn176 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( addAnnotation (gl $ head $ unLoc happy_var_1) AnnComma (gl happy_var_2) + >> return (sLL happy_var_1 happy_var_3 (happy_var_3 : unLoc happy_var_1)))) + ) (\r -> happyReturn (HappyAbsSyn176 r)) + +happyReduce_424 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_424 = happySpecReduce_1 160# happyReduction_424 +happyReduction_424 (HappyAbsSyn177 happy_var_1) + = HappyAbsSyn176 + (sL1 happy_var_1 [happy_var_1] + ) +happyReduction_424 _ = notHappyAtAll + +happyReduce_425 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_425 = happyMonadReduce 3# 161# happyReduction_425 +happyReduction_425 ((HappyAbsSyn87 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn87 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (cL (comb3 happy_var_1 happy_var_2 happy_var_3) + (reverse (unLoc happy_var_1), reverse (unLoc happy_var_3))) + [mu AnnRarrow happy_var_2])) + ) (\r -> happyReturn (HappyAbsSyn177 r)) + +happyReduce_426 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_426 = happySpecReduce_0 162# happyReduction_426 +happyReduction_426 = HappyAbsSyn87 + (noLoc [] + ) + +happyReduce_427 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_427 = happySpecReduce_2 162# happyReduction_427 +happyReduction_427 (HappyAbsSyn16 happy_var_2) + (HappyAbsSyn87 happy_var_1) + = HappyAbsSyn87 + (sLL happy_var_1 happy_var_2 (happy_var_2 : unLoc happy_var_1) + ) +happyReduction_427 _ _ = notHappyAtAll + +happyReduce_428 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_428 = happySpecReduce_1 163# happyReduction_428 +happyReduction_428 (HappyAbsSyn147 happy_var_1) + = HappyAbsSyn179 + (happy_var_1 + ) +happyReduction_428 _ = notHappyAtAll + +happyReduce_429 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_429 = happyMonadReduce 4# 164# happyReduction_429 +happyReduction_429 ((HappyTerminal happy_var_4) `HappyStk` + (HappyAbsSyn181 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( checkEmptyGADTs $ + cL (comb2 happy_var_1 happy_var_3) + ([mj AnnWhere happy_var_1 + ,moc happy_var_2 + ,mcc happy_var_4] + , unLoc happy_var_3))) + ) (\r -> happyReturn (HappyAbsSyn180 r)) + +happyReduce_430 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_430 = happyMonadReduce 4# 164# happyReduction_430 +happyReduction_430 (_ `HappyStk` + (HappyAbsSyn181 happy_var_3) `HappyStk` + _ `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( checkEmptyGADTs $ + cL (comb2 happy_var_1 happy_var_3) + ([mj AnnWhere happy_var_1] + , unLoc happy_var_3))) + ) (\r -> happyReturn (HappyAbsSyn180 r)) + +happyReduce_431 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_431 = happySpecReduce_0 164# happyReduction_431 +happyReduction_431 = HappyAbsSyn180 + (noLoc ([],[]) + ) + +happyReduce_432 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_432 = happyMonadReduce 3# 165# happyReduction_432 +happyReduction_432 ((HappyAbsSyn181 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn182 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( addAnnotation (gl happy_var_1) AnnSemi (gl happy_var_2) + >> return (cL (comb2 happy_var_1 happy_var_3) (happy_var_1 : unLoc happy_var_3)))) + ) (\r -> happyReturn (HappyAbsSyn181 r)) + +happyReduce_433 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_433 = happySpecReduce_1 165# happyReduction_433 +happyReduction_433 (HappyAbsSyn182 happy_var_1) + = HappyAbsSyn181 + (cL (gl happy_var_1) [happy_var_1] + ) +happyReduction_433 _ = notHappyAtAll + +happyReduce_434 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_434 = happySpecReduce_0 165# happyReduction_434 +happyReduction_434 = HappyAbsSyn181 + (noLoc [] + ) + +happyReduce_435 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_435 = happyMonadReduce 3# 166# happyReduction_435 +happyReduction_435 ((HappyAbsSyn182 happy_var_3) `HappyStk` + _ `HappyStk` + (HappyAbsSyn35 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( return $ addConDoc happy_var_3 happy_var_1)) + ) (\r -> happyReturn (HappyAbsSyn182 r)) + +happyReduce_436 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_436 = happyMonadReduce 1# 166# happyReduction_436 +happyReduction_436 ((HappyAbsSyn182 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( return happy_var_1)) + ) (\r -> happyReturn (HappyAbsSyn182 r)) + +happyReduce_437 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_437 = happyMonadReduce 3# 167# happyReduction_437 +happyReduction_437 ((HappyAbsSyn147 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn87 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( let (gadt,anns) = mkGadtDecl (unLoc happy_var_1) happy_var_3 + in ams (sLL happy_var_1 happy_var_3 gadt) + (mu AnnDcolon happy_var_2:anns))) + ) (\r -> happyReturn (HappyAbsSyn182 r)) + +happyReduce_438 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_438 = happySpecReduce_3 168# happyReduction_438 +happyReduction_438 (HappyAbsSyn181 happy_var_3) + (HappyTerminal happy_var_2) + (HappyAbsSyn35 happy_var_1) + = HappyAbsSyn184 + (cL (comb2 happy_var_2 happy_var_3) ([mj AnnEqual happy_var_2] + ,addConDocs (unLoc happy_var_3) happy_var_1) + ) +happyReduction_438 _ _ _ = notHappyAtAll + +happyReduce_439 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_439 = happyMonadReduce 5# 169# happyReduction_439 +happyReduction_439 ((HappyAbsSyn182 happy_var_5) `HappyStk` + (HappyAbsSyn35 happy_var_4) `HappyStk` + (HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn35 happy_var_2) `HappyStk` + (HappyAbsSyn181 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( addAnnotation (gl $ head $ unLoc happy_var_1) AnnVbar (gl happy_var_3) + >> return (sLL happy_var_1 happy_var_5 (addConDoc happy_var_5 happy_var_2 : addConDocFirst (unLoc happy_var_1) happy_var_4)))) + ) (\r -> happyReturn (HappyAbsSyn181 r)) + +happyReduce_440 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_440 = happySpecReduce_1 169# happyReduction_440 +happyReduction_440 (HappyAbsSyn182 happy_var_1) + = HappyAbsSyn181 + (sL1 happy_var_1 [happy_var_1] + ) +happyReduction_440 _ = notHappyAtAll + +happyReduce_441 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_441 = happyMonadReduce 5# 170# happyReduction_441 +happyReduction_441 ((HappyAbsSyn188 happy_var_5) `HappyStk` + (HappyTerminal happy_var_4) `HappyStk` + (HappyAbsSyn157 happy_var_3) `HappyStk` + (HappyAbsSyn187 happy_var_2) `HappyStk` + (HappyAbsSyn35 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (let (con,details,doc_prev) = unLoc happy_var_5 in + addConDoc (cL (comb4 happy_var_2 happy_var_3 happy_var_4 happy_var_5) (mkConDeclH98 con + (snd $ unLoc happy_var_2) + (Just happy_var_3) + details)) + (happy_var_1 `mplus` doc_prev)) + (mu AnnDarrow happy_var_4:(fst $ unLoc happy_var_2)))) + ) (\r -> happyReturn (HappyAbsSyn182 r)) + +happyReduce_442 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_442 = happyMonadReduce 3# 170# happyReduction_442 +happyReduction_442 ((HappyAbsSyn188 happy_var_3) `HappyStk` + (HappyAbsSyn187 happy_var_2) `HappyStk` + (HappyAbsSyn35 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams ( let (con,details,doc_prev) = unLoc happy_var_3 in + addConDoc (cL (comb2 happy_var_2 happy_var_3) (mkConDeclH98 con + (snd $ unLoc happy_var_2) + Nothing -- No context + details)) + (happy_var_1 `mplus` doc_prev)) + (fst $ unLoc happy_var_2))) + ) (\r -> happyReturn (HappyAbsSyn182 r)) + +happyReduce_443 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_443 = happySpecReduce_3 171# happyReduction_443 +happyReduction_443 (HappyTerminal happy_var_3) + (HappyAbsSyn173 happy_var_2) + (HappyTerminal happy_var_1) + = HappyAbsSyn187 + (sLL happy_var_1 happy_var_3 ([mu AnnForall happy_var_1,mj AnnDot happy_var_3], Just happy_var_2) + ) +happyReduction_443 _ _ _ = notHappyAtAll + +happyReduce_444 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_444 = happySpecReduce_0 171# happyReduction_444 +happyReduction_444 = HappyAbsSyn187 + (noLoc ([], Nothing) + ) + +happyReduce_445 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_445 = happyMonadReduce 1# 172# happyReduction_445 +happyReduction_445 ((HappyAbsSyn162 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( do { c <- mergeDataCon (unLoc happy_var_1) + ; return $ sL1 happy_var_1 c })) + ) (\r -> happyReturn (HappyAbsSyn188 r)) + +happyReduce_446 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_446 = happySpecReduce_0 173# happyReduction_446 +happyReduction_446 = HappyAbsSyn189 + ([] + ) + +happyReduce_447 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_447 = happySpecReduce_1 173# happyReduction_447 +happyReduction_447 (HappyAbsSyn189 happy_var_1) + = HappyAbsSyn189 + (happy_var_1 + ) +happyReduction_447 _ = notHappyAtAll + +happyReduce_448 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_448 = happyMonadReduce 5# 174# happyReduction_448 +happyReduction_448 ((HappyAbsSyn189 happy_var_5) `HappyStk` + (HappyAbsSyn35 happy_var_4) `HappyStk` + (HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn35 happy_var_2) `HappyStk` + (HappyAbsSyn191 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( addAnnotation (gl happy_var_1) AnnComma (gl happy_var_3) >> + return ((addFieldDoc happy_var_1 happy_var_4) : addFieldDocs happy_var_5 happy_var_2))) + ) (\r -> happyReturn (HappyAbsSyn189 r)) + +happyReduce_449 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_449 = happySpecReduce_1 174# happyReduction_449 +happyReduction_449 (HappyAbsSyn191 happy_var_1) + = HappyAbsSyn189 + ([happy_var_1] + ) +happyReduction_449 _ = notHappyAtAll + +happyReduce_450 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_450 = happyMonadReduce 5# 175# happyReduction_450 +happyReduction_450 ((HappyAbsSyn35 happy_var_5) `HappyStk` + (HappyAbsSyn147 happy_var_4) `HappyStk` + (HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn87 happy_var_2) `HappyStk` + (HappyAbsSyn35 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (cL (comb2 happy_var_2 happy_var_4) + (ConDeclField noExt (reverse (map (\ln@(dL->L l n) -> cL l $ FieldOcc noExt ln) (unLoc happy_var_2))) happy_var_4 (happy_var_1 `mplus` happy_var_5))) + [mu AnnDcolon happy_var_3])) + ) (\r -> happyReturn (HappyAbsSyn191 r)) + +happyReduce_451 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_451 = happySpecReduce_0 176# happyReduction_451 +happyReduction_451 = HappyAbsSyn192 + (noLoc [] + ) + +happyReduce_452 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_452 = happySpecReduce_1 176# happyReduction_452 +happyReduction_452 (HappyAbsSyn192 happy_var_1) + = HappyAbsSyn192 + (happy_var_1 + ) +happyReduction_452 _ = notHappyAtAll + +happyReduce_453 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_453 = happySpecReduce_2 177# happyReduction_453 +happyReduction_453 (HappyAbsSyn194 happy_var_2) + (HappyAbsSyn192 happy_var_1) + = HappyAbsSyn192 + (sLL happy_var_1 happy_var_2 $ happy_var_2 : unLoc happy_var_1 + ) +happyReduction_453 _ _ = notHappyAtAll + +happyReduce_454 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_454 = happySpecReduce_1 177# happyReduction_454 +happyReduction_454 (HappyAbsSyn194 happy_var_1) + = HappyAbsSyn192 + (sLL happy_var_1 happy_var_1 [happy_var_1] + ) +happyReduction_454 _ = notHappyAtAll + +happyReduce_455 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_455 = happyMonadReduce 2# 178# happyReduction_455 +happyReduction_455 ((HappyAbsSyn195 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( let { full_loc = comb2 happy_var_1 happy_var_2 } + in ams (cL full_loc $ HsDerivingClause noExt Nothing happy_var_2) + [mj AnnDeriving happy_var_1])) + ) (\r -> happyReturn (HappyAbsSyn194 r)) + +happyReduce_456 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_456 = happyMonadReduce 3# 178# happyReduction_456 +happyReduction_456 ((HappyAbsSyn195 happy_var_3) `HappyStk` + (HappyAbsSyn82 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( let { full_loc = comb2 happy_var_1 happy_var_3 } + in ams (cL full_loc $ HsDerivingClause noExt (Just happy_var_2) happy_var_3) + [mj AnnDeriving happy_var_1])) + ) (\r -> happyReturn (HappyAbsSyn194 r)) + +happyReduce_457 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_457 = happyMonadReduce 3# 178# happyReduction_457 +happyReduction_457 ((HappyAbsSyn82 happy_var_3) `HappyStk` + (HappyAbsSyn195 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( let { full_loc = comb2 happy_var_1 happy_var_3 } + in ams (cL full_loc $ HsDerivingClause noExt (Just happy_var_3) happy_var_2) + [mj AnnDeriving happy_var_1])) + ) (\r -> happyReturn (HappyAbsSyn194 r)) + +happyReduce_458 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_458 = happySpecReduce_1 179# happyReduction_458 +happyReduction_458 (HappyAbsSyn147 happy_var_1) + = HappyAbsSyn195 + (sL1 happy_var_1 [mkLHsSigType happy_var_1] + ) +happyReduction_458 _ = notHappyAtAll + +happyReduce_459 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_459 = happyMonadReduce 2# 179# happyReduction_459 +happyReduction_459 ((HappyTerminal happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_2 []) + [mop happy_var_1,mcp happy_var_2])) + ) (\r -> happyReturn (HappyAbsSyn195 r)) + +happyReduce_460 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_460 = happyMonadReduce 3# 179# happyReduction_460 +happyReduction_460 ((HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn169 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_3 happy_var_2) + [mop happy_var_1,mcp happy_var_3])) + ) (\r -> happyReturn (HappyAbsSyn195 r)) + +happyReduce_461 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_461 = happySpecReduce_1 180# happyReduction_461 +happyReduction_461 (HappyAbsSyn197 happy_var_1) + = HappyAbsSyn77 + (sL1 happy_var_1 (DocD noExt (unLoc happy_var_1)) + ) +happyReduction_461 _ = notHappyAtAll + +happyReduce_462 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_462 = happySpecReduce_1 181# happyReduction_462 +happyReduction_462 (HappyAbsSyn321 happy_var_1) + = HappyAbsSyn197 + (sL1 happy_var_1 (DocCommentNext (unLoc happy_var_1)) + ) +happyReduction_462 _ = notHappyAtAll + +happyReduce_463 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_463 = happySpecReduce_1 181# happyReduction_463 +happyReduction_463 (HappyAbsSyn321 happy_var_1) + = HappyAbsSyn197 + (sL1 happy_var_1 (DocCommentPrev (unLoc happy_var_1)) + ) +happyReduction_463 _ = notHappyAtAll + +happyReduce_464 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_464 = happySpecReduce_1 181# happyReduction_464 +happyReduction_464 (HappyAbsSyn323 happy_var_1) + = HappyAbsSyn197 + (sL1 happy_var_1 (case (unLoc happy_var_1) of (n, doc) -> DocCommentNamed n doc) + ) +happyReduction_464 _ = notHappyAtAll + +happyReduce_465 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_465 = happySpecReduce_1 181# happyReduction_465 +happyReduction_465 (HappyAbsSyn324 happy_var_1) + = HappyAbsSyn197 + (sL1 happy_var_1 (case (unLoc happy_var_1) of (n, doc) -> DocGroup n doc) + ) +happyReduction_465 _ = notHappyAtAll + +happyReduce_466 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_466 = happySpecReduce_1 182# happyReduction_466 +happyReduction_466 (HappyAbsSyn77 happy_var_1) + = HappyAbsSyn77 + (happy_var_1 + ) +happyReduction_466 _ = notHappyAtAll + +happyReduce_467 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_467 = happyMonadReduce 3# 182# happyReduction_467 +happyReduction_467 ((HappyAbsSyn200 happy_var_3) `HappyStk` + (HappyAbsSyn207 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_2 >>= \ happy_var_2 -> + do { let { e = sLL happy_var_1 happy_var_2 (SectionR noExt (sL1 happy_var_1 (HsVar noExt (sL1 happy_var_1 bang_RDR))) happy_var_2) + ; l = comb2 happy_var_1 happy_var_3 }; + (ann, r) <- checkValDef empty SrcStrict e Nothing happy_var_3 ; + hintBangPat (comb2 happy_var_1 happy_var_2) (unLoc e) ; + -- Depending upon what the pattern looks like we might get either + -- a FunBind or PatBind back from checkValDef. See Note + -- [FunBind vs PatBind] + case r of { + (FunBind _ n _ _ _) -> + amsL l [mj AnnFunId n] >> return () ; + (PatBind _ (dL->L l _) _rhs _) -> + amsL l [] >> return () } ; + + _ <- amsL l (ann ++ fst (unLoc happy_var_3) ++ [mj AnnBang happy_var_1]) ; + return $! (sL l $ ValD noExt r) })) + ) (\r -> happyReturn (HappyAbsSyn77 r)) + +happyReduce_468 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_468 = happyMonadReduce 3# 182# happyReduction_468 +happyReduction_468 ((HappyAbsSyn200 happy_var_3) `HappyStk` + (HappyAbsSyn145 happy_var_2) `HappyStk` + (HappyAbsSyn209 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( do { (ann,r) <- checkValDef empty NoSrcStrict happy_var_1 (snd happy_var_2) happy_var_3; + let { l = comb2 happy_var_1 happy_var_3 }; + -- Depending upon what the pattern looks like we might get either + -- a FunBind or PatBind back from checkValDef. See Note + -- [FunBind vs PatBind] + case r of { + (FunBind _ n _ _ _) -> + amsL l (mj AnnFunId n:(fst happy_var_2)) >> return () ; + (PatBind _ (dL->L lh _lhs) _rhs _) -> + amsL lh (fst happy_var_2) >> return () } ; + _ <- amsL l (ann ++ (fst $ unLoc happy_var_3)); + return $! (sL l $ ValD noExt r) })) + ) (\r -> happyReturn (HappyAbsSyn77 r)) + +happyReduce_469 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_469 = happySpecReduce_1 182# happyReduction_469 +happyReduction_469 (HappyAbsSyn77 happy_var_1) + = HappyAbsSyn77 + (happy_var_1 + ) +happyReduction_469 _ = notHappyAtAll + +happyReduce_470 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_470 = happySpecReduce_1 182# happyReduction_470 +happyReduction_470 (HappyAbsSyn77 happy_var_1) + = HappyAbsSyn77 + (happy_var_1 + ) +happyReduction_470 _ = notHappyAtAll + +happyReduce_471 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_471 = happySpecReduce_1 183# happyReduction_471 +happyReduction_471 (HappyAbsSyn77 happy_var_1) + = HappyAbsSyn77 + (happy_var_1 + ) +happyReduction_471 _ = notHappyAtAll + +happyReduce_472 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_472 = happySpecReduce_1 183# happyReduction_472 +happyReduction_472 (HappyAbsSyn209 happy_var_1) + = HappyAbsSyn77 + (sLL happy_var_1 happy_var_1 $ mkSpliceDecl happy_var_1 + ) +happyReduction_472 _ = notHappyAtAll + +happyReduce_473 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_473 = happyMonadReduce 3# 184# happyReduction_473 +happyReduction_473 ((HappyAbsSyn125 happy_var_3) `HappyStk` + (HappyAbsSyn207 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_2 >>= \ happy_var_2 -> return $ + sL (comb3 happy_var_1 happy_var_2 happy_var_3) + ((mj AnnEqual happy_var_1 : (fst $ unLoc happy_var_3)) + ,GRHSs noExt (unguardedRHS (comb3 happy_var_1 happy_var_2 happy_var_3) happy_var_2) + (snd $ unLoc happy_var_3)))) + ) (\r -> happyReturn (HappyAbsSyn200 r)) + +happyReduce_474 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_474 = happySpecReduce_2 184# happyReduction_474 +happyReduction_474 (HappyAbsSyn125 happy_var_2) + (HappyAbsSyn201 happy_var_1) + = HappyAbsSyn200 + (sLL happy_var_1 happy_var_2 (fst $ unLoc happy_var_2 + ,GRHSs noExt (reverse (unLoc happy_var_1)) + (snd $ unLoc happy_var_2)) + ) +happyReduction_474 _ _ = notHappyAtAll + +happyReduce_475 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_475 = happySpecReduce_2 185# happyReduction_475 +happyReduction_475 (HappyAbsSyn202 happy_var_2) + (HappyAbsSyn201 happy_var_1) + = HappyAbsSyn201 + (sLL happy_var_1 happy_var_2 (happy_var_2 : unLoc happy_var_1) + ) +happyReduction_475 _ _ = notHappyAtAll + +happyReduce_476 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_476 = happySpecReduce_1 185# happyReduction_476 +happyReduction_476 (HappyAbsSyn202 happy_var_1) + = HappyAbsSyn201 + (sL1 happy_var_1 [happy_var_1] + ) +happyReduction_476 _ = notHappyAtAll + +happyReduce_477 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_477 = happyMonadReduce 4# 186# happyReduction_477 +happyReduction_477 ((HappyAbsSyn207 happy_var_4) `HappyStk` + (HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn232 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_4 >>= \ happy_var_4 -> + ams (sL (comb2 happy_var_1 happy_var_4) $ GRHS noExt (unLoc happy_var_2) happy_var_4) + [mj AnnVbar happy_var_1,mj AnnEqual happy_var_3])) + ) (\r -> happyReturn (HappyAbsSyn202 r)) + +happyReduce_478 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_478 = happyMonadReduce 3# 187# happyReduction_478 +happyReduction_478 ((HappyAbsSyn147 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn209 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( do { v <- checkValSigLhs happy_var_1 + ; _ <- amsL (comb2 happy_var_1 happy_var_3) [mu AnnDcolon happy_var_2] + ; return (sLL happy_var_1 happy_var_3 $ SigD noExt $ + TypeSig noExt [v] (mkLHsSigWcType happy_var_3))})) + ) (\r -> happyReturn (HappyAbsSyn77 r)) + +happyReduce_479 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_479 = happyMonadReduce 5# 187# happyReduction_479 +happyReduction_479 ((HappyAbsSyn147 happy_var_5) `HappyStk` + (HappyTerminal happy_var_4) `HappyStk` + (HappyAbsSyn87 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn16 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( do { let sig = TypeSig noExt (happy_var_1 : reverse (unLoc happy_var_3)) + (mkLHsSigWcType happy_var_5) + ; addAnnotation (gl happy_var_1) AnnComma (gl happy_var_2) + ; ams ( sLL happy_var_1 happy_var_5 $ SigD noExt sig ) + [mu AnnDcolon happy_var_4] })) + ) (\r -> happyReturn (HappyAbsSyn77 r)) + +happyReduce_480 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_480 = happyMonadReduce 3# 187# happyReduction_480 +happyReduction_480 ((HappyAbsSyn74 happy_var_3) `HappyStk` + (HappyAbsSyn72 happy_var_2) `HappyStk` + (HappyAbsSyn73 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( checkPrecP happy_var_2 happy_var_3 >> + ams (sLL happy_var_1 happy_var_3 $ SigD noExt + (FixSig noExt (FixitySig noExt (fromOL $ unLoc happy_var_3) + (Fixity (fst $ unLoc happy_var_2) (snd $ unLoc happy_var_2) (unLoc happy_var_1))))) + [mj AnnInfix happy_var_1,mj AnnVal happy_var_2])) + ) (\r -> happyReturn (HappyAbsSyn77 r)) + +happyReduce_481 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_481 = happySpecReduce_1 187# happyReduction_481 +happyReduction_481 (HappyAbsSyn114 happy_var_1) + = HappyAbsSyn77 + (sLL happy_var_1 happy_var_1 . SigD noExt . unLoc $ happy_var_1 + ) +happyReduction_481 _ = notHappyAtAll + +happyReduce_482 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_482 = happyMonadReduce 4# 187# happyReduction_482 +happyReduction_482 ((HappyTerminal happy_var_4) `HappyStk` + (HappyAbsSyn146 happy_var_3) `HappyStk` + (HappyAbsSyn87 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( let (dcolon, tc) = happy_var_3 + in ams + (sLL happy_var_1 happy_var_4 + (SigD noExt (CompleteMatchSig noExt (getCOMPLETE_PRAGs happy_var_1) happy_var_2 tc))) + ([ mo happy_var_1 ] ++ dcolon ++ [mc happy_var_4]))) + ) (\r -> happyReturn (HappyAbsSyn77 r)) + +happyReduce_483 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_483 = happyMonadReduce 4# 187# happyReduction_483 +happyReduction_483 ((HappyTerminal happy_var_4) `HappyStk` + (HappyAbsSyn16 happy_var_3) `HappyStk` + (HappyAbsSyn129 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams ((sLL happy_var_1 happy_var_4 $ SigD noExt (InlineSig noExt happy_var_3 + (mkInlinePragma (getINLINE_PRAGs happy_var_1) (getINLINE happy_var_1) + (snd happy_var_2))))) + ((mo happy_var_1:fst happy_var_2) ++ [mc happy_var_4]))) + ) (\r -> happyReturn (HappyAbsSyn77 r)) + +happyReduce_484 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_484 = happyMonadReduce 3# 187# happyReduction_484 +happyReduction_484 ((HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn16 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_3 (SigD noExt (SCCFunSig noExt (getSCC_PRAGs happy_var_1) happy_var_2 Nothing))) + [mo happy_var_1, mc happy_var_3])) + ) (\r -> happyReturn (HappyAbsSyn77 r)) + +happyReduce_485 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_485 = happyMonadReduce 4# 187# happyReduction_485 +happyReduction_485 ((HappyTerminal happy_var_4) `HappyStk` + (HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn16 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( do { scc <- getSCC happy_var_3 + ; let str_lit = StringLiteral (getSTRINGs happy_var_3) scc + ; ams (sLL happy_var_1 happy_var_4 (SigD noExt (SCCFunSig noExt (getSCC_PRAGs happy_var_1) happy_var_2 (Just ( sL1 happy_var_3 str_lit))))) + [mo happy_var_1, mc happy_var_4] })) + ) (\r -> happyReturn (HappyAbsSyn77 r)) + +happyReduce_486 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_486 = happyMonadReduce 6# 187# happyReduction_486 +happyReduction_486 ((HappyTerminal happy_var_6) `HappyStk` + (HappyAbsSyn150 happy_var_5) `HappyStk` + (HappyTerminal happy_var_4) `HappyStk` + (HappyAbsSyn16 happy_var_3) `HappyStk` + (HappyAbsSyn129 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams ( + let inl_prag = mkInlinePragma (getSPEC_PRAGs happy_var_1) + (NoUserInline, FunLike) (snd happy_var_2) + in sLL happy_var_1 happy_var_6 $ SigD noExt (SpecSig noExt happy_var_3 (fromOL happy_var_5) inl_prag)) + (mo happy_var_1:mu AnnDcolon happy_var_4:mc happy_var_6:(fst happy_var_2)))) + ) (\r -> happyReturn (HappyAbsSyn77 r)) + +happyReduce_487 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_487 = happyMonadReduce 6# 187# happyReduction_487 +happyReduction_487 ((HappyTerminal happy_var_6) `HappyStk` + (HappyAbsSyn150 happy_var_5) `HappyStk` + (HappyTerminal happy_var_4) `HappyStk` + (HappyAbsSyn16 happy_var_3) `HappyStk` + (HappyAbsSyn129 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_6 $ SigD noExt (SpecSig noExt happy_var_3 (fromOL happy_var_5) + (mkInlinePragma (getSPEC_INLINE_PRAGs happy_var_1) + (getSPEC_INLINE happy_var_1) (snd happy_var_2)))) + (mo happy_var_1:mu AnnDcolon happy_var_4:mc happy_var_6:(fst happy_var_2)))) + ) (\r -> happyReturn (HappyAbsSyn77 r)) + +happyReduce_488 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_488 = happyMonadReduce 4# 187# happyReduction_488 +happyReduction_488 ((HappyTerminal happy_var_4) `HappyStk` + (HappyAbsSyn168 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_4 + $ SigD noExt (SpecInstSig noExt (getSPEC_PRAGs happy_var_1) happy_var_3)) + [mo happy_var_1,mj AnnInstance happy_var_2,mc happy_var_4])) + ) (\r -> happyReturn (HappyAbsSyn77 r)) + +happyReduce_489 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_489 = happyMonadReduce 3# 187# happyReduction_489 +happyReduction_489 ((HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn264 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_3 $ SigD noExt (MinimalSig noExt (getMINIMAL_PRAGs happy_var_1) happy_var_2)) + [mo happy_var_1,mc happy_var_3])) + ) (\r -> happyReturn (HappyAbsSyn77 r)) + +happyReduce_490 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_490 = happySpecReduce_0 188# happyReduction_490 +happyReduction_490 = HappyAbsSyn129 + (([],Nothing) + ) + +happyReduce_491 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_491 = happySpecReduce_1 188# happyReduction_491 +happyReduction_491 (HappyAbsSyn205 happy_var_1) + = HappyAbsSyn129 + ((fst happy_var_1,Just (snd happy_var_1)) + ) +happyReduction_491 _ = notHappyAtAll + +happyReduce_492 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_492 = happySpecReduce_3 189# happyReduction_492 +happyReduction_492 (HappyTerminal happy_var_3) + (HappyTerminal happy_var_2) + (HappyTerminal happy_var_1) + = HappyAbsSyn205 + (([mj AnnOpenS happy_var_1,mj AnnVal happy_var_2,mj AnnCloseS happy_var_3] + ,ActiveAfter (getINTEGERs happy_var_2) (fromInteger (il_value (getINTEGER happy_var_2)))) + ) +happyReduction_492 _ _ _ = notHappyAtAll + +happyReduce_493 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_493 = happyReduce 4# 189# happyReduction_493 +happyReduction_493 ((HappyTerminal happy_var_4) `HappyStk` + (HappyTerminal happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) + = HappyAbsSyn205 + (([mj AnnOpenS happy_var_1,mj AnnTilde happy_var_2,mj AnnVal happy_var_3 + ,mj AnnCloseS happy_var_4] + ,ActiveBefore (getINTEGERs happy_var_3) (fromInteger (il_value (getINTEGER happy_var_3)))) + ) `HappyStk` happyRest + +happyReduce_494 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_494 = happySpecReduce_1 190# happyReduction_494 +happyReduction_494 (HappyTerminal happy_var_1) + = HappyAbsSyn206 + (let { loc = getLoc happy_var_1 + ; ITquasiQuote (quoter, quote, quoteSpan) = unLoc happy_var_1 + ; quoterId = mkUnqual varName quoter } + in sL1 happy_var_1 (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) + ) +happyReduction_494 _ = notHappyAtAll + +happyReduce_495 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_495 = happySpecReduce_1 190# happyReduction_495 +happyReduction_495 (HappyTerminal happy_var_1) + = HappyAbsSyn206 + (let { loc = getLoc happy_var_1 + ; ITqQuasiQuote (qual, quoter, quote, quoteSpan) = unLoc happy_var_1 + ; quoterId = mkQual varName (qual, quoter) } + in sL (getLoc happy_var_1) (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) + ) +happyReduction_495 _ = notHappyAtAll + +happyReduce_496 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_496 = happyMonadReduce 3# 191# happyReduction_496 +happyReduction_496 ((HappyAbsSyn147 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn207 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_1 >>= \ happy_var_1 -> + fmap ecFromExp $ + ams (sLL happy_var_1 happy_var_3 $ ExprWithTySig noExt happy_var_1 (mkLHsSigWcType happy_var_3)) + [mu AnnDcolon happy_var_2])) + ) (\r -> happyReturn (HappyAbsSyn207 r)) + +happyReduce_497 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_497 = happyMonadReduce 3# 191# happyReduction_497 +happyReduction_497 ((HappyAbsSyn207 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn207 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_1 >>= \ happy_var_1 -> + runExpCmdP happy_var_3 >>= \ happy_var_3 -> + fmap ecFromCmd $ + ams (sLL happy_var_1 happy_var_3 $ HsCmdArrApp noExt happy_var_1 happy_var_3 + HsFirstOrderApp True) + [mu Annlarrowtail happy_var_2])) + ) (\r -> happyReturn (HappyAbsSyn207 r)) + +happyReduce_498 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_498 = happyMonadReduce 3# 191# happyReduction_498 +happyReduction_498 ((HappyAbsSyn207 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn207 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_1 >>= \ happy_var_1 -> + runExpCmdP happy_var_3 >>= \ happy_var_3 -> + fmap ecFromCmd $ + ams (sLL happy_var_1 happy_var_3 $ HsCmdArrApp noExt happy_var_3 happy_var_1 + HsFirstOrderApp False) + [mu Annrarrowtail happy_var_2])) + ) (\r -> happyReturn (HappyAbsSyn207 r)) + +happyReduce_499 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_499 = happyMonadReduce 3# 191# happyReduction_499 +happyReduction_499 ((HappyAbsSyn207 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn207 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_1 >>= \ happy_var_1 -> + runExpCmdP happy_var_3 >>= \ happy_var_3 -> + fmap ecFromCmd $ + ams (sLL happy_var_1 happy_var_3 $ HsCmdArrApp noExt happy_var_1 happy_var_3 + HsHigherOrderApp True) + [mu AnnLarrowtail happy_var_2])) + ) (\r -> happyReturn (HappyAbsSyn207 r)) + +happyReduce_500 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_500 = happyMonadReduce 3# 191# happyReduction_500 +happyReduction_500 ((HappyAbsSyn207 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn207 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_1 >>= \ happy_var_1 -> + runExpCmdP happy_var_3 >>= \ happy_var_3 -> + fmap ecFromCmd $ + ams (sLL happy_var_1 happy_var_3 $ HsCmdArrApp noExt happy_var_3 happy_var_1 + HsHigherOrderApp False) + [mu AnnRarrowtail happy_var_2])) + ) (\r -> happyReturn (HappyAbsSyn207 r)) + +happyReduce_501 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_501 = happySpecReduce_1 191# happyReduction_501 +happyReduction_501 (HappyAbsSyn207 happy_var_1) + = HappyAbsSyn207 + (happy_var_1 + ) +happyReduction_501 _ = notHappyAtAll + +happyReduce_502 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_502 = happySpecReduce_1 192# happyReduction_502 +happyReduction_502 (HappyAbsSyn207 happy_var_1) + = HappyAbsSyn207 + (happy_var_1 + ) +happyReduction_502 _ = notHappyAtAll + +happyReduce_503 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_503 = happySpecReduce_3 192# happyReduction_503 +happyReduction_503 (HappyAbsSyn207 happy_var_3) + (HappyAbsSyn209 happy_var_2) + (HappyAbsSyn207 happy_var_1) + = HappyAbsSyn207 + (ExpCmdP $ + runExpCmdP happy_var_1 >>= \ happy_var_1 -> + runExpCmdP happy_var_3 >>= \ happy_var_3 -> + ams (sLL happy_var_1 happy_var_3 (ecOpApp happy_var_1 happy_var_2 happy_var_3)) + [mj AnnVal happy_var_2] + ) +happyReduction_503 _ _ _ = notHappyAtAll + +happyReduce_504 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_504 = happyMonadReduce 1# 193# happyReduction_504 +happyReduction_504 ((HappyAbsSyn207 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_1)) + ) (\r -> happyReturn (HappyAbsSyn209 r)) + +happyReduce_505 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_505 = happyMonadReduce 3# 193# happyReduction_505 +happyReduction_505 ((HappyAbsSyn207 happy_var_3) `HappyStk` + (HappyAbsSyn209 happy_var_2) `HappyStk` + (HappyAbsSyn209 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_3 >>= \ happy_var_3 -> + do { when (srcSpanEnd (getLoc happy_var_2) + == srcSpanStart (getLoc happy_var_3) + && checkIfBang happy_var_2) $ + warnSpaceAfterBang (comb2 happy_var_2 happy_var_3); + ams (sLL happy_var_1 happy_var_3 (OpApp noExt happy_var_1 happy_var_2 happy_var_3)) + [mj AnnVal happy_var_2] + })) + ) (\r -> happyReturn (HappyAbsSyn209 r)) + +happyReduce_506 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_506 = happyMonadReduce 2# 194# happyReduction_506 +happyReduction_506 ((HappyAbsSyn207 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_2 >>= \ happy_var_2 -> + fmap ecFromExp $ + ams (sLL happy_var_1 happy_var_2 $ NegApp noExt happy_var_2 noSyntaxExpr) + [mj AnnMinus happy_var_1])) + ) (\r -> happyReturn (HappyAbsSyn207 r)) + +happyReduce_507 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_507 = happyMonadReduce 2# 194# happyReduction_507 +happyReduction_507 ((HappyAbsSyn207 happy_var_2) `HappyStk` + (HappyAbsSyn214 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_2 >>= \ happy_var_2 -> + fmap ecFromExp $ + ams (sLL happy_var_1 happy_var_2 $ HsTickPragma noExt (snd $ fst $ fst $ unLoc happy_var_1) + (snd $ fst $ unLoc happy_var_1) (snd $ unLoc happy_var_1) happy_var_2) + (fst $ fst $ fst $ unLoc happy_var_1))) + ) (\r -> happyReturn (HappyAbsSyn207 r)) + +happyReduce_508 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_508 = happyMonadReduce 4# 194# happyReduction_508 +happyReduction_508 ((HappyAbsSyn207 happy_var_4) `HappyStk` + (HappyTerminal happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_4 >>= \ happy_var_4 -> + fmap ecFromExp $ + ams (sLL happy_var_1 happy_var_4 $ HsCoreAnn noExt (getCORE_PRAGs happy_var_1) (getStringLiteral happy_var_2) happy_var_4) + [mo happy_var_1,mj AnnVal happy_var_2 + ,mc happy_var_3])) + ) (\r -> happyReturn (HappyAbsSyn207 r)) + +happyReduce_509 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_509 = happySpecReduce_1 194# happyReduction_509 +happyReduction_509 (HappyAbsSyn207 happy_var_1) + = HappyAbsSyn207 + (happy_var_1 + ) +happyReduction_509 _ = notHappyAtAll + +happyReduce_510 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_510 = happySpecReduce_1 195# happyReduction_510 +happyReduction_510 (HappyAbsSyn207 happy_var_1) + = HappyAbsSyn207 + (happy_var_1 + ) +happyReduction_510 _ = notHappyAtAll + +happyReduce_511 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_511 = happyMonadReduce 2# 195# happyReduction_511 +happyReduction_511 ((HappyAbsSyn207 happy_var_2) `HappyStk` + (HappyAbsSyn213 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_2 >>= \ happy_var_2 -> + fmap ecFromExp $ + ams (sLL happy_var_1 happy_var_2 $ HsSCC noExt (snd $ fst $ unLoc happy_var_1) (snd $ unLoc happy_var_1) happy_var_2) + (fst $ fst $ unLoc happy_var_1))) + ) (\r -> happyReturn (HappyAbsSyn207 r)) + +happyReduce_512 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_512 = happySpecReduce_1 196# happyReduction_512 +happyReduction_512 (HappyTerminal happy_var_1) + = HappyAbsSyn212 + (([happy_var_1],True) + ) +happyReduction_512 _ = notHappyAtAll + +happyReduce_513 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_513 = happySpecReduce_0 196# happyReduction_513 +happyReduction_513 = HappyAbsSyn212 + (([],False) + ) + +happyReduce_514 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_514 = happyMonadReduce 3# 197# happyReduction_514 +happyReduction_514 ((HappyTerminal happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( do scc <- getSCC happy_var_2 + ; return $ sLL happy_var_1 happy_var_3 + (([mo happy_var_1,mj AnnValStr happy_var_2 + ,mc happy_var_3],getSCC_PRAGs happy_var_1),(StringLiteral (getSTRINGs happy_var_2) scc)))) + ) (\r -> happyReturn (HappyAbsSyn213 r)) + +happyReduce_515 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_515 = happySpecReduce_3 197# happyReduction_515 +happyReduction_515 (HappyTerminal happy_var_3) + (HappyTerminal happy_var_2) + (HappyTerminal happy_var_1) + = HappyAbsSyn213 + (sLL happy_var_1 happy_var_3 (([mo happy_var_1,mj AnnVal happy_var_2 + ,mc happy_var_3],getSCC_PRAGs happy_var_1) + ,(StringLiteral NoSourceText (getVARID happy_var_2))) + ) +happyReduction_515 _ _ _ = notHappyAtAll + +happyReduce_516 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_516 = happyReduce 10# 198# happyReduction_516 +happyReduction_516 ((HappyTerminal happy_var_10) `HappyStk` + (HappyTerminal happy_var_9) `HappyStk` + (HappyTerminal happy_var_8) `HappyStk` + (HappyTerminal happy_var_7) `HappyStk` + (HappyTerminal happy_var_6) `HappyStk` + (HappyTerminal happy_var_5) `HappyStk` + (HappyTerminal happy_var_4) `HappyStk` + (HappyTerminal happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) + = HappyAbsSyn214 + (sLL happy_var_1 happy_var_10 $ ((([mo happy_var_1,mj AnnVal happy_var_2 + ,mj AnnVal happy_var_3,mj AnnColon happy_var_4 + ,mj AnnVal happy_var_5,mj AnnMinus happy_var_6 + ,mj AnnVal happy_var_7,mj AnnColon happy_var_8 + ,mj AnnVal happy_var_9,mc happy_var_10], + getGENERATED_PRAGs happy_var_1) + ,((getStringLiteral happy_var_2) + ,( fromInteger $ il_value $ getINTEGER happy_var_3 + , fromInteger $ il_value $ getINTEGER happy_var_5 + ) + ,( fromInteger $ il_value $ getINTEGER happy_var_7 + , fromInteger $ il_value $ getINTEGER happy_var_9 + ) + )) + , (( getINTEGERs happy_var_3 + , getINTEGERs happy_var_5 + ) + ,( getINTEGERs happy_var_7 + , getINTEGERs happy_var_9 + ))) + ) `HappyStk` happyRest + +happyReduce_517 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_517 = happyMonadReduce 2# 199# happyReduction_517 +happyReduction_517 ((HappyAbsSyn207 happy_var_2) `HappyStk` + (HappyAbsSyn207 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_2 >>= \ happy_var_2 -> + checkBlockArguments happy_var_2 >>= \_ -> + return $ ExpCmdP $ + runExpCmdP happy_var_1 >>= \ happy_var_1 -> + checkBlockArguments happy_var_1 >>= \_ -> + return (sLL happy_var_1 happy_var_2 (ecHsApp happy_var_1 happy_var_2)))) + ) (\r -> happyReturn (HappyAbsSyn207 r)) + +happyReduce_518 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_518 = happyMonadReduce 3# 199# happyReduction_518 +happyReduction_518 ((HappyAbsSyn147 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn207 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_1 >>= \ happy_var_1 -> + checkBlockArguments happy_var_1 >>= \_ -> + fmap ecFromExp $ + ams (sLL happy_var_1 happy_var_3 $ HsAppType noExt happy_var_1 (mkHsWildCardBndrs happy_var_3)) + [mj AnnAt happy_var_2])) + ) (\r -> happyReturn (HappyAbsSyn207 r)) + +happyReduce_519 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_519 = happyMonadReduce 2# 199# happyReduction_519 +happyReduction_519 ((HappyAbsSyn207 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_2 >>= \ happy_var_2 -> + fmap ecFromExp $ + ams (sLL happy_var_1 happy_var_2 $ HsStatic noExt happy_var_2) + [mj AnnStatic happy_var_1])) + ) (\r -> happyReturn (HappyAbsSyn207 r)) + +happyReduce_520 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_520 = happySpecReduce_1 199# happyReduction_520 +happyReduction_520 (HappyAbsSyn207 happy_var_1) + = HappyAbsSyn207 + (happy_var_1 + ) +happyReduction_520 _ = notHappyAtAll + +happyReduce_521 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_521 = happyMonadReduce 3# 200# happyReduction_521 +happyReduction_521 ((HappyAbsSyn207 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn16 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_3 >>= \ happy_var_3 -> + fmap ecFromExp $ + ams (sLL happy_var_1 happy_var_3 $ EAsPat noExt happy_var_1 happy_var_3) [mj AnnAt happy_var_2])) + ) (\r -> happyReturn (HappyAbsSyn207 r)) + +happyReduce_522 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_522 = happyMonadReduce 2# 200# happyReduction_522 +happyReduction_522 ((HappyAbsSyn207 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_2 >>= \ happy_var_2 -> + fmap ecFromExp $ + ams (sLL happy_var_1 happy_var_2 $ ELazyPat noExt happy_var_2) [mj AnnTilde happy_var_1])) + ) (\r -> happyReturn (HappyAbsSyn207 r)) + +happyReduce_523 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_523 = happyReduce 5# 200# happyReduction_523 +happyReduction_523 ((HappyAbsSyn207 happy_var_5) `HappyStk` + (HappyTerminal happy_var_4) `HappyStk` + (HappyAbsSyn250 happy_var_3) `HappyStk` + (HappyAbsSyn247 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) + = HappyAbsSyn207 + (ExpCmdP $ + runExpCmdP happy_var_5 >>= \ happy_var_5 -> + ams (sLL happy_var_1 happy_var_5 $ ecHsLam (mkMatchGroup FromSource + [sLL happy_var_1 happy_var_5 $ Match { m_ext = noExt + , m_ctxt = LambdaExpr + , m_pats = happy_var_2:happy_var_3 + , m_grhss = unguardedGRHSs happy_var_5 }])) + [mj AnnLam happy_var_1, mu AnnRarrow happy_var_4] + ) `HappyStk` happyRest + +happyReduce_524 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_524 = happyReduce 4# 200# happyReduction_524 +happyReduction_524 ((HappyAbsSyn207 happy_var_4) `HappyStk` + (HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn125 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) + = HappyAbsSyn207 + (ExpCmdP $ + runExpCmdP happy_var_4 >>= \ happy_var_4 -> + ams (sLL happy_var_1 happy_var_4 $ ecHsLet (snd (unLoc happy_var_2)) happy_var_4) + (mj AnnLet happy_var_1:mj AnnIn happy_var_3 + :(fst $ unLoc happy_var_2)) + ) `HappyStk` happyRest + +happyReduce_525 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_525 = happyMonadReduce 3# 200# happyReduction_525 +happyReduction_525 ((HappyAbsSyn238 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( happy_var_3 >>= \ happy_var_3 -> + fmap ecFromExp $ + ams (sLL happy_var_1 happy_var_3 $ HsLamCase noExt + (mkMatchGroup FromSource (snd $ unLoc happy_var_3))) + (mj AnnLam happy_var_1:mj AnnCase happy_var_2:(fst $ unLoc happy_var_3)))) + ) (\r -> happyReturn (HappyAbsSyn207 r)) + +happyReduce_526 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_526 = happyMonadReduce 8# 200# happyReduction_526 +happyReduction_526 ((HappyAbsSyn207 happy_var_8) `HappyStk` + (HappyTerminal happy_var_7) `HappyStk` + (HappyAbsSyn212 happy_var_6) `HappyStk` + (HappyAbsSyn207 happy_var_5) `HappyStk` + (HappyTerminal happy_var_4) `HappyStk` + (HappyAbsSyn212 happy_var_3) `HappyStk` + (HappyAbsSyn207 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_2 >>= \ happy_var_2 -> + return $ ExpCmdP $ + runExpCmdP happy_var_5 >>= \ happy_var_5 -> + runExpCmdP happy_var_8 >>= \ happy_var_8 -> + checkDoAndIfThenElse happy_var_2 (snd happy_var_3) happy_var_5 (snd happy_var_6) happy_var_8 >> + ams (sLL happy_var_1 happy_var_8 $ ecHsIf happy_var_2 happy_var_5 happy_var_8) + (mj AnnIf happy_var_1:mj AnnThen happy_var_4 + :mj AnnElse happy_var_7 + :(map (\l -> mj AnnSemi l) (fst happy_var_3)) + ++(map (\l -> mj AnnSemi l) (fst happy_var_6))))) + ) (\r -> happyReturn (HappyAbsSyn207 r)) + +happyReduce_527 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_527 = happyMonadReduce 2# 200# happyReduction_527 +happyReduction_527 ((HappyAbsSyn245 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( hintMultiWayIf (getLoc happy_var_1) >>= \_ -> + fmap ecFromExp $ + ams (sLL happy_var_1 happy_var_2 $ HsMultiIf noExt + (reverse $ snd $ unLoc happy_var_2)) + (mj AnnIf happy_var_1:(fst $ unLoc happy_var_2)))) + ) (\r -> happyReturn (HappyAbsSyn207 r)) + +happyReduce_528 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_528 = happyMonadReduce 4# 200# happyReduction_528 +happyReduction_528 ((HappyAbsSyn238 happy_var_4) `HappyStk` + (HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn207 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_2 >>= \ happy_var_2 -> + return $ ExpCmdP $ + happy_var_4 >>= \ happy_var_4 -> + ams (cL (comb3 happy_var_1 happy_var_3 happy_var_4) $ + ecHsCase happy_var_2 (mkMatchGroup + FromSource (snd $ unLoc happy_var_4))) + (mj AnnCase happy_var_1:mj AnnOf happy_var_3 + :(fst $ unLoc happy_var_4)))) + ) (\r -> happyReturn (HappyAbsSyn207 r)) + +happyReduce_529 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_529 = happySpecReduce_2 200# happyReduction_529 +happyReduction_529 (HappyAbsSyn251 happy_var_2) + (HappyTerminal happy_var_1) + = HappyAbsSyn207 + (ExpCmdP $ + happy_var_2 >>= \ happy_var_2 -> + ams (cL (comb2 happy_var_1 happy_var_2) + (ecHsDo (mapLoc snd happy_var_2))) + (mj AnnDo happy_var_1:(fst $ unLoc happy_var_2)) + ) +happyReduction_529 _ _ = notHappyAtAll + +happyReduce_530 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_530 = happyMonadReduce 2# 200# happyReduction_530 +happyReduction_530 ((HappyAbsSyn251 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( happy_var_2 >>= \ happy_var_2 -> + fmap ecFromExp $ + ams (cL (comb2 happy_var_1 happy_var_2) + (mkHsDo MDoExpr (snd $ unLoc happy_var_2))) + (mj AnnMdo happy_var_1:(fst $ unLoc happy_var_2)))) + ) (\r -> happyReturn (HappyAbsSyn207 r)) + +happyReduce_531 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_531 = happyMonadReduce 4# 200# happyReduction_531 +happyReduction_531 ((HappyAbsSyn207 happy_var_4) `HappyStk` + (HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn207 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( (checkPattern empty <=< runExpCmdP) happy_var_2 >>= \ p -> + runExpCmdP happy_var_4 >>= \ happy_var_4@cmd -> + fmap ecFromExp $ + ams (sLL happy_var_1 happy_var_4 $ HsProc noExt p (sLL happy_var_1 happy_var_4 $ HsCmdTop noExt cmd)) + -- TODO: is LL right here? + [mj AnnProc happy_var_1,mu AnnRarrow happy_var_3])) + ) (\r -> happyReturn (HappyAbsSyn207 r)) + +happyReduce_532 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_532 = happySpecReduce_1 200# happyReduction_532 +happyReduction_532 (HappyAbsSyn207 happy_var_1) + = HappyAbsSyn207 + (happy_var_1 + ) +happyReduction_532 _ = notHappyAtAll + +happyReduce_533 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_533 = happyMonadReduce 4# 201# happyReduction_533 +happyReduction_533 ((HappyTerminal happy_var_4) `HappyStk` + (HappyAbsSyn257 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn207 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_1 >>= \ happy_var_1 -> + do { r <- mkRecConstrOrUpdate happy_var_1 (comb2 happy_var_2 happy_var_4) + (snd happy_var_3) + ; _ <- amsL (comb2 happy_var_1 happy_var_4) (moc happy_var_2:mcc happy_var_4:(fst happy_var_3)) + ; fmap ecFromExp $ + checkRecordSyntax (sLL happy_var_1 happy_var_4 r) })) + ) (\r -> happyReturn (HappyAbsSyn207 r)) + +happyReduce_534 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_534 = happySpecReduce_1 201# happyReduction_534 +happyReduction_534 (HappyAbsSyn207 happy_var_1) + = HappyAbsSyn207 + (happy_var_1 + ) +happyReduction_534 _ = notHappyAtAll + +happyReduce_535 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_535 = happySpecReduce_1 202# happyReduction_535 +happyReduction_535 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn207 + (ecFromExp $ sL1 happy_var_1 (HsVar noExt $! happy_var_1) + ) +happyReduction_535 _ = notHappyAtAll + +happyReduce_536 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_536 = happySpecReduce_1 202# happyReduction_536 +happyReduction_536 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn207 + (ecFromExp $ sL1 happy_var_1 (HsVar noExt $! happy_var_1) + ) +happyReduction_536 _ = notHappyAtAll + +happyReduce_537 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_537 = happySpecReduce_1 202# happyReduction_537 +happyReduction_537 (HappyAbsSyn262 happy_var_1) + = HappyAbsSyn207 + (ecFromExp $ sL1 happy_var_1 (HsIPVar noExt $! unLoc happy_var_1) + ) +happyReduction_537 _ = notHappyAtAll + +happyReduce_538 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_538 = happySpecReduce_1 202# happyReduction_538 +happyReduction_538 (HappyAbsSyn25 happy_var_1) + = HappyAbsSyn207 + (ecFromExp $ sL1 happy_var_1 (HsOverLabel noExt Nothing $! unLoc happy_var_1) + ) +happyReduction_538 _ = notHappyAtAll + +happyReduce_539 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_539 = happySpecReduce_1 202# happyReduction_539 +happyReduction_539 (HappyAbsSyn315 happy_var_1) + = HappyAbsSyn207 + (ecFromExp $ sL1 happy_var_1 (HsLit noExt $! unLoc happy_var_1) + ) +happyReduction_539 _ = notHappyAtAll + +happyReduce_540 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_540 = happySpecReduce_1 202# happyReduction_540 +happyReduction_540 (HappyTerminal happy_var_1) + = HappyAbsSyn207 + (ecFromExp $ sL (getLoc happy_var_1) (HsOverLit noExt $! mkHsIntegral (getINTEGER happy_var_1) ) + ) +happyReduction_540 _ = notHappyAtAll + +happyReduce_541 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_541 = happySpecReduce_1 202# happyReduction_541 +happyReduction_541 (HappyTerminal happy_var_1) + = HappyAbsSyn207 + (ecFromExp $ sL (getLoc happy_var_1) (HsOverLit noExt $! mkHsFractional (getRATIONAL happy_var_1) ) + ) +happyReduction_541 _ = notHappyAtAll + +happyReduce_542 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_542 = happySpecReduce_3 202# happyReduction_542 +happyReduction_542 (HappyTerminal happy_var_3) + (HappyAbsSyn207 happy_var_2) + (HappyTerminal happy_var_1) + = HappyAbsSyn207 + (ExpCmdP $ + runExpCmdP happy_var_2 >>= \ happy_var_2 -> + ams (sLL happy_var_1 happy_var_3 (ecHsPar happy_var_2)) [mop happy_var_1,mcp happy_var_3] + ) +happyReduction_542 _ _ _ = notHappyAtAll + +happyReduce_543 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_543 = happyMonadReduce 3# 202# happyReduction_543 +happyReduction_543 ((HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn227 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( do { e <- mkSumOrTuple Boxed (comb2 happy_var_1 happy_var_3) (snd happy_var_2) + ; fmap ecFromExp $ + ams (sLL happy_var_1 happy_var_3 e) ((mop happy_var_1:fst happy_var_2) ++ [mcp happy_var_3]) })) + ) (\r -> happyReturn (HappyAbsSyn207 r)) + +happyReduce_544 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_544 = happyMonadReduce 3# 202# happyReduction_544 +happyReduction_544 ((HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn207 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_2 >>= \ happy_var_2 -> + fmap ecFromExp $ + ams (sLL happy_var_1 happy_var_3 (ExplicitTuple noExt [cL (gl happy_var_2) + (Present noExt happy_var_2)] Unboxed)) + [mo happy_var_1,mc happy_var_3])) + ) (\r -> happyReturn (HappyAbsSyn207 r)) + +happyReduce_545 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_545 = happyMonadReduce 3# 202# happyReduction_545 +happyReduction_545 ((HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn227 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( do { e <- mkSumOrTuple Unboxed (comb2 happy_var_1 happy_var_3) (snd happy_var_2) + ; fmap ecFromExp $ + ams (sLL happy_var_1 happy_var_3 e) ((mo happy_var_1:fst happy_var_2) ++ [mc happy_var_3]) })) + ) (\r -> happyReturn (HappyAbsSyn207 r)) + +happyReduce_546 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_546 = happyMonadReduce 3# 202# happyReduction_546 +happyReduction_546 ((HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn230 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( fmap ecFromExp $ ams (sLL happy_var_1 happy_var_3 (snd happy_var_2)) (mos happy_var_1:mcs happy_var_3:(fst happy_var_2)))) + ) (\r -> happyReturn (HappyAbsSyn207 r)) + +happyReduce_547 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_547 = happySpecReduce_1 202# happyReduction_547 +happyReduction_547 (HappyTerminal happy_var_1) + = HappyAbsSyn207 + (ecFromExp $ sL1 happy_var_1 $ EWildPat noExt + ) +happyReduction_547 _ = notHappyAtAll + +happyReduce_548 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_548 = happySpecReduce_1 202# happyReduction_548 +happyReduction_548 (HappyAbsSyn209 happy_var_1) + = HappyAbsSyn207 + (ecFromExp happy_var_1 + ) +happyReduction_548 _ = notHappyAtAll + +happyReduce_549 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_549 = happyMonadReduce 2# 202# happyReduction_549 +happyReduction_549 ((HappyAbsSyn16 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( fmap ecFromExp $ ams (sLL happy_var_1 happy_var_2 $ HsBracket noExt (VarBr noExt True (unLoc happy_var_2))) [mj AnnSimpleQuote happy_var_1,mj AnnName happy_var_2])) + ) (\r -> happyReturn (HappyAbsSyn207 r)) + +happyReduce_550 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_550 = happyMonadReduce 2# 202# happyReduction_550 +happyReduction_550 ((HappyAbsSyn16 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( fmap ecFromExp $ ams (sLL happy_var_1 happy_var_2 $ HsBracket noExt (VarBr noExt True (unLoc happy_var_2))) [mj AnnSimpleQuote happy_var_1,mj AnnName happy_var_2])) + ) (\r -> happyReturn (HappyAbsSyn207 r)) + +happyReduce_551 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_551 = happyMonadReduce 2# 202# happyReduction_551 +happyReduction_551 ((HappyAbsSyn16 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( fmap ecFromExp $ ams (sLL happy_var_1 happy_var_2 $ HsBracket noExt (VarBr noExt False (unLoc happy_var_2))) [mj AnnThTyQuote happy_var_1,mj AnnName happy_var_2])) + ) (\r -> happyReturn (HappyAbsSyn207 r)) + +happyReduce_552 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_552 = happyMonadReduce 2# 202# happyReduction_552 +happyReduction_552 ((HappyAbsSyn16 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( fmap ecFromExp $ ams (sLL happy_var_1 happy_var_2 $ HsBracket noExt (VarBr noExt False (unLoc happy_var_2))) [mj AnnThTyQuote happy_var_1,mj AnnName happy_var_2])) + ) (\r -> happyReturn (HappyAbsSyn207 r)) + +happyReduce_553 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_553 = happyMonadReduce 1# 202# happyReduction_553 +happyReduction_553 ((HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( reportEmptyDoubleQuotes (getLoc happy_var_1))) + ) (\r -> happyReturn (HappyAbsSyn207 r)) + +happyReduce_554 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_554 = happyMonadReduce 3# 202# happyReduction_554 +happyReduction_554 ((HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn207 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_2 >>= \ happy_var_2 -> + fmap ecFromExp $ + ams (sLL happy_var_1 happy_var_3 $ HsBracket noExt (ExpBr noExt happy_var_2)) + (if (hasE happy_var_1) then [mj AnnOpenE happy_var_1, mu AnnCloseQ happy_var_3] + else [mu AnnOpenEQ happy_var_1,mu AnnCloseQ happy_var_3]))) + ) (\r -> happyReturn (HappyAbsSyn207 r)) + +happyReduce_555 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_555 = happyMonadReduce 3# 202# happyReduction_555 +happyReduction_555 ((HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn207 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_2 >>= \ happy_var_2 -> + fmap ecFromExp $ + ams (sLL happy_var_1 happy_var_3 $ HsBracket noExt (TExpBr noExt happy_var_2)) + (if (hasE happy_var_1) then [mj AnnOpenE happy_var_1,mc happy_var_3] else [mo happy_var_1,mc happy_var_3]))) + ) (\r -> happyReturn (HappyAbsSyn207 r)) + +happyReduce_556 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_556 = happyMonadReduce 3# 202# happyReduction_556 +happyReduction_556 ((HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn147 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( fmap ecFromExp $ + ams (sLL happy_var_1 happy_var_3 $ HsBracket noExt (TypBr noExt happy_var_2)) [mo happy_var_1,mu AnnCloseQ happy_var_3])) + ) (\r -> happyReturn (HappyAbsSyn207 r)) + +happyReduce_557 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_557 = happyMonadReduce 3# 202# happyReduction_557 +happyReduction_557 ((HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn207 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( (checkPattern empty <=< runExpCmdP) happy_var_2 >>= \p -> + fmap ecFromExp $ + ams (sLL happy_var_1 happy_var_3 $ HsBracket noExt (PatBr noExt p)) + [mo happy_var_1,mu AnnCloseQ happy_var_3])) + ) (\r -> happyReturn (HappyAbsSyn207 r)) + +happyReduce_558 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_558 = happyMonadReduce 3# 202# happyReduction_558 +happyReduction_558 ((HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn224 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( fmap ecFromExp $ + ams (sLL happy_var_1 happy_var_3 $ HsBracket noExt (DecBrL noExt (snd happy_var_2))) + (mo happy_var_1:mu AnnCloseQ happy_var_3:fst happy_var_2))) + ) (\r -> happyReturn (HappyAbsSyn207 r)) + +happyReduce_559 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_559 = happySpecReduce_1 202# happyReduction_559 +happyReduction_559 (HappyAbsSyn206 happy_var_1) + = HappyAbsSyn207 + (ecFromExp $ sL1 happy_var_1 (HsSpliceE noExt (unLoc happy_var_1)) + ) +happyReduction_559 _ = notHappyAtAll + +happyReduce_560 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_560 = happyMonadReduce 4# 202# happyReduction_560 +happyReduction_560 ((HappyTerminal happy_var_4) `HappyStk` + (HappyAbsSyn222 happy_var_3) `HappyStk` + (HappyAbsSyn207 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_2 >>= \ happy_var_2 -> + fmap ecFromCmd $ + ams (sLL happy_var_1 happy_var_4 $ HsCmdArrForm noExt happy_var_2 Prefix + Nothing (reverse happy_var_3)) + [mu AnnOpenB happy_var_1,mu AnnCloseB happy_var_4])) + ) (\r -> happyReturn (HappyAbsSyn207 r)) + +happyReduce_561 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_561 = happySpecReduce_1 203# happyReduction_561 +happyReduction_561 (HappyAbsSyn206 happy_var_1) + = HappyAbsSyn209 + (mapLoc (HsSpliceE noExt) happy_var_1 + ) +happyReduction_561 _ = notHappyAtAll + +happyReduce_562 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_562 = happySpecReduce_1 203# happyReduction_562 +happyReduction_562 (HappyAbsSyn206 happy_var_1) + = HappyAbsSyn209 + (mapLoc (HsSpliceE noExt) happy_var_1 + ) +happyReduction_562 _ = notHappyAtAll + +happyReduce_563 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_563 = happyMonadReduce 1# 204# happyReduction_563 +happyReduction_563 ((HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sL1 happy_var_1 $ mkUntypedSplice HasDollar + (sL1 happy_var_1 $ HsVar noExt (sL1 happy_var_1 (mkUnqual varName + (getTH_ID_SPLICE happy_var_1))))) + [mj AnnThIdSplice happy_var_1])) + ) (\r -> happyReturn (HappyAbsSyn206 r)) + +happyReduce_564 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_564 = happyMonadReduce 3# 204# happyReduction_564 +happyReduction_564 ((HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn207 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_2 >>= \ happy_var_2 -> + ams (sLL happy_var_1 happy_var_3 $ mkUntypedSplice HasParens happy_var_2) + [mj AnnOpenPE happy_var_1,mj AnnCloseP happy_var_3])) + ) (\r -> happyReturn (HappyAbsSyn206 r)) + +happyReduce_565 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_565 = happyMonadReduce 1# 205# happyReduction_565 +happyReduction_565 ((HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sL1 happy_var_1 $ mkTypedSplice HasDollar + (sL1 happy_var_1 $ HsVar noExt (sL1 happy_var_1 (mkUnqual varName + (getTH_ID_TY_SPLICE happy_var_1))))) + [mj AnnThIdTySplice happy_var_1])) + ) (\r -> happyReturn (HappyAbsSyn206 r)) + +happyReduce_566 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_566 = happyMonadReduce 3# 205# happyReduction_566 +happyReduction_566 ((HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn207 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_2 >>= \ happy_var_2 -> + ams (sLL happy_var_1 happy_var_3 $ mkTypedSplice HasParens happy_var_2) + [mj AnnOpenPTE happy_var_1,mj AnnCloseP happy_var_3])) + ) (\r -> happyReturn (HappyAbsSyn206 r)) + +happyReduce_567 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_567 = happySpecReduce_2 206# happyReduction_567 +happyReduction_567 (HappyAbsSyn223 happy_var_2) + (HappyAbsSyn222 happy_var_1) + = HappyAbsSyn222 + (happy_var_2 : happy_var_1 + ) +happyReduction_567 _ _ = notHappyAtAll + +happyReduce_568 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_568 = happySpecReduce_0 206# happyReduction_568 +happyReduction_568 = HappyAbsSyn222 + ([] + ) + +happyReduce_569 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_569 = happyMonadReduce 1# 207# happyReduction_569 +happyReduction_569 ((HappyAbsSyn207 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_1 >>= \ cmd -> + return (sL1 cmd $ HsCmdTop noExt cmd))) + ) (\r -> happyReturn (HappyAbsSyn223 r)) + +happyReduce_570 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_570 = happySpecReduce_3 208# happyReduction_570 +happyReduction_570 (HappyTerminal happy_var_3) + (HappyAbsSyn225 happy_var_2) + (HappyTerminal happy_var_1) + = HappyAbsSyn224 + (([mj AnnOpenC happy_var_1 + ,mj AnnCloseC happy_var_3],happy_var_2) + ) +happyReduction_570 _ _ _ = notHappyAtAll + +happyReduce_571 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_571 = happySpecReduce_3 208# happyReduction_571 +happyReduction_571 _ + (HappyAbsSyn225 happy_var_2) + _ + = HappyAbsSyn224 + (([],happy_var_2) + ) +happyReduction_571 _ _ _ = notHappyAtAll + +happyReduce_572 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_572 = happySpecReduce_1 209# happyReduction_572 +happyReduction_572 (HappyAbsSyn75 happy_var_1) + = HappyAbsSyn225 + (cvTopDecls happy_var_1 + ) +happyReduction_572 _ = notHappyAtAll + +happyReduce_573 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_573 = happySpecReduce_1 209# happyReduction_573 +happyReduction_573 (HappyAbsSyn75 happy_var_1) + = HappyAbsSyn225 + (cvTopDecls happy_var_1 + ) +happyReduction_573 _ = notHappyAtAll + +happyReduce_574 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_574 = happySpecReduce_1 210# happyReduction_574 +happyReduction_574 (HappyAbsSyn207 happy_var_1) + = HappyAbsSyn207 + (happy_var_1 + ) +happyReduction_574 _ = notHappyAtAll + +happyReduce_575 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_575 = happyMonadReduce 2# 210# happyReduction_575 +happyReduction_575 ((HappyAbsSyn209 happy_var_2) `HappyStk` + (HappyAbsSyn207 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_1 >>= \ happy_var_1 -> + return $ ecFromExp $ + sLL happy_var_1 happy_var_2 $ SectionL noExt happy_var_1 happy_var_2)) + ) (\r -> happyReturn (HappyAbsSyn207 r)) + +happyReduce_576 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_576 = happyMonadReduce 2# 210# happyReduction_576 +happyReduction_576 ((HappyAbsSyn207 happy_var_2) `HappyStk` + (HappyAbsSyn209 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_2 >>= \ happy_var_2 -> + return $ ecFromExp $ + sLL happy_var_1 happy_var_2 $ SectionR noExt happy_var_1 happy_var_2)) + ) (\r -> happyReturn (HappyAbsSyn207 r)) + +happyReduce_577 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_577 = happyMonadReduce 3# 210# happyReduction_577 +happyReduction_577 ((HappyAbsSyn207 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn207 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_1 >>= \ happy_var_1 -> + runExpCmdP happy_var_3 >>= \ happy_var_3 -> + fmap ecFromExp $ + ams (sLL happy_var_1 happy_var_3 $ EViewPat noExt happy_var_1 happy_var_3) [mu AnnRarrow happy_var_2])) + ) (\r -> happyReturn (HappyAbsSyn207 r)) + +happyReduce_578 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_578 = happyMonadReduce 2# 211# happyReduction_578 +happyReduction_578 ((HappyAbsSyn228 happy_var_2) `HappyStk` + (HappyAbsSyn207 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_1 >>= \ happy_var_1 -> + do { addAnnotation (gl happy_var_1) AnnComma (fst happy_var_2) + ; return ([],Tuple ((sL1 happy_var_1 (Present noExt happy_var_1)) : snd happy_var_2)) })) + ) (\r -> happyReturn (HappyAbsSyn227 r)) + +happyReduce_579 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_579 = happyMonadReduce 2# 211# happyReduction_579 +happyReduction_579 ((HappyAbsSyn318 happy_var_2) `HappyStk` + (HappyAbsSyn207 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_1 >>= \ happy_var_1 -> return $ + (mvbars (fst happy_var_2), Sum 1 (snd happy_var_2 + 1) happy_var_1))) + ) (\r -> happyReturn (HappyAbsSyn227 r)) + +happyReduce_580 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_580 = happyMonadReduce 2# 211# happyReduction_580 +happyReduction_580 ((HappyAbsSyn229 happy_var_2) `HappyStk` + (HappyAbsSyn318 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (fst happy_var_1) + ; return + ([],Tuple (map (\l -> cL l missingTupArg) (fst happy_var_1) ++ happy_var_2)) })) + ) (\r -> happyReturn (HappyAbsSyn227 r)) + +happyReduce_581 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_581 = happyMonadReduce 3# 211# happyReduction_581 +happyReduction_581 ((HappyAbsSyn318 happy_var_3) `HappyStk` + (HappyAbsSyn207 happy_var_2) `HappyStk` + (HappyAbsSyn318 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_2 >>= \ happy_var_2 -> return $ + (mvbars (fst happy_var_1) ++ mvbars (fst happy_var_3), Sum (snd happy_var_1 + 1) (snd happy_var_1 + snd happy_var_3 + 1) happy_var_2))) + ) (\r -> happyReturn (HappyAbsSyn227 r)) + +happyReduce_582 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_582 = happyMonadReduce 2# 212# happyReduction_582 +happyReduction_582 ((HappyAbsSyn229 happy_var_2) `HappyStk` + (HappyAbsSyn318 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (tail $ fst happy_var_1) + ; return ( + (head $ fst happy_var_1 + ,(map (\l -> cL l missingTupArg) (tail $ fst happy_var_1)) ++ happy_var_2)) })) + ) (\r -> happyReturn (HappyAbsSyn228 r)) + +happyReduce_583 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_583 = happyMonadReduce 2# 213# happyReduction_583 +happyReduction_583 ((HappyAbsSyn228 happy_var_2) `HappyStk` + (HappyAbsSyn207 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_1 >>= \ happy_var_1 -> + addAnnotation (gl happy_var_1) AnnComma (fst happy_var_2) >> + return ((cL (gl happy_var_1) (Present noExt happy_var_1)) : snd happy_var_2))) + ) (\r -> happyReturn (HappyAbsSyn229 r)) + +happyReduce_584 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_584 = happyMonadReduce 1# 213# happyReduction_584 +happyReduction_584 ((HappyAbsSyn207 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_1 >>= \ happy_var_1 -> + return [cL (gl happy_var_1) (Present noExt happy_var_1)])) + ) (\r -> happyReturn (HappyAbsSyn229 r)) + +happyReduce_585 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_585 = happySpecReduce_0 213# happyReduction_585 +happyReduction_585 = HappyAbsSyn229 + ([noLoc missingTupArg] + ) + +happyReduce_586 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_586 = happyMonadReduce 1# 214# happyReduction_586 +happyReduction_586 ((HappyAbsSyn207 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_1 >>= \ happy_var_1 -> + return ([],ExplicitList noExt Nothing [happy_var_1]))) + ) (\r -> happyReturn (HappyAbsSyn230 r)) + +happyReduce_587 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_587 = happySpecReduce_1 214# happyReduction_587 +happyReduction_587 (HappyAbsSyn231 happy_var_1) + = HappyAbsSyn230 + (([],ExplicitList noExt Nothing (reverse (unLoc happy_var_1))) + ) +happyReduction_587 _ = notHappyAtAll + +happyReduce_588 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_588 = happyMonadReduce 2# 214# happyReduction_588 +happyReduction_588 ((HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn207 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_1 >>= \ happy_var_1 -> + return ([mj AnnDotdot happy_var_2], + ArithSeq noExt Nothing (From happy_var_1)))) + ) (\r -> happyReturn (HappyAbsSyn230 r)) + +happyReduce_589 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_589 = happyMonadReduce 4# 214# happyReduction_589 +happyReduction_589 ((HappyTerminal happy_var_4) `HappyStk` + (HappyAbsSyn207 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn207 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_1 >>= \ happy_var_1 -> + runExpCmdP happy_var_3 >>= \ happy_var_3 -> + return ([mj AnnComma happy_var_2,mj AnnDotdot happy_var_4], + ArithSeq noExt Nothing + (FromThen happy_var_1 happy_var_3)))) + ) (\r -> happyReturn (HappyAbsSyn230 r)) + +happyReduce_590 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_590 = happyMonadReduce 3# 214# happyReduction_590 +happyReduction_590 ((HappyAbsSyn207 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn207 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_1 >>= \ happy_var_1 -> + runExpCmdP happy_var_3 >>= \ happy_var_3 -> + return ([mj AnnDotdot happy_var_2], + ArithSeq noExt Nothing + (FromTo happy_var_1 happy_var_3)))) + ) (\r -> happyReturn (HappyAbsSyn230 r)) + +happyReduce_591 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_591 = happyMonadReduce 5# 214# happyReduction_591 +happyReduction_591 ((HappyAbsSyn207 happy_var_5) `HappyStk` + (HappyTerminal happy_var_4) `HappyStk` + (HappyAbsSyn207 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn207 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_1 >>= \ happy_var_1 -> + runExpCmdP happy_var_3 >>= \ happy_var_3 -> + runExpCmdP happy_var_5 >>= \ happy_var_5 -> + return ([mj AnnComma happy_var_2,mj AnnDotdot happy_var_4], + ArithSeq noExt Nothing + (FromThenTo happy_var_1 happy_var_3 happy_var_5)))) + ) (\r -> happyReturn (HappyAbsSyn230 r)) + +happyReduce_592 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_592 = happyMonadReduce 3# 214# happyReduction_592 +happyReduction_592 ((HappyAbsSyn232 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn207 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( checkMonadComp >>= \ ctxt -> + runExpCmdP happy_var_1 >>= \ happy_var_1 -> + return ([mj AnnVbar happy_var_2], + mkHsComp ctxt (unLoc happy_var_3) happy_var_1))) + ) (\r -> happyReturn (HappyAbsSyn230 r)) + +happyReduce_593 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_593 = happyMonadReduce 3# 215# happyReduction_593 +happyReduction_593 ((HappyAbsSyn207 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn231 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_3 >>= \ happy_var_3 -> + addAnnotation (gl $ head $ unLoc happy_var_1) + AnnComma (gl happy_var_2) >> + return (sLL happy_var_1 happy_var_3 (((:) $! happy_var_3) $! unLoc happy_var_1)))) + ) (\r -> happyReturn (HappyAbsSyn231 r)) + +happyReduce_594 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_594 = happyMonadReduce 3# 215# happyReduction_594 +happyReduction_594 ((HappyAbsSyn207 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn207 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_1 >>= \ happy_var_1 -> + runExpCmdP happy_var_3 >>= \ happy_var_3 -> + addAnnotation (gl happy_var_1) AnnComma (gl happy_var_2) >> + return (sLL happy_var_1 happy_var_3 [happy_var_3,happy_var_1]))) + ) (\r -> happyReturn (HappyAbsSyn231 r)) + +happyReduce_595 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_595 = happySpecReduce_1 216# happyReduction_595 +happyReduction_595 (HappyAbsSyn233 happy_var_1) + = HappyAbsSyn232 + (case (unLoc happy_var_1) of + [qs] -> sL1 happy_var_1 qs + -- We just had one thing in our "parallel" list so + -- we simply return that thing directly + + qss -> sL1 happy_var_1 [sL1 happy_var_1 $ ParStmt noExt [ParStmtBlock noExt qs [] noSyntaxExpr | + qs <- qss] + noExpr noSyntaxExpr] + -- We actually found some actual parallel lists so + -- we wrap them into as a ParStmt + ) +happyReduction_595 _ = notHappyAtAll + +happyReduce_596 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_596 = happyMonadReduce 3# 217# happyReduction_596 +happyReduction_596 ((HappyAbsSyn233 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn232 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( addAnnotation (gl $ head $ unLoc happy_var_1) AnnVbar (gl happy_var_2) >> + return (sLL happy_var_1 happy_var_3 (reverse (unLoc happy_var_1) : unLoc happy_var_3)))) + ) (\r -> happyReturn (HappyAbsSyn233 r)) + +happyReduce_597 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_597 = happySpecReduce_1 217# happyReduction_597 +happyReduction_597 (HappyAbsSyn232 happy_var_1) + = HappyAbsSyn233 + (cL (getLoc happy_var_1) [reverse (unLoc happy_var_1)] + ) +happyReduction_597 _ = notHappyAtAll + +happyReduce_598 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_598 = happyMonadReduce 3# 218# happyReduction_598 +happyReduction_598 ((HappyAbsSyn235 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn232 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( addAnnotation (gl $ head $ unLoc happy_var_1) AnnComma (gl happy_var_2) >> + amsL (comb2 happy_var_1 happy_var_3) (fst $ unLoc happy_var_3) >> + return (sLL happy_var_1 happy_var_3 [sLL happy_var_1 happy_var_3 ((snd $ unLoc happy_var_3) (reverse (unLoc happy_var_1)))]))) + ) (\r -> happyReturn (HappyAbsSyn232 r)) + +happyReduce_599 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_599 = happyMonadReduce 3# 218# happyReduction_599 +happyReduction_599 ((HappyAbsSyn255 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn232 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( happy_var_3 >>= \ happy_var_3 -> + addAnnotation (gl $ head $ unLoc happy_var_1) AnnComma (gl happy_var_2) >> + return (sLL happy_var_1 happy_var_3 (happy_var_3 : unLoc happy_var_1)))) + ) (\r -> happyReturn (HappyAbsSyn232 r)) + +happyReduce_600 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_600 = happyMonadReduce 1# 218# happyReduction_600 +happyReduction_600 ((HappyAbsSyn235 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams happy_var_1 (fst $ unLoc happy_var_1) >> + return (sLL happy_var_1 happy_var_1 [cL (getLoc happy_var_1) ((snd $ unLoc happy_var_1) [])]))) + ) (\r -> happyReturn (HappyAbsSyn232 r)) + +happyReduce_601 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_601 = happyMonadReduce 1# 218# happyReduction_601 +happyReduction_601 ((HappyAbsSyn255 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( happy_var_1 >>= \ happy_var_1 -> + return $ sL1 happy_var_1 [happy_var_1])) + ) (\r -> happyReturn (HappyAbsSyn232 r)) + +happyReduce_602 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_602 = happyMonadReduce 2# 219# happyReduction_602 +happyReduction_602 ((HappyAbsSyn207 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_2 >>= \ happy_var_2 -> return $ + sLL happy_var_1 happy_var_2 ([mj AnnThen happy_var_1], \ss -> (mkTransformStmt ss happy_var_2)))) + ) (\r -> happyReturn (HappyAbsSyn235 r)) + +happyReduce_603 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_603 = happyMonadReduce 4# 219# happyReduction_603 +happyReduction_603 ((HappyAbsSyn207 happy_var_4) `HappyStk` + (HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn207 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_2 >>= \ happy_var_2 -> + runExpCmdP happy_var_4 >>= \ happy_var_4 -> + return $ sLL happy_var_1 happy_var_4 ([mj AnnThen happy_var_1,mj AnnBy happy_var_3], + \ss -> (mkTransformByStmt ss happy_var_2 happy_var_4)))) + ) (\r -> happyReturn (HappyAbsSyn235 r)) + +happyReduce_604 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_604 = happyMonadReduce 4# 219# happyReduction_604 +happyReduction_604 ((HappyAbsSyn207 happy_var_4) `HappyStk` + (HappyTerminal happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_4 >>= \ happy_var_4 -> + return $ sLL happy_var_1 happy_var_4 ([mj AnnThen happy_var_1,mj AnnGroup happy_var_2,mj AnnUsing happy_var_3], + \ss -> (mkGroupUsingStmt ss happy_var_4)))) + ) (\r -> happyReturn (HappyAbsSyn235 r)) + +happyReduce_605 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_605 = happyMonadReduce 6# 219# happyReduction_605 +happyReduction_605 ((HappyAbsSyn207 happy_var_6) `HappyStk` + (HappyTerminal happy_var_5) `HappyStk` + (HappyAbsSyn207 happy_var_4) `HappyStk` + (HappyTerminal happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_4 >>= \ happy_var_4 -> + runExpCmdP happy_var_6 >>= \ happy_var_6 -> + return $ sLL happy_var_1 happy_var_6 ([mj AnnThen happy_var_1,mj AnnGroup happy_var_2,mj AnnBy happy_var_3,mj AnnUsing happy_var_5], + \ss -> (mkGroupByUsingStmt ss happy_var_4 happy_var_6)))) + ) (\r -> happyReturn (HappyAbsSyn235 r)) + +happyReduce_606 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_606 = happySpecReduce_1 220# happyReduction_606 +happyReduction_606 (HappyAbsSyn232 happy_var_1) + = HappyAbsSyn232 + (cL (getLoc happy_var_1) (reverse (unLoc happy_var_1)) + ) +happyReduction_606 _ = notHappyAtAll + +happyReduce_607 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_607 = happyMonadReduce 3# 221# happyReduction_607 +happyReduction_607 ((HappyAbsSyn255 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn232 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( happy_var_3 >>= \ happy_var_3 -> + addAnnotation (gl $ head $ unLoc happy_var_1) AnnComma + (gl happy_var_2) >> + return (sLL happy_var_1 happy_var_3 (happy_var_3 : unLoc happy_var_1)))) + ) (\r -> happyReturn (HappyAbsSyn232 r)) + +happyReduce_608 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_608 = happyMonadReduce 1# 221# happyReduction_608 +happyReduction_608 ((HappyAbsSyn255 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( happy_var_1 >>= \ happy_var_1 -> + return $ sL1 happy_var_1 [happy_var_1])) + ) (\r -> happyReturn (HappyAbsSyn232 r)) + +happyReduce_609 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_609 = happySpecReduce_3 222# happyReduction_609 +happyReduction_609 (HappyTerminal happy_var_3) + (HappyAbsSyn238 happy_var_2) + (HappyTerminal happy_var_1) + = HappyAbsSyn238 + (happy_var_2 >>= \ happy_var_2 -> return $ + sLL happy_var_1 happy_var_3 ((moc happy_var_1:mcc happy_var_3:(fst $ unLoc happy_var_2)) + ,(reverse (snd $ unLoc happy_var_2))) + ) +happyReduction_609 _ _ _ = notHappyAtAll + +happyReduce_610 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_610 = happySpecReduce_3 222# happyReduction_610 +happyReduction_610 _ + (HappyAbsSyn238 happy_var_2) + _ + = HappyAbsSyn238 + (happy_var_2 >>= \ happy_var_2 -> return $ + cL (getLoc happy_var_2) (fst $ unLoc happy_var_2 + ,(reverse (snd $ unLoc happy_var_2))) + ) +happyReduction_610 _ _ _ = notHappyAtAll + +happyReduce_611 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_611 = happySpecReduce_2 222# happyReduction_611 +happyReduction_611 (HappyTerminal happy_var_2) + (HappyTerminal happy_var_1) + = HappyAbsSyn238 + (return $ sLL happy_var_1 happy_var_2 ([moc happy_var_1,mcc happy_var_2],[]) + ) +happyReduction_611 _ _ = notHappyAtAll + +happyReduce_612 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_612 = happySpecReduce_2 222# happyReduction_612 +happyReduction_612 _ + _ + = HappyAbsSyn238 + (return $ noLoc ([],[]) + ) + +happyReduce_613 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_613 = happySpecReduce_1 223# happyReduction_613 +happyReduction_613 (HappyAbsSyn238 happy_var_1) + = HappyAbsSyn238 + (happy_var_1 >>= \ happy_var_1 -> return $ + sL1 happy_var_1 (fst $ unLoc happy_var_1,snd $ unLoc happy_var_1) + ) +happyReduction_613 _ = notHappyAtAll + +happyReduce_614 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_614 = happySpecReduce_2 223# happyReduction_614 +happyReduction_614 (HappyAbsSyn238 happy_var_2) + (HappyTerminal happy_var_1) + = HappyAbsSyn238 + (happy_var_2 >>= \ happy_var_2 -> return $ + sLL happy_var_1 happy_var_2 ((mj AnnSemi happy_var_1:(fst $ unLoc happy_var_2)) + ,snd $ unLoc happy_var_2) + ) +happyReduction_614 _ _ = notHappyAtAll + +happyReduce_615 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_615 = happySpecReduce_3 224# happyReduction_615 +happyReduction_615 (HappyAbsSyn241 happy_var_3) + (HappyTerminal happy_var_2) + (HappyAbsSyn238 happy_var_1) + = HappyAbsSyn238 + (happy_var_1 >>= \ happy_var_1 -> + happy_var_3 >>= \ happy_var_3 -> + if null (snd $ unLoc happy_var_1) + then return (sLL happy_var_1 happy_var_3 (mj AnnSemi happy_var_2:(fst $ unLoc happy_var_1) + ,[happy_var_3])) + else (ams (head $ snd $ unLoc happy_var_1) + (mj AnnSemi happy_var_2:(fst $ unLoc happy_var_1)) + >> return (sLL happy_var_1 happy_var_3 ([],happy_var_3 : (snd $ unLoc happy_var_1))) ) + ) +happyReduction_615 _ _ _ = notHappyAtAll + +happyReduce_616 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_616 = happySpecReduce_2 224# happyReduction_616 +happyReduction_616 (HappyTerminal happy_var_2) + (HappyAbsSyn238 happy_var_1) + = HappyAbsSyn238 + (happy_var_1 >>= \ happy_var_1 -> + if null (snd $ unLoc happy_var_1) + then return (sLL happy_var_1 happy_var_2 (mj AnnSemi happy_var_2:(fst $ unLoc happy_var_1) + ,snd $ unLoc happy_var_1)) + else (ams (head $ snd $ unLoc happy_var_1) + (mj AnnSemi happy_var_2:(fst $ unLoc happy_var_1)) + >> return (sLL happy_var_1 happy_var_2 ([],snd $ unLoc happy_var_1))) + ) +happyReduction_616 _ _ = notHappyAtAll + +happyReduce_617 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_617 = happySpecReduce_1 224# happyReduction_617 +happyReduction_617 (HappyAbsSyn241 happy_var_1) + = HappyAbsSyn238 + (happy_var_1 >>= \ happy_var_1 -> return $ sL1 happy_var_1 ([],[happy_var_1]) + ) +happyReduction_617 _ = notHappyAtAll + +happyReduce_618 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_618 = happySpecReduce_2 225# happyReduction_618 +happyReduction_618 (HappyAbsSyn242 happy_var_2) + (HappyAbsSyn247 happy_var_1) + = HappyAbsSyn241 + (happy_var_2 >>= \ happy_var_2 -> + ams (sLL happy_var_1 happy_var_2 (Match { m_ext = noExt + , m_ctxt = CaseAlt + , m_pats = [happy_var_1] + , m_grhss = snd $ unLoc happy_var_2 })) + (fst $ unLoc happy_var_2) + ) +happyReduction_618 _ _ = notHappyAtAll + +happyReduce_619 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_619 = happySpecReduce_2 226# happyReduction_619 +happyReduction_619 (HappyAbsSyn125 happy_var_2) + (HappyAbsSyn243 happy_var_1) + = HappyAbsSyn242 + (happy_var_1 >>= \alt -> + return $ sLL alt happy_var_2 (fst $ unLoc happy_var_2, GRHSs noExt (unLoc alt) (snd $ unLoc happy_var_2)) + ) +happyReduction_619 _ _ = notHappyAtAll + +happyReduce_620 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_620 = happySpecReduce_2 227# happyReduction_620 +happyReduction_620 (HappyAbsSyn207 happy_var_2) + (HappyTerminal happy_var_1) + = HappyAbsSyn243 + (runExpCmdP happy_var_2 >>= \ happy_var_2 -> + ams (sLL happy_var_1 happy_var_2 (unguardedRHS (comb2 happy_var_1 happy_var_2) happy_var_2)) + [mu AnnRarrow happy_var_1] + ) +happyReduction_620 _ _ = notHappyAtAll + +happyReduce_621 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_621 = happySpecReduce_1 227# happyReduction_621 +happyReduction_621 (HappyAbsSyn243 happy_var_1) + = HappyAbsSyn243 + (happy_var_1 >>= \gdpats -> + return $ sL1 gdpats (reverse (unLoc gdpats)) + ) +happyReduction_621 _ = notHappyAtAll + +happyReduce_622 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_622 = happySpecReduce_2 228# happyReduction_622 +happyReduction_622 (HappyAbsSyn246 happy_var_2) + (HappyAbsSyn243 happy_var_1) + = HappyAbsSyn243 + (happy_var_1 >>= \gdpats -> + happy_var_2 >>= \gdpat -> + return $ sLL gdpats gdpat (gdpat : unLoc gdpats) + ) +happyReduction_622 _ _ = notHappyAtAll + +happyReduce_623 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_623 = happySpecReduce_1 228# happyReduction_623 +happyReduction_623 (HappyAbsSyn246 happy_var_1) + = HappyAbsSyn243 + (happy_var_1 >>= \gdpat -> return $ sL1 gdpat [gdpat] + ) +happyReduction_623 _ = notHappyAtAll + +happyReduce_624 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_624 = happyMonadReduce 3# 229# happyReduction_624 +happyReduction_624 ((HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn243 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( happy_var_2 >>= \ happy_var_2 -> + return $ sLL happy_var_1 happy_var_3 ([moc happy_var_1,mcc happy_var_3],unLoc happy_var_2))) + ) (\r -> happyReturn (HappyAbsSyn245 r)) + +happyReduce_625 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_625 = happyMonadReduce 2# 229# happyReduction_625 +happyReduction_625 (_ `HappyStk` + (HappyAbsSyn243 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( happy_var_1 >>= \ happy_var_1 -> + return $ sL1 happy_var_1 ([],unLoc happy_var_1))) + ) (\r -> happyReturn (HappyAbsSyn245 r)) + +happyReduce_626 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_626 = happyReduce 4# 230# happyReduction_626 +happyReduction_626 ((HappyAbsSyn207 happy_var_4) `HappyStk` + (HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn232 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) + = HappyAbsSyn246 + (runExpCmdP happy_var_4 >>= \ happy_var_4 -> + ams (sL (comb2 happy_var_1 happy_var_4) $ GRHS noExt (unLoc happy_var_2) happy_var_4) + [mj AnnVbar happy_var_1,mu AnnRarrow happy_var_3] + ) `HappyStk` happyRest + +happyReduce_627 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_627 = happyMonadReduce 1# 231# happyReduction_627 +happyReduction_627 ((HappyAbsSyn207 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( (checkPattern empty <=< runExpCmdP) happy_var_1)) + ) (\r -> happyReturn (HappyAbsSyn247 r)) + +happyReduce_628 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_628 = happyMonadReduce 2# 231# happyReduction_628 +happyReduction_628 ((HappyAbsSyn207 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_2 >>= \ happy_var_2 -> + amms (checkPattern empty (sLL happy_var_1 happy_var_2 (SectionR noExt + (sL1 happy_var_1 (HsVar noExt (sL1 happy_var_1 bang_RDR))) happy_var_2))) + [mj AnnBang happy_var_1])) + ) (\r -> happyReturn (HappyAbsSyn247 r)) + +happyReduce_629 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_629 = happyMonadReduce 1# 232# happyReduction_629 +happyReduction_629 ((HappyAbsSyn207 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_1 >>= \ happy_var_1 -> + checkPattern + (text "Possibly caused by a missing 'do'?") happy_var_1)) + ) (\r -> happyReturn (HappyAbsSyn247 r)) + +happyReduce_630 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_630 = happyMonadReduce 2# 232# happyReduction_630 +happyReduction_630 ((HappyAbsSyn207 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_2 >>= \ happy_var_2 -> + amms (checkPattern + (text "Possibly caused by a missing 'do'?") + (sLL happy_var_1 happy_var_2 (SectionR noExt (sL1 happy_var_1 (HsVar noExt (sL1 happy_var_1 bang_RDR))) happy_var_2))) + [mj AnnBang happy_var_1])) + ) (\r -> happyReturn (HappyAbsSyn247 r)) + +happyReduce_631 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_631 = happyMonadReduce 1# 233# happyReduction_631 +happyReduction_631 ((HappyAbsSyn207 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( (checkPattern empty <=< runExpCmdP) happy_var_1)) + ) (\r -> happyReturn (HappyAbsSyn247 r)) + +happyReduce_632 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_632 = happyMonadReduce 2# 233# happyReduction_632 +happyReduction_632 ((HappyAbsSyn207 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_2 >>= \ happy_var_2 -> + amms (checkPattern empty + (sLL happy_var_1 happy_var_2 (SectionR noExt + (sL1 happy_var_1 (HsVar noExt (sL1 happy_var_1 bang_RDR))) happy_var_2))) + [mj AnnBang happy_var_1])) + ) (\r -> happyReturn (HappyAbsSyn247 r)) + +happyReduce_633 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_633 = happySpecReduce_2 234# happyReduction_633 +happyReduction_633 (HappyAbsSyn250 happy_var_2) + (HappyAbsSyn247 happy_var_1) + = HappyAbsSyn250 + (happy_var_1 : happy_var_2 + ) +happyReduction_633 _ _ = notHappyAtAll + +happyReduce_634 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_634 = happySpecReduce_0 234# happyReduction_634 +happyReduction_634 = HappyAbsSyn250 + ([] + ) + +happyReduce_635 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_635 = happySpecReduce_3 235# happyReduction_635 +happyReduction_635 (HappyTerminal happy_var_3) + (HappyAbsSyn251 happy_var_2) + (HappyTerminal happy_var_1) + = HappyAbsSyn251 + (happy_var_2 >>= \ happy_var_2 -> return $ + sLL happy_var_1 happy_var_3 ((moc happy_var_1:mcc happy_var_3:(fst $ unLoc happy_var_2)) + ,(reverse $ snd $ unLoc happy_var_2)) + ) +happyReduction_635 _ _ _ = notHappyAtAll + +happyReduce_636 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_636 = happySpecReduce_3 235# happyReduction_636 +happyReduction_636 _ + (HappyAbsSyn251 happy_var_2) + _ + = HappyAbsSyn251 + (happy_var_2 >>= \ happy_var_2 -> return $ + cL (gl happy_var_2) (fst $ unLoc happy_var_2 + ,reverse $ snd $ unLoc happy_var_2) + ) +happyReduction_636 _ _ _ = notHappyAtAll + +happyReduce_637 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_637 = happySpecReduce_3 236# happyReduction_637 +happyReduction_637 (HappyAbsSyn255 happy_var_3) + (HappyTerminal happy_var_2) + (HappyAbsSyn251 happy_var_1) + = HappyAbsSyn251 + (happy_var_1 >>= \ happy_var_1 -> + happy_var_3 >>= \ happy_var_3 -> + if null (snd $ unLoc happy_var_1) + then return (sLL happy_var_1 happy_var_3 (mj AnnSemi happy_var_2:(fst $ unLoc happy_var_1) + ,happy_var_3 : (snd $ unLoc happy_var_1))) + else do + { ams (head $ snd $ unLoc happy_var_1) [mj AnnSemi happy_var_2] + ; return $ sLL happy_var_1 happy_var_3 (fst $ unLoc happy_var_1,happy_var_3 :(snd $ unLoc happy_var_1)) } + ) +happyReduction_637 _ _ _ = notHappyAtAll + +happyReduce_638 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_638 = happySpecReduce_2 236# happyReduction_638 +happyReduction_638 (HappyTerminal happy_var_2) + (HappyAbsSyn251 happy_var_1) + = HappyAbsSyn251 + (happy_var_1 >>= \ happy_var_1 -> + if null (snd $ unLoc happy_var_1) + then return (sLL happy_var_1 happy_var_2 (mj AnnSemi happy_var_2:(fst $ unLoc happy_var_1),snd $ unLoc happy_var_1)) + else do + { ams (head $ snd $ unLoc happy_var_1) + [mj AnnSemi happy_var_2] + ; return happy_var_1 } + ) +happyReduction_638 _ _ = notHappyAtAll + +happyReduce_639 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_639 = happySpecReduce_1 236# happyReduction_639 +happyReduction_639 (HappyAbsSyn255 happy_var_1) + = HappyAbsSyn251 + (happy_var_1 >>= \ happy_var_1 -> + return $ sL1 happy_var_1 ([],[happy_var_1]) + ) +happyReduction_639 _ = notHappyAtAll + +happyReduce_640 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_640 = happySpecReduce_0 236# happyReduction_640 +happyReduction_640 = HappyAbsSyn251 + (return $ noLoc ([],[]) + ) + +happyReduce_641 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_641 = happyMonadReduce 1# 237# happyReduction_641 +happyReduction_641 ((HappyAbsSyn255 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( fmap Just happy_var_1)) + ) (\r -> happyReturn (HappyAbsSyn253 r)) + +happyReduce_642 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_642 = happySpecReduce_0 237# happyReduction_642 +happyReduction_642 = HappyAbsSyn253 + (Nothing + ) + +happyReduce_643 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_643 = happyMonadReduce 1# 238# happyReduction_643 +happyReduction_643 ((HappyAbsSyn255 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( happy_var_1)) + ) (\r -> happyReturn (HappyAbsSyn254 r)) + +happyReduce_644 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_644 = happySpecReduce_1 239# happyReduction_644 +happyReduction_644 (HappyAbsSyn255 happy_var_1) + = HappyAbsSyn255 + (happy_var_1 + ) +happyReduction_644 _ = notHappyAtAll + +happyReduce_645 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_645 = happySpecReduce_2 239# happyReduction_645 +happyReduction_645 (HappyAbsSyn251 happy_var_2) + (HappyTerminal happy_var_1) + = HappyAbsSyn255 + (happy_var_2 >>= \ happy_var_2 -> + ams (sLL happy_var_1 happy_var_2 $ mkRecStmt (snd $ unLoc happy_var_2)) + (mj AnnRec happy_var_1:(fst $ unLoc happy_var_2)) + ) +happyReduction_645 _ _ = notHappyAtAll + +happyReduce_646 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_646 = happySpecReduce_3 240# happyReduction_646 +happyReduction_646 (HappyAbsSyn207 happy_var_3) + (HappyTerminal happy_var_2) + (HappyAbsSyn247 happy_var_1) + = HappyAbsSyn255 + (runExpCmdP happy_var_3 >>= \ happy_var_3 -> + ams (sLL happy_var_1 happy_var_3 $ mkBindStmt happy_var_1 happy_var_3) + [mu AnnLarrow happy_var_2] + ) +happyReduction_646 _ _ _ = notHappyAtAll + +happyReduce_647 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_647 = happySpecReduce_1 240# happyReduction_647 +happyReduction_647 (HappyAbsSyn207 happy_var_1) + = HappyAbsSyn255 + (runExpCmdP happy_var_1 >>= \ happy_var_1 -> + return $ sL1 happy_var_1 $ mkBodyStmt happy_var_1 + ) +happyReduction_647 _ = notHappyAtAll + +happyReduce_648 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_648 = happySpecReduce_2 240# happyReduction_648 +happyReduction_648 (HappyAbsSyn125 happy_var_2) + (HappyTerminal happy_var_1) + = HappyAbsSyn255 + (ams (sLL happy_var_1 happy_var_2 $ LetStmt noExt (snd $ unLoc happy_var_2)) + (mj AnnLet happy_var_1:(fst $ unLoc happy_var_2)) + ) +happyReduction_648 _ _ = notHappyAtAll + +happyReduce_649 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_649 = happySpecReduce_1 241# happyReduction_649 +happyReduction_649 (HappyAbsSyn257 happy_var_1) + = HappyAbsSyn257 + (happy_var_1 + ) +happyReduction_649 _ = notHappyAtAll + +happyReduce_650 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_650 = happySpecReduce_0 241# happyReduction_650 +happyReduction_650 = HappyAbsSyn257 + (([],([], Nothing)) + ) + +happyReduce_651 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_651 = happyMonadReduce 3# 242# happyReduction_651 +happyReduction_651 ((HappyAbsSyn257 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn259 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( addAnnotation (gl happy_var_1) AnnComma (gl happy_var_2) >> + return (case happy_var_3 of (ma,(flds, dd)) -> (ma,(happy_var_1 : flds, dd))))) + ) (\r -> happyReturn (HappyAbsSyn257 r)) + +happyReduce_652 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_652 = happySpecReduce_1 242# happyReduction_652 +happyReduction_652 (HappyAbsSyn259 happy_var_1) + = HappyAbsSyn257 + (([],([happy_var_1], Nothing)) + ) +happyReduction_652 _ = notHappyAtAll + +happyReduce_653 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_653 = happySpecReduce_1 242# happyReduction_653 +happyReduction_653 (HappyTerminal happy_var_1) + = HappyAbsSyn257 + (([mj AnnDotdot happy_var_1],([], Just (getLoc happy_var_1))) + ) +happyReduction_653 _ = notHappyAtAll + +happyReduce_654 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_654 = happyMonadReduce 3# 243# happyReduction_654 +happyReduction_654 ((HappyAbsSyn207 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn16 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_3 >>= \ happy_var_3 -> + ams (sLL happy_var_1 happy_var_3 $ HsRecField (sL1 happy_var_1 $ mkFieldOcc happy_var_1) happy_var_3 False) + [mj AnnEqual happy_var_2])) + ) (\r -> happyReturn (HappyAbsSyn259 r)) + +happyReduce_655 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_655 = happySpecReduce_1 243# happyReduction_655 +happyReduction_655 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn259 + (sLL happy_var_1 happy_var_1 $ HsRecField (sL1 happy_var_1 $ mkFieldOcc happy_var_1) placeHolderPunRhs True + ) +happyReduction_655 _ = notHappyAtAll + +happyReduce_656 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_656 = happyMonadReduce 3# 244# happyReduction_656 +happyReduction_656 ((HappyAbsSyn261 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn260 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( addAnnotation (gl $ last $ unLoc happy_var_1) AnnSemi (gl happy_var_2) >> + return (let { this = happy_var_3; rest = unLoc happy_var_1 } + in rest `seq` this `seq` sLL happy_var_1 happy_var_3 (this : rest)))) + ) (\r -> happyReturn (HappyAbsSyn260 r)) + +happyReduce_657 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_657 = happyMonadReduce 2# 244# happyReduction_657 +happyReduction_657 ((HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn260 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( addAnnotation (gl $ last $ unLoc happy_var_1) AnnSemi (gl happy_var_2) >> + return (sLL happy_var_1 happy_var_2 (unLoc happy_var_1)))) + ) (\r -> happyReturn (HappyAbsSyn260 r)) + +happyReduce_658 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_658 = happySpecReduce_1 244# happyReduction_658 +happyReduction_658 (HappyAbsSyn261 happy_var_1) + = HappyAbsSyn260 + (let this = happy_var_1 in this `seq` sL1 happy_var_1 [this] + ) +happyReduction_658 _ = notHappyAtAll + +happyReduce_659 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_659 = happyMonadReduce 3# 245# happyReduction_659 +happyReduction_659 ((HappyAbsSyn207 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn262 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( runExpCmdP happy_var_3 >>= \ happy_var_3 -> + ams (sLL happy_var_1 happy_var_3 (IPBind noExt (Left happy_var_1) happy_var_3)) + [mj AnnEqual happy_var_2])) + ) (\r -> happyReturn (HappyAbsSyn261 r)) + +happyReduce_660 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_660 = happySpecReduce_1 246# happyReduction_660 +happyReduction_660 (HappyTerminal happy_var_1) + = HappyAbsSyn262 + (sL1 happy_var_1 (HsIPName (getIPDUPVARID happy_var_1)) + ) +happyReduction_660 _ = notHappyAtAll + +happyReduce_661 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_661 = happySpecReduce_1 247# happyReduction_661 +happyReduction_661 (HappyTerminal happy_var_1) + = HappyAbsSyn25 + (sL1 happy_var_1 (getLABELVARID happy_var_1) + ) +happyReduction_661 _ = notHappyAtAll + +happyReduce_662 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_662 = happySpecReduce_1 248# happyReduction_662 +happyReduction_662 (HappyAbsSyn264 happy_var_1) + = HappyAbsSyn264 + (happy_var_1 + ) +happyReduction_662 _ = notHappyAtAll + +happyReduce_663 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_663 = happySpecReduce_0 248# happyReduction_663 +happyReduction_663 = HappyAbsSyn264 + (noLoc mkTrue + ) + +happyReduce_664 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_664 = happySpecReduce_1 249# happyReduction_664 +happyReduction_664 (HappyAbsSyn264 happy_var_1) + = HappyAbsSyn264 + (happy_var_1 + ) +happyReduction_664 _ = notHappyAtAll + +happyReduce_665 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_665 = happyMonadReduce 3# 249# happyReduction_665 +happyReduction_665 ((HappyAbsSyn264 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn264 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( aa happy_var_1 (AnnVbar, happy_var_2) + >> return (sLL happy_var_1 happy_var_3 (Or [happy_var_1,happy_var_3])))) + ) (\r -> happyReturn (HappyAbsSyn264 r)) + +happyReduce_666 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_666 = happySpecReduce_1 250# happyReduction_666 +happyReduction_666 (HappyAbsSyn267 happy_var_1) + = HappyAbsSyn264 + (sLL (head happy_var_1) (last happy_var_1) (And (happy_var_1)) + ) +happyReduction_666 _ = notHappyAtAll + +happyReduce_667 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_667 = happySpecReduce_1 251# happyReduction_667 +happyReduction_667 (HappyAbsSyn264 happy_var_1) + = HappyAbsSyn267 + ([happy_var_1] + ) +happyReduction_667 _ = notHappyAtAll + +happyReduce_668 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_668 = happyMonadReduce 3# 251# happyReduction_668 +happyReduction_668 ((HappyAbsSyn267 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn264 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( aa happy_var_1 (AnnComma, happy_var_2) >> return (happy_var_1 : happy_var_3))) + ) (\r -> happyReturn (HappyAbsSyn267 r)) + +happyReduce_669 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_669 = happyMonadReduce 3# 252# happyReduction_669 +happyReduction_669 ((HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn264 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_3 (Parens happy_var_2)) [mop happy_var_1,mcp happy_var_3])) + ) (\r -> happyReturn (HappyAbsSyn264 r)) + +happyReduce_670 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_670 = happySpecReduce_1 252# happyReduction_670 +happyReduction_670 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn264 + (sL1 happy_var_1 (Var happy_var_1) + ) +happyReduction_670 _ = notHappyAtAll + +happyReduce_671 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_671 = happySpecReduce_1 253# happyReduction_671 +happyReduction_671 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn87 + (sL1 happy_var_1 [happy_var_1] + ) +happyReduction_671 _ = notHappyAtAll + +happyReduce_672 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_672 = happyMonadReduce 3# 253# happyReduction_672 +happyReduction_672 ((HappyAbsSyn87 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn16 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( addAnnotation (gl happy_var_1) AnnComma (gl happy_var_2) >> + return (sLL happy_var_1 happy_var_3 (happy_var_1 : unLoc happy_var_3)))) + ) (\r -> happyReturn (HappyAbsSyn87 r)) + +happyReduce_673 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_673 = happySpecReduce_1 254# happyReduction_673 +happyReduction_673 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn16 + (happy_var_1 + ) +happyReduction_673 _ = notHappyAtAll + +happyReduce_674 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_674 = happySpecReduce_1 254# happyReduction_674 +happyReduction_674 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn16 + (happy_var_1 + ) +happyReduction_674 _ = notHappyAtAll + +happyReduce_675 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_675 = happySpecReduce_1 255# happyReduction_675 +happyReduction_675 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn16 + (happy_var_1 + ) +happyReduction_675 _ = notHappyAtAll + +happyReduce_676 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_676 = happySpecReduce_1 255# happyReduction_676 +happyReduction_676 (HappyAbsSyn276 happy_var_1) + = HappyAbsSyn16 + (sL1 happy_var_1 $ nameRdrName (dataConName (unLoc happy_var_1)) + ) +happyReduction_676 _ = notHappyAtAll + +happyReduce_677 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_677 = happySpecReduce_1 256# happyReduction_677 +happyReduction_677 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn16 + (happy_var_1 + ) +happyReduction_677 _ = notHappyAtAll + +happyReduce_678 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_678 = happySpecReduce_1 256# happyReduction_678 +happyReduction_678 (HappyAbsSyn276 happy_var_1) + = HappyAbsSyn16 + (sL1 happy_var_1 $ nameRdrName (dataConName (unLoc happy_var_1)) + ) +happyReduction_678 _ = notHappyAtAll + +happyReduce_679 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_679 = happySpecReduce_1 257# happyReduction_679 +happyReduction_679 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn16 + (happy_var_1 + ) +happyReduction_679 _ = notHappyAtAll + +happyReduce_680 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_680 = happyMonadReduce 3# 257# happyReduction_680 +happyReduction_680 ((HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn16 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + [mop happy_var_1,mj AnnVal happy_var_2,mcp happy_var_3])) + ) (\r -> happyReturn (HappyAbsSyn16 r)) + +happyReduce_681 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_681 = happySpecReduce_1 258# happyReduction_681 +happyReduction_681 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn16 + (happy_var_1 + ) +happyReduction_681 _ = notHappyAtAll + +happyReduce_682 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_682 = happyMonadReduce 3# 258# happyReduction_682 +happyReduction_682 ((HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn16 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + [mop happy_var_1,mj AnnVal happy_var_2,mcp happy_var_3])) + ) (\r -> happyReturn (HappyAbsSyn16 r)) + +happyReduce_683 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_683 = happySpecReduce_1 258# happyReduction_683 +happyReduction_683 (HappyAbsSyn276 happy_var_1) + = HappyAbsSyn16 + (sL1 happy_var_1 $ nameRdrName (dataConName (unLoc happy_var_1)) + ) +happyReduction_683 _ = notHappyAtAll + +happyReduce_684 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_684 = happySpecReduce_1 259# happyReduction_684 +happyReduction_684 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn87 + (sL1 happy_var_1 [happy_var_1] + ) +happyReduction_684 _ = notHappyAtAll + +happyReduce_685 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_685 = happyMonadReduce 3# 259# happyReduction_685 +happyReduction_685 ((HappyAbsSyn87 happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyAbsSyn16 happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( addAnnotation (gl happy_var_1) AnnComma (gl happy_var_2) >> + return (sLL happy_var_1 happy_var_3 (happy_var_1 : unLoc happy_var_3)))) + ) (\r -> happyReturn (HappyAbsSyn87 r)) + +happyReduce_686 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_686 = happyMonadReduce 2# 260# happyReduction_686 +happyReduction_686 ((HappyTerminal happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_2 unitDataCon) [mop happy_var_1,mcp happy_var_2])) + ) (\r -> happyReturn (HappyAbsSyn276 r)) + +happyReduce_687 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_687 = happyMonadReduce 3# 260# happyReduction_687 +happyReduction_687 ((HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn318 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_3 $ tupleDataCon Boxed (snd happy_var_2 + 1)) + (mop happy_var_1:mcp happy_var_3:(mcommas (fst happy_var_2))))) + ) (\r -> happyReturn (HappyAbsSyn276 r)) + +happyReduce_688 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_688 = happyMonadReduce 2# 260# happyReduction_688 +happyReduction_688 ((HappyTerminal happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_2 $ unboxedUnitDataCon) [mo happy_var_1,mc happy_var_2])) + ) (\r -> happyReturn (HappyAbsSyn276 r)) + +happyReduce_689 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_689 = happyMonadReduce 3# 260# happyReduction_689 +happyReduction_689 ((HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn318 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_3 $ tupleDataCon Unboxed (snd happy_var_2 + 1)) + (mo happy_var_1:mc happy_var_3:(mcommas (fst happy_var_2))))) + ) (\r -> happyReturn (HappyAbsSyn276 r)) + +happyReduce_690 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_690 = happySpecReduce_1 261# happyReduction_690 +happyReduction_690 (HappyAbsSyn276 happy_var_1) + = HappyAbsSyn276 + (happy_var_1 + ) +happyReduction_690 _ = notHappyAtAll + +happyReduce_691 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_691 = happyMonadReduce 2# 261# happyReduction_691 +happyReduction_691 ((HappyTerminal happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_2 nilDataCon) [mos happy_var_1,mcs happy_var_2])) + ) (\r -> happyReturn (HappyAbsSyn276 r)) + +happyReduce_692 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_692 = happySpecReduce_1 262# happyReduction_692 +happyReduction_692 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn16 + (happy_var_1 + ) +happyReduction_692 _ = notHappyAtAll + +happyReduce_693 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_693 = happyMonadReduce 3# 262# happyReduction_693 +happyReduction_693 ((HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn16 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + [mj AnnBackquote happy_var_1,mj AnnVal happy_var_2 + ,mj AnnBackquote happy_var_3])) + ) (\r -> happyReturn (HappyAbsSyn16 r)) + +happyReduce_694 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_694 = happySpecReduce_1 263# happyReduction_694 +happyReduction_694 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn16 + (happy_var_1 + ) +happyReduction_694 _ = notHappyAtAll + +happyReduce_695 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_695 = happyMonadReduce 3# 263# happyReduction_695 +happyReduction_695 ((HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn16 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + [mj AnnBackquote happy_var_1,mj AnnVal happy_var_2 + ,mj AnnBackquote happy_var_3])) + ) (\r -> happyReturn (HappyAbsSyn16 r)) + +happyReduce_696 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_696 = happySpecReduce_1 264# happyReduction_696 +happyReduction_696 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn16 + (happy_var_1 + ) +happyReduction_696 _ = notHappyAtAll + +happyReduce_697 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_697 = happyMonadReduce 2# 264# happyReduction_697 +happyReduction_697 ((HappyTerminal happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_2 $ getRdrName unitTyCon) + [mop happy_var_1,mcp happy_var_2])) + ) (\r -> happyReturn (HappyAbsSyn16 r)) + +happyReduce_698 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_698 = happyMonadReduce 2# 264# happyReduction_698 +happyReduction_698 ((HappyTerminal happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_2 $ getRdrName unboxedUnitTyCon) + [mo happy_var_1,mc happy_var_2])) + ) (\r -> happyReturn (HappyAbsSyn16 r)) + +happyReduce_699 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_699 = happySpecReduce_1 265# happyReduction_699 +happyReduction_699 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn16 + (happy_var_1 + ) +happyReduction_699 _ = notHappyAtAll + +happyReduce_700 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_700 = happyMonadReduce 3# 265# happyReduction_700 +happyReduction_700 ((HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn318 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_3 $ getRdrName (tupleTyCon Boxed + (snd happy_var_2 + 1))) + (mop happy_var_1:mcp happy_var_3:(mcommas (fst happy_var_2))))) + ) (\r -> happyReturn (HappyAbsSyn16 r)) + +happyReduce_701 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_701 = happyMonadReduce 3# 265# happyReduction_701 +happyReduction_701 ((HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn318 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_3 $ getRdrName (tupleTyCon Unboxed + (snd happy_var_2 + 1))) + (mo happy_var_1:mc happy_var_3:(mcommas (fst happy_var_2))))) + ) (\r -> happyReturn (HappyAbsSyn16 r)) + +happyReduce_702 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_702 = happyMonadReduce 3# 265# happyReduction_702 +happyReduction_702 ((HappyTerminal happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_3 $ getRdrName funTyCon) + [mop happy_var_1,mu AnnRarrow happy_var_2,mcp happy_var_3])) + ) (\r -> happyReturn (HappyAbsSyn16 r)) + +happyReduce_703 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_703 = happyMonadReduce 2# 265# happyReduction_703 +happyReduction_703 ((HappyTerminal happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_2 $ listTyCon_RDR) [mos happy_var_1,mcs happy_var_2])) + ) (\r -> happyReturn (HappyAbsSyn16 r)) + +happyReduce_704 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_704 = happySpecReduce_1 266# happyReduction_704 +happyReduction_704 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn16 + (happy_var_1 + ) +happyReduction_704 _ = notHappyAtAll + +happyReduce_705 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_705 = happyMonadReduce 3# 266# happyReduction_705 +happyReduction_705 ((HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn16 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + [mop happy_var_1,mj AnnVal happy_var_2,mcp happy_var_3])) + ) (\r -> happyReturn (HappyAbsSyn16 r)) + +happyReduce_706 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_706 = happySpecReduce_1 267# happyReduction_706 +happyReduction_706 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn16 + (happy_var_1 + ) +happyReduction_706 _ = notHappyAtAll + +happyReduce_707 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_707 = happyMonadReduce 3# 267# happyReduction_707 +happyReduction_707 ((HappyTerminal happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( let { name :: Located RdrName + ; name = sL1 happy_var_2 $! mkQual tcClsName (getQCONSYM happy_var_2) } + in ams (sLL happy_var_1 happy_var_3 (unLoc name)) [mop happy_var_1,mj AnnVal name,mcp happy_var_3])) + ) (\r -> happyReturn (HappyAbsSyn16 r)) + +happyReduce_708 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_708 = happyMonadReduce 3# 267# happyReduction_708 +happyReduction_708 ((HappyTerminal happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( let { name :: Located RdrName + ; name = sL1 happy_var_2 $! mkUnqual tcClsName (getCONSYM happy_var_2) } + in ams (sLL happy_var_1 happy_var_3 (unLoc name)) [mop happy_var_1,mj AnnVal name,mcp happy_var_3])) + ) (\r -> happyReturn (HappyAbsSyn16 r)) + +happyReduce_709 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_709 = happyMonadReduce 3# 267# happyReduction_709 +happyReduction_709 ((HappyTerminal happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( let { name :: Located RdrName + ; name = sL1 happy_var_2 $! consDataCon_RDR } + in ams (sLL happy_var_1 happy_var_3 (unLoc name)) [mop happy_var_1,mj AnnVal name,mcp happy_var_3])) + ) (\r -> happyReturn (HappyAbsSyn16 r)) + +happyReduce_710 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_710 = happyMonadReduce 3# 267# happyReduction_710 +happyReduction_710 ((HappyTerminal happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_3 $ eqTyCon_RDR) [mop happy_var_1,mj AnnTilde happy_var_2,mcp happy_var_3])) + ) (\r -> happyReturn (HappyAbsSyn16 r)) + +happyReduce_711 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_711 = happySpecReduce_1 268# happyReduction_711 +happyReduction_711 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn16 + (happy_var_1 + ) +happyReduction_711 _ = notHappyAtAll + +happyReduce_712 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_712 = happyMonadReduce 3# 268# happyReduction_712 +happyReduction_712 ((HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn16 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + [mj AnnBackquote happy_var_1,mj AnnVal happy_var_2 + ,mj AnnBackquote happy_var_3])) + ) (\r -> happyReturn (HappyAbsSyn16 r)) + +happyReduce_713 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_713 = happySpecReduce_1 269# happyReduction_713 +happyReduction_713 (HappyTerminal happy_var_1) + = HappyAbsSyn16 + (sL1 happy_var_1 $! mkQual tcClsName (getQCONID happy_var_1) + ) +happyReduction_713 _ = notHappyAtAll + +happyReduce_714 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_714 = happySpecReduce_1 269# happyReduction_714 +happyReduction_714 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn16 + (happy_var_1 + ) +happyReduction_714 _ = notHappyAtAll + +happyReduce_715 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_715 = happySpecReduce_1 270# happyReduction_715 +happyReduction_715 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn147 + (sL1 happy_var_1 (HsTyVar noExt NotPromoted happy_var_1) + ) +happyReduction_715 _ = notHappyAtAll + +happyReduce_716 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_716 = happySpecReduce_2 270# happyReduction_716 +happyReduction_716 (HappyAbsSyn321 happy_var_2) + (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn147 + (sLL happy_var_1 happy_var_2 (HsDocTy noExt (sL1 happy_var_1 (HsTyVar noExt NotPromoted happy_var_1)) happy_var_2) + ) +happyReduction_716 _ _ = notHappyAtAll + +happyReduce_717 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_717 = happySpecReduce_1 271# happyReduction_717 +happyReduction_717 (HappyTerminal happy_var_1) + = HappyAbsSyn16 + (sL1 happy_var_1 $! mkUnqual tcClsName (getCONID happy_var_1) + ) +happyReduction_717 _ = notHappyAtAll + +happyReduce_718 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_718 = happySpecReduce_1 272# happyReduction_718 +happyReduction_718 (HappyTerminal happy_var_1) + = HappyAbsSyn16 + (sL1 happy_var_1 $! mkQual tcClsName (getQCONSYM happy_var_1) + ) +happyReduction_718 _ = notHappyAtAll + +happyReduce_719 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_719 = happySpecReduce_1 272# happyReduction_719 +happyReduction_719 (HappyTerminal happy_var_1) + = HappyAbsSyn16 + (sL1 happy_var_1 $! mkQual tcClsName (getQVARSYM happy_var_1) + ) +happyReduction_719 _ = notHappyAtAll + +happyReduce_720 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_720 = happySpecReduce_1 272# happyReduction_720 +happyReduction_720 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn16 + (happy_var_1 + ) +happyReduction_720 _ = notHappyAtAll + +happyReduce_721 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_721 = happySpecReduce_1 273# happyReduction_721 +happyReduction_721 (HappyTerminal happy_var_1) + = HappyAbsSyn16 + (sL1 happy_var_1 $! mkUnqual tcClsName (getCONSYM happy_var_1) + ) +happyReduction_721 _ = notHappyAtAll + +happyReduce_722 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_722 = happySpecReduce_1 273# happyReduction_722 +happyReduction_722 (HappyTerminal happy_var_1) + = HappyAbsSyn16 + (sL1 happy_var_1 $! mkUnqual tcClsName (getVARSYM happy_var_1) + ) +happyReduction_722 _ = notHappyAtAll + +happyReduce_723 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_723 = happySpecReduce_1 273# happyReduction_723 +happyReduction_723 (HappyTerminal happy_var_1) + = HappyAbsSyn16 + (sL1 happy_var_1 $! consDataCon_RDR + ) +happyReduction_723 _ = notHappyAtAll + +happyReduce_724 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_724 = happySpecReduce_1 273# happyReduction_724 +happyReduction_724 (HappyTerminal happy_var_1) + = HappyAbsSyn16 + (sL1 happy_var_1 $! mkUnqual tcClsName (fsLit "-") + ) +happyReduction_724 _ = notHappyAtAll + +happyReduce_725 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_725 = happySpecReduce_1 273# happyReduction_725 +happyReduction_725 (HappyTerminal happy_var_1) + = HappyAbsSyn16 + (sL1 happy_var_1 $! mkUnqual tcClsName (fsLit "!") + ) +happyReduction_725 _ = notHappyAtAll + +happyReduce_726 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_726 = happySpecReduce_1 273# happyReduction_726 +happyReduction_726 (HappyTerminal happy_var_1) + = HappyAbsSyn16 + (sL1 happy_var_1 $! mkUnqual tcClsName (fsLit ".") + ) +happyReduction_726 _ = notHappyAtAll + +happyReduce_727 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_727 = happySpecReduce_1 273# happyReduction_727 +happyReduction_727 (HappyTerminal happy_var_1) + = HappyAbsSyn16 + (sL1 happy_var_1 $ eqTyCon_RDR + ) +happyReduction_727 _ = notHappyAtAll + +happyReduce_728 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_728 = happySpecReduce_1 274# happyReduction_728 +happyReduction_728 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn16 + (happy_var_1 + ) +happyReduction_728 _ = notHappyAtAll + +happyReduce_729 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_729 = happySpecReduce_1 274# happyReduction_729 +happyReduction_729 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn16 + (happy_var_1 + ) +happyReduction_729 _ = notHappyAtAll + +happyReduce_730 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_730 = happySpecReduce_1 274# happyReduction_730 +happyReduction_730 (HappyTerminal happy_var_1) + = HappyAbsSyn16 + (sL1 happy_var_1 $ getRdrName funTyCon + ) +happyReduction_730 _ = notHappyAtAll + +happyReduce_731 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_731 = happySpecReduce_1 274# happyReduction_731 +happyReduction_731 (HappyTerminal happy_var_1) + = HappyAbsSyn16 + (sL1 happy_var_1 $ eqTyCon_RDR + ) +happyReduction_731 _ = notHappyAtAll + +happyReduce_732 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_732 = happySpecReduce_1 275# happyReduction_732 +happyReduction_732 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn16 + (happy_var_1 + ) +happyReduction_732 _ = notHappyAtAll + +happyReduce_733 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_733 = happyMonadReduce 3# 275# happyReduction_733 +happyReduction_733 ((HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn16 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + [mj AnnBackquote happy_var_1,mj AnnVal happy_var_2 + ,mj AnnBackquote happy_var_3])) + ) (\r -> happyReturn (HappyAbsSyn16 r)) + +happyReduce_734 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_734 = happySpecReduce_1 276# happyReduction_734 +happyReduction_734 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn209 + (sL1 happy_var_1 $ HsVar noExt happy_var_1 + ) +happyReduction_734 _ = notHappyAtAll + +happyReduce_735 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_735 = happySpecReduce_1 276# happyReduction_735 +happyReduction_735 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn209 + (sL1 happy_var_1 $ HsVar noExt happy_var_1 + ) +happyReduction_735 _ = notHappyAtAll + +happyReduce_736 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_736 = happySpecReduce_1 276# happyReduction_736 +happyReduction_736 (HappyAbsSyn209 happy_var_1) + = HappyAbsSyn209 + (happy_var_1 + ) +happyReduction_736 _ = notHappyAtAll + +happyReduce_737 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_737 = happySpecReduce_1 277# happyReduction_737 +happyReduction_737 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn209 + (sL1 happy_var_1 $ HsVar noExt happy_var_1 + ) +happyReduction_737 _ = notHappyAtAll + +happyReduce_738 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_738 = happySpecReduce_1 277# happyReduction_738 +happyReduction_738 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn209 + (sL1 happy_var_1 $ HsVar noExt happy_var_1 + ) +happyReduction_738 _ = notHappyAtAll + +happyReduce_739 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_739 = happySpecReduce_1 277# happyReduction_739 +happyReduction_739 (HappyAbsSyn209 happy_var_1) + = HappyAbsSyn209 + (happy_var_1 + ) +happyReduction_739 _ = notHappyAtAll + +happyReduce_740 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_740 = happyMonadReduce 3# 278# happyReduction_740 +happyReduction_740 ((HappyTerminal happy_var_3) `HappyStk` + (HappyTerminal happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_3 $ EWildPat noExt) + [mj AnnBackquote happy_var_1,mj AnnVal happy_var_2 + ,mj AnnBackquote happy_var_3])) + ) (\r -> happyReturn (HappyAbsSyn209 r)) + +happyReduce_741 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_741 = happySpecReduce_1 279# happyReduction_741 +happyReduction_741 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn16 + (happy_var_1 + ) +happyReduction_741 _ = notHappyAtAll + +happyReduce_742 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_742 = happyMonadReduce 3# 279# happyReduction_742 +happyReduction_742 ((HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn16 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + [mj AnnBackquote happy_var_1,mj AnnVal happy_var_2 + ,mj AnnBackquote happy_var_3])) + ) (\r -> happyReturn (HappyAbsSyn16 r)) + +happyReduce_743 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_743 = happySpecReduce_1 280# happyReduction_743 +happyReduction_743 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn16 + (happy_var_1 + ) +happyReduction_743 _ = notHappyAtAll + +happyReduce_744 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_744 = happyMonadReduce 3# 280# happyReduction_744 +happyReduction_744 ((HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn16 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + [mj AnnBackquote happy_var_1,mj AnnVal happy_var_2 + ,mj AnnBackquote happy_var_3])) + ) (\r -> happyReturn (HappyAbsSyn16 r)) + +happyReduce_745 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_745 = happySpecReduce_1 281# happyReduction_745 +happyReduction_745 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn16 + (happy_var_1 + ) +happyReduction_745 _ = notHappyAtAll + +happyReduce_746 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_746 = happyMonadReduce 3# 282# happyReduction_746 +happyReduction_746 ((HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn16 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + [mj AnnBackquote happy_var_1,mj AnnVal happy_var_2 + ,mj AnnBackquote happy_var_3])) + ) (\r -> happyReturn (HappyAbsSyn16 r)) + +happyReduce_747 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_747 = happySpecReduce_1 283# happyReduction_747 +happyReduction_747 (HappyTerminal happy_var_1) + = HappyAbsSyn16 + (sL1 happy_var_1 $! mkUnqual tvName (getVARID happy_var_1) + ) +happyReduction_747 _ = notHappyAtAll + +happyReduce_748 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_748 = happySpecReduce_1 283# happyReduction_748 +happyReduction_748 (HappyAbsSyn25 happy_var_1) + = HappyAbsSyn16 + (sL1 happy_var_1 $! mkUnqual tvName (unLoc happy_var_1) + ) +happyReduction_748 _ = notHappyAtAll + +happyReduce_749 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_749 = happySpecReduce_1 283# happyReduction_749 +happyReduction_749 (HappyTerminal happy_var_1) + = HappyAbsSyn16 + (sL1 happy_var_1 $! mkUnqual tvName (fsLit "unsafe") + ) +happyReduction_749 _ = notHappyAtAll + +happyReduce_750 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_750 = happySpecReduce_1 283# happyReduction_750 +happyReduction_750 (HappyTerminal happy_var_1) + = HappyAbsSyn16 + (sL1 happy_var_1 $! mkUnqual tvName (fsLit "safe") + ) +happyReduction_750 _ = notHappyAtAll + +happyReduce_751 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_751 = happySpecReduce_1 283# happyReduction_751 +happyReduction_751 (HappyTerminal happy_var_1) + = HappyAbsSyn16 + (sL1 happy_var_1 $! mkUnqual tvName (fsLit "interruptible") + ) +happyReduction_751 _ = notHappyAtAll + +happyReduce_752 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_752 = happySpecReduce_1 284# happyReduction_752 +happyReduction_752 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn16 + (happy_var_1 + ) +happyReduction_752 _ = notHappyAtAll + +happyReduce_753 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_753 = happyMonadReduce 3# 284# happyReduction_753 +happyReduction_753 ((HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn16 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + [mop happy_var_1,mj AnnVal happy_var_2,mcp happy_var_3])) + ) (\r -> happyReturn (HappyAbsSyn16 r)) + +happyReduce_754 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_754 = happySpecReduce_1 285# happyReduction_754 +happyReduction_754 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn16 + (happy_var_1 + ) +happyReduction_754 _ = notHappyAtAll + +happyReduce_755 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_755 = happyMonadReduce 3# 285# happyReduction_755 +happyReduction_755 ((HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn16 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + [mop happy_var_1,mj AnnVal happy_var_2,mcp happy_var_3])) + ) (\r -> happyReturn (HappyAbsSyn16 r)) + +happyReduce_756 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_756 = happyMonadReduce 3# 285# happyReduction_756 +happyReduction_756 ((HappyTerminal happy_var_3) `HappyStk` + (HappyAbsSyn16 happy_var_2) `HappyStk` + (HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sLL happy_var_1 happy_var_3 (unLoc happy_var_2)) + [mop happy_var_1,mj AnnVal happy_var_2,mcp happy_var_3])) + ) (\r -> happyReturn (HappyAbsSyn16 r)) + +happyReduce_757 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_757 = happySpecReduce_1 286# happyReduction_757 +happyReduction_757 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn16 + (happy_var_1 + ) +happyReduction_757 _ = notHappyAtAll + +happyReduce_758 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_758 = happySpecReduce_1 286# happyReduction_758 +happyReduction_758 (HappyTerminal happy_var_1) + = HappyAbsSyn16 + (sL1 happy_var_1 $! mkQual varName (getQVARID happy_var_1) + ) +happyReduction_758 _ = notHappyAtAll + +happyReduce_759 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_759 = happySpecReduce_1 287# happyReduction_759 +happyReduction_759 (HappyTerminal happy_var_1) + = HappyAbsSyn16 + (sL1 happy_var_1 $! mkUnqual varName (getVARID happy_var_1) + ) +happyReduction_759 _ = notHappyAtAll + +happyReduce_760 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_760 = happySpecReduce_1 287# happyReduction_760 +happyReduction_760 (HappyAbsSyn25 happy_var_1) + = HappyAbsSyn16 + (sL1 happy_var_1 $! mkUnqual varName (unLoc happy_var_1) + ) +happyReduction_760 _ = notHappyAtAll + +happyReduce_761 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_761 = happySpecReduce_1 287# happyReduction_761 +happyReduction_761 (HappyTerminal happy_var_1) + = HappyAbsSyn16 + (sL1 happy_var_1 $! mkUnqual varName (fsLit "unsafe") + ) +happyReduction_761 _ = notHappyAtAll + +happyReduce_762 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_762 = happySpecReduce_1 287# happyReduction_762 +happyReduction_762 (HappyTerminal happy_var_1) + = HappyAbsSyn16 + (sL1 happy_var_1 $! mkUnqual varName (fsLit "safe") + ) +happyReduction_762 _ = notHappyAtAll + +happyReduce_763 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_763 = happySpecReduce_1 287# happyReduction_763 +happyReduction_763 (HappyTerminal happy_var_1) + = HappyAbsSyn16 + (sL1 happy_var_1 $! mkUnqual varName (fsLit "interruptible") + ) +happyReduction_763 _ = notHappyAtAll + +happyReduce_764 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_764 = happySpecReduce_1 287# happyReduction_764 +happyReduction_764 (HappyTerminal happy_var_1) + = HappyAbsSyn16 + (sL1 happy_var_1 $! mkUnqual varName (fsLit "forall") + ) +happyReduction_764 _ = notHappyAtAll + +happyReduce_765 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_765 = happySpecReduce_1 287# happyReduction_765 +happyReduction_765 (HappyTerminal happy_var_1) + = HappyAbsSyn16 + (sL1 happy_var_1 $! mkUnqual varName (fsLit "family") + ) +happyReduction_765 _ = notHappyAtAll + +happyReduce_766 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_766 = happySpecReduce_1 287# happyReduction_766 +happyReduction_766 (HappyTerminal happy_var_1) + = HappyAbsSyn16 + (sL1 happy_var_1 $! mkUnqual varName (fsLit "role") + ) +happyReduction_766 _ = notHappyAtAll + +happyReduce_767 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_767 = happySpecReduce_1 288# happyReduction_767 +happyReduction_767 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn16 + (happy_var_1 + ) +happyReduction_767 _ = notHappyAtAll + +happyReduce_768 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_768 = happySpecReduce_1 288# happyReduction_768 +happyReduction_768 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn16 + (happy_var_1 + ) +happyReduction_768 _ = notHappyAtAll + +happyReduce_769 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_769 = happySpecReduce_1 289# happyReduction_769 +happyReduction_769 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn16 + (happy_var_1 + ) +happyReduction_769 _ = notHappyAtAll + +happyReduce_770 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_770 = happySpecReduce_1 289# happyReduction_770 +happyReduction_770 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn16 + (happy_var_1 + ) +happyReduction_770 _ = notHappyAtAll + +happyReduce_771 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_771 = happySpecReduce_1 290# happyReduction_771 +happyReduction_771 (HappyTerminal happy_var_1) + = HappyAbsSyn16 + (sL1 happy_var_1 $ mkQual varName (getQVARSYM happy_var_1) + ) +happyReduction_771 _ = notHappyAtAll + +happyReduce_772 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_772 = happySpecReduce_1 291# happyReduction_772 +happyReduction_772 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn16 + (happy_var_1 + ) +happyReduction_772 _ = notHappyAtAll + +happyReduce_773 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_773 = happySpecReduce_1 291# happyReduction_773 +happyReduction_773 (HappyTerminal happy_var_1) + = HappyAbsSyn16 + (sL1 happy_var_1 $ mkUnqual varName (fsLit "-") + ) +happyReduction_773 _ = notHappyAtAll + +happyReduce_774 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_774 = happySpecReduce_1 292# happyReduction_774 +happyReduction_774 (HappyTerminal happy_var_1) + = HappyAbsSyn16 + (sL1 happy_var_1 $ mkUnqual varName (getVARSYM happy_var_1) + ) +happyReduction_774 _ = notHappyAtAll + +happyReduce_775 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_775 = happySpecReduce_1 292# happyReduction_775 +happyReduction_775 (HappyAbsSyn25 happy_var_1) + = HappyAbsSyn16 + (sL1 happy_var_1 $ mkUnqual varName (unLoc happy_var_1) + ) +happyReduction_775 _ = notHappyAtAll + +happyReduce_776 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_776 = happySpecReduce_1 293# happyReduction_776 +happyReduction_776 (HappyTerminal happy_var_1) + = HappyAbsSyn25 + (sL1 happy_var_1 (fsLit "as") + ) +happyReduction_776 _ = notHappyAtAll + +happyReduce_777 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_777 = happySpecReduce_1 293# happyReduction_777 +happyReduction_777 (HappyTerminal happy_var_1) + = HappyAbsSyn25 + (sL1 happy_var_1 (fsLit "qualified") + ) +happyReduction_777 _ = notHappyAtAll + +happyReduce_778 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_778 = happySpecReduce_1 293# happyReduction_778 +happyReduction_778 (HappyTerminal happy_var_1) + = HappyAbsSyn25 + (sL1 happy_var_1 (fsLit "hiding") + ) +happyReduction_778 _ = notHappyAtAll + +happyReduce_779 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_779 = happySpecReduce_1 293# happyReduction_779 +happyReduction_779 (HappyTerminal happy_var_1) + = HappyAbsSyn25 + (sL1 happy_var_1 (fsLit "export") + ) +happyReduction_779 _ = notHappyAtAll + +happyReduce_780 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_780 = happySpecReduce_1 293# happyReduction_780 +happyReduction_780 (HappyTerminal happy_var_1) + = HappyAbsSyn25 + (sL1 happy_var_1 (fsLit "label") + ) +happyReduction_780 _ = notHappyAtAll + +happyReduce_781 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_781 = happySpecReduce_1 293# happyReduction_781 +happyReduction_781 (HappyTerminal happy_var_1) + = HappyAbsSyn25 + (sL1 happy_var_1 (fsLit "dynamic") + ) +happyReduction_781 _ = notHappyAtAll + +happyReduce_782 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_782 = happySpecReduce_1 293# happyReduction_782 +happyReduction_782 (HappyTerminal happy_var_1) + = HappyAbsSyn25 + (sL1 happy_var_1 (fsLit "stdcall") + ) +happyReduction_782 _ = notHappyAtAll + +happyReduce_783 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_783 = happySpecReduce_1 293# happyReduction_783 +happyReduction_783 (HappyTerminal happy_var_1) + = HappyAbsSyn25 + (sL1 happy_var_1 (fsLit "ccall") + ) +happyReduction_783 _ = notHappyAtAll + +happyReduce_784 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_784 = happySpecReduce_1 293# happyReduction_784 +happyReduction_784 (HappyTerminal happy_var_1) + = HappyAbsSyn25 + (sL1 happy_var_1 (fsLit "capi") + ) +happyReduction_784 _ = notHappyAtAll + +happyReduce_785 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_785 = happySpecReduce_1 293# happyReduction_785 +happyReduction_785 (HappyTerminal happy_var_1) + = HappyAbsSyn25 + (sL1 happy_var_1 (fsLit "prim") + ) +happyReduction_785 _ = notHappyAtAll + +happyReduce_786 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_786 = happySpecReduce_1 293# happyReduction_786 +happyReduction_786 (HappyTerminal happy_var_1) + = HappyAbsSyn25 + (sL1 happy_var_1 (fsLit "javascript") + ) +happyReduction_786 _ = notHappyAtAll + +happyReduce_787 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_787 = happySpecReduce_1 293# happyReduction_787 +happyReduction_787 (HappyTerminal happy_var_1) + = HappyAbsSyn25 + (sL1 happy_var_1 (fsLit "group") + ) +happyReduction_787 _ = notHappyAtAll + +happyReduce_788 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_788 = happySpecReduce_1 293# happyReduction_788 +happyReduction_788 (HappyTerminal happy_var_1) + = HappyAbsSyn25 + (sL1 happy_var_1 (fsLit "stock") + ) +happyReduction_788 _ = notHappyAtAll + +happyReduce_789 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_789 = happySpecReduce_1 293# happyReduction_789 +happyReduction_789 (HappyTerminal happy_var_1) + = HappyAbsSyn25 + (sL1 happy_var_1 (fsLit "anyclass") + ) +happyReduction_789 _ = notHappyAtAll + +happyReduce_790 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_790 = happySpecReduce_1 293# happyReduction_790 +happyReduction_790 (HappyTerminal happy_var_1) + = HappyAbsSyn25 + (sL1 happy_var_1 (fsLit "via") + ) +happyReduction_790 _ = notHappyAtAll + +happyReduce_791 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_791 = happySpecReduce_1 293# happyReduction_791 +happyReduction_791 (HappyTerminal happy_var_1) + = HappyAbsSyn25 + (sL1 happy_var_1 (fsLit "unit") + ) +happyReduction_791 _ = notHappyAtAll + +happyReduce_792 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_792 = happySpecReduce_1 293# happyReduction_792 +happyReduction_792 (HappyTerminal happy_var_1) + = HappyAbsSyn25 + (sL1 happy_var_1 (fsLit "dependency") + ) +happyReduction_792 _ = notHappyAtAll + +happyReduce_793 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_793 = happySpecReduce_1 293# happyReduction_793 +happyReduction_793 (HappyTerminal happy_var_1) + = HappyAbsSyn25 + (sL1 happy_var_1 (fsLit "signature") + ) +happyReduction_793 _ = notHappyAtAll + +happyReduce_794 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_794 = happyMonadReduce 1# 294# happyReduction_794 +happyReduction_794 ((HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( ams (sL1 happy_var_1 (fsLit "!")) [mj AnnBang happy_var_1])) + ) (\r -> happyReturn (HappyAbsSyn25 r)) + +happyReduce_795 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_795 = happySpecReduce_1 294# happyReduction_795 +happyReduction_795 (HappyTerminal happy_var_1) + = HappyAbsSyn25 + (sL1 happy_var_1 (fsLit ".") + ) +happyReduction_795 _ = notHappyAtAll + +happyReduce_796 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_796 = happySpecReduce_1 294# happyReduction_796 +happyReduction_796 (HappyTerminal happy_var_1) + = HappyAbsSyn25 + (sL1 happy_var_1 (fsLit (starSym (isUnicode happy_var_1))) + ) +happyReduction_796 _ = notHappyAtAll + +happyReduce_797 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_797 = happySpecReduce_1 295# happyReduction_797 +happyReduction_797 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn16 + (happy_var_1 + ) +happyReduction_797 _ = notHappyAtAll + +happyReduce_798 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_798 = happySpecReduce_1 295# happyReduction_798 +happyReduction_798 (HappyTerminal happy_var_1) + = HappyAbsSyn16 + (sL1 happy_var_1 $! mkQual dataName (getQCONID happy_var_1) + ) +happyReduction_798 _ = notHappyAtAll + +happyReduce_799 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_799 = happySpecReduce_1 296# happyReduction_799 +happyReduction_799 (HappyTerminal happy_var_1) + = HappyAbsSyn16 + (sL1 happy_var_1 $ mkUnqual dataName (getCONID happy_var_1) + ) +happyReduction_799 _ = notHappyAtAll + +happyReduce_800 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_800 = happySpecReduce_1 297# happyReduction_800 +happyReduction_800 (HappyAbsSyn16 happy_var_1) + = HappyAbsSyn16 + (happy_var_1 + ) +happyReduction_800 _ = notHappyAtAll + +happyReduce_801 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_801 = happySpecReduce_1 297# happyReduction_801 +happyReduction_801 (HappyTerminal happy_var_1) + = HappyAbsSyn16 + (sL1 happy_var_1 $ mkQual dataName (getQCONSYM happy_var_1) + ) +happyReduction_801 _ = notHappyAtAll + +happyReduce_802 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_802 = happySpecReduce_1 298# happyReduction_802 +happyReduction_802 (HappyTerminal happy_var_1) + = HappyAbsSyn16 + (sL1 happy_var_1 $ mkUnqual dataName (getCONSYM happy_var_1) + ) +happyReduction_802 _ = notHappyAtAll + +happyReduce_803 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_803 = happySpecReduce_1 298# happyReduction_803 +happyReduction_803 (HappyTerminal happy_var_1) + = HappyAbsSyn16 + (sL1 happy_var_1 $ consDataCon_RDR + ) +happyReduction_803 _ = notHappyAtAll + +happyReduce_804 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_804 = happySpecReduce_1 299# happyReduction_804 +happyReduction_804 (HappyTerminal happy_var_1) + = HappyAbsSyn315 + (sL1 happy_var_1 $ HsChar (getCHARs happy_var_1) $ getCHAR happy_var_1 + ) +happyReduction_804 _ = notHappyAtAll + +happyReduce_805 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_805 = happySpecReduce_1 299# happyReduction_805 +happyReduction_805 (HappyTerminal happy_var_1) + = HappyAbsSyn315 + (sL1 happy_var_1 $ HsString (getSTRINGs happy_var_1) + $ getSTRING happy_var_1 + ) +happyReduction_805 _ = notHappyAtAll + +happyReduce_806 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_806 = happySpecReduce_1 299# happyReduction_806 +happyReduction_806 (HappyTerminal happy_var_1) + = HappyAbsSyn315 + (sL1 happy_var_1 $ HsIntPrim (getPRIMINTEGERs happy_var_1) + $ getPRIMINTEGER happy_var_1 + ) +happyReduction_806 _ = notHappyAtAll + +happyReduce_807 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_807 = happySpecReduce_1 299# happyReduction_807 +happyReduction_807 (HappyTerminal happy_var_1) + = HappyAbsSyn315 + (sL1 happy_var_1 $ HsWordPrim (getPRIMWORDs happy_var_1) + $ getPRIMWORD happy_var_1 + ) +happyReduction_807 _ = notHappyAtAll + +happyReduce_808 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_808 = happySpecReduce_1 299# happyReduction_808 +happyReduction_808 (HappyTerminal happy_var_1) + = HappyAbsSyn315 + (sL1 happy_var_1 $ HsCharPrim (getPRIMCHARs happy_var_1) + $ getPRIMCHAR happy_var_1 + ) +happyReduction_808 _ = notHappyAtAll + +happyReduce_809 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_809 = happySpecReduce_1 299# happyReduction_809 +happyReduction_809 (HappyTerminal happy_var_1) + = HappyAbsSyn315 + (sL1 happy_var_1 $ HsStringPrim (getPRIMSTRINGs happy_var_1) + $ getPRIMSTRING happy_var_1 + ) +happyReduction_809 _ = notHappyAtAll + +happyReduce_810 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_810 = happySpecReduce_1 299# happyReduction_810 +happyReduction_810 (HappyTerminal happy_var_1) + = HappyAbsSyn315 + (sL1 happy_var_1 $ HsFloatPrim noExt $ getPRIMFLOAT happy_var_1 + ) +happyReduction_810 _ = notHappyAtAll + +happyReduce_811 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_811 = happySpecReduce_1 299# happyReduction_811 +happyReduction_811 (HappyTerminal happy_var_1) + = HappyAbsSyn315 + (sL1 happy_var_1 $ HsDoublePrim noExt $ getPRIMDOUBLE happy_var_1 + ) +happyReduction_811 _ = notHappyAtAll + +happyReduce_812 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_812 = happySpecReduce_1 300# happyReduction_812 +happyReduction_812 _ + = HappyAbsSyn36 + (() + ) + +happyReduce_813 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_813 = happyMonadReduce 1# 300# happyReduction_813 +happyReduction_813 (_ `HappyStk` + happyRest) tk + = happyThen ((( popContext)) + ) (\r -> happyReturn (HappyAbsSyn36 r)) + +happyReduce_814 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_814 = happySpecReduce_1 301# happyReduction_814 +happyReduction_814 (HappyTerminal happy_var_1) + = HappyAbsSyn317 + (sL1 happy_var_1 $ mkModuleNameFS (getCONID happy_var_1) + ) +happyReduction_814 _ = notHappyAtAll + +happyReduce_815 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_815 = happySpecReduce_1 301# happyReduction_815 +happyReduction_815 (HappyTerminal happy_var_1) + = HappyAbsSyn317 + (sL1 happy_var_1 $ let (mod,c) = getQCONID happy_var_1 in + mkModuleNameFS + (mkFastString + (unpackFS mod ++ '.':unpackFS c)) + ) +happyReduction_815 _ = notHappyAtAll + +happyReduce_816 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_816 = happySpecReduce_2 302# happyReduction_816 +happyReduction_816 (HappyTerminal happy_var_2) + (HappyAbsSyn318 happy_var_1) + = HappyAbsSyn318 + (((fst happy_var_1)++[gl happy_var_2],snd happy_var_1 + 1) + ) +happyReduction_816 _ _ = notHappyAtAll + +happyReduce_817 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_817 = happySpecReduce_1 302# happyReduction_817 +happyReduction_817 (HappyTerminal happy_var_1) + = HappyAbsSyn318 + (([gl happy_var_1],1) + ) +happyReduction_817 _ = notHappyAtAll + +happyReduce_818 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_818 = happySpecReduce_1 303# happyReduction_818 +happyReduction_818 (HappyAbsSyn318 happy_var_1) + = HappyAbsSyn318 + (happy_var_1 + ) +happyReduction_818 _ = notHappyAtAll + +happyReduce_819 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_819 = happySpecReduce_0 303# happyReduction_819 +happyReduction_819 = HappyAbsSyn318 + (([], 0) + ) + +happyReduce_820 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_820 = happySpecReduce_2 304# happyReduction_820 +happyReduction_820 (HappyTerminal happy_var_2) + (HappyAbsSyn318 happy_var_1) + = HappyAbsSyn318 + (((fst happy_var_1)++[gl happy_var_2],snd happy_var_1 + 1) + ) +happyReduction_820 _ _ = notHappyAtAll + +happyReduce_821 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_821 = happySpecReduce_1 304# happyReduction_821 +happyReduction_821 (HappyTerminal happy_var_1) + = HappyAbsSyn318 + (([gl happy_var_1],1) + ) +happyReduction_821 _ = notHappyAtAll + +happyReduce_822 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_822 = happyMonadReduce 1# 305# happyReduction_822 +happyReduction_822 ((HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( return (sL1 happy_var_1 (mkHsDocString (getDOCNEXT happy_var_1))))) + ) (\r -> happyReturn (HappyAbsSyn321 r)) + +happyReduce_823 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_823 = happyMonadReduce 1# 306# happyReduction_823 +happyReduction_823 ((HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( return (sL1 happy_var_1 (mkHsDocString (getDOCPREV happy_var_1))))) + ) (\r -> happyReturn (HappyAbsSyn321 r)) + +happyReduce_824 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_824 = happyMonadReduce 1# 307# happyReduction_824 +happyReduction_824 ((HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( + let string = getDOCNAMED happy_var_1 + (name, rest) = break isSpace string + in return (sL1 happy_var_1 (name, mkHsDocString rest)))) + ) (\r -> happyReturn (HappyAbsSyn323 r)) + +happyReduce_825 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_825 = happyMonadReduce 1# 308# happyReduction_825 +happyReduction_825 ((HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( let (n, doc) = getDOCSECTION happy_var_1 in + return (sL1 happy_var_1 (n, mkHsDocString doc)))) + ) (\r -> happyReturn (HappyAbsSyn324 r)) + +happyReduce_826 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_826 = happyMonadReduce 1# 309# happyReduction_826 +happyReduction_826 ((HappyTerminal happy_var_1) `HappyStk` + happyRest) tk + = happyThen ((( let string = getDOCNEXT happy_var_1 in + return (Just (sL1 happy_var_1 (mkHsDocString string))))) + ) (\r -> happyReturn (HappyAbsSyn35 r)) + +happyReduce_827 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_827 = happySpecReduce_1 310# happyReduction_827 +happyReduction_827 (HappyAbsSyn321 happy_var_1) + = HappyAbsSyn35 + (Just happy_var_1 + ) +happyReduction_827 _ = notHappyAtAll + +happyReduce_828 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_828 = happySpecReduce_0 310# happyReduction_828 +happyReduction_828 = HappyAbsSyn35 + (Nothing + ) + +happyReduce_829 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_829 = happySpecReduce_1 311# happyReduction_829 +happyReduction_829 (HappyAbsSyn321 happy_var_1) + = HappyAbsSyn35 + (Just happy_var_1 + ) +happyReduction_829 _ = notHappyAtAll + +happyReduce_830 :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) +happyReduce_830 = happySpecReduce_0 311# happyReduction_830 +happyReduction_830 = HappyAbsSyn35 + (Nothing + ) + +happyNewToken action sts stk + = (lexer True)(\tk -> + let cont i = happyDoAction i tk action sts stk in + case tk of { + L _ ITeof -> happyDoAction 153# tk action sts stk; + L _ ITunderscore -> cont 1#; + L _ ITas -> cont 2#; + L _ ITcase -> cont 3#; + L _ ITclass -> cont 4#; + L _ ITdata -> cont 5#; + L _ ITdefault -> cont 6#; + L _ ITderiving -> cont 7#; + L _ ITdo -> cont 8#; + L _ ITelse -> cont 9#; + L _ IThiding -> cont 10#; + L _ ITif -> cont 11#; + L _ ITimport -> cont 12#; + L _ ITin -> cont 13#; + L _ ITinfix -> cont 14#; + L _ ITinfixl -> cont 15#; + L _ ITinfixr -> cont 16#; + L _ ITinstance -> cont 17#; + L _ ITlet -> cont 18#; + L _ ITmodule -> cont 19#; + L _ ITnewtype -> cont 20#; + L _ ITof -> cont 21#; + L _ ITqualified -> cont 22#; + L _ ITthen -> cont 23#; + L _ ITtype -> cont 24#; + L _ ITwhere -> cont 25#; + L _ (ITforall _) -> cont 26#; + L _ ITforeign -> cont 27#; + L _ ITexport -> cont 28#; + L _ ITlabel -> cont 29#; + L _ ITdynamic -> cont 30#; + L _ ITsafe -> cont 31#; + L _ ITinterruptible -> cont 32#; + L _ ITunsafe -> cont 33#; + L _ ITmdo -> cont 34#; + L _ ITfamily -> cont 35#; + L _ ITrole -> cont 36#; + L _ ITstdcallconv -> cont 37#; + L _ ITccallconv -> cont 38#; + L _ ITcapiconv -> cont 39#; + L _ ITprimcallconv -> cont 40#; + L _ ITjavascriptcallconv -> cont 41#; + L _ ITproc -> cont 42#; + L _ ITrec -> cont 43#; + L _ ITgroup -> cont 44#; + L _ ITby -> cont 45#; + L _ ITusing -> cont 46#; + L _ ITpattern -> cont 47#; + L _ ITstatic -> cont 48#; + L _ ITstock -> cont 49#; + L _ ITanyclass -> cont 50#; + L _ ITvia -> cont 51#; + L _ ITunit -> cont 52#; + L _ ITsignature -> cont 53#; + L _ ITdependency -> cont 54#; + L _ (ITinline_prag _ _ _) -> cont 55#; + L _ (ITspec_prag _) -> cont 56#; + L _ (ITspec_inline_prag _ _) -> cont 57#; + L _ (ITsource_prag _) -> cont 58#; + L _ (ITrules_prag _) -> cont 59#; + L _ (ITcore_prag _) -> cont 60#; + L _ (ITscc_prag _) -> cont 61#; + L _ (ITgenerated_prag _) -> cont 62#; + L _ (ITdeprecated_prag _) -> cont 63#; + L _ (ITwarning_prag _) -> cont 64#; + L _ (ITunpack_prag _) -> cont 65#; + L _ (ITnounpack_prag _) -> cont 66#; + L _ (ITann_prag _) -> cont 67#; + L _ (ITminimal_prag _) -> cont 68#; + L _ (ITctype _) -> cont 69#; + L _ (IToverlapping_prag _) -> cont 70#; + L _ (IToverlappable_prag _) -> cont 71#; + L _ (IToverlaps_prag _) -> cont 72#; + L _ (ITincoherent_prag _) -> cont 73#; + L _ (ITcomplete_prag _) -> cont 74#; + L _ ITclose_prag -> cont 75#; + L _ ITdotdot -> cont 76#; + L _ ITcolon -> cont 77#; + L _ (ITdcolon _) -> cont 78#; + L _ ITequal -> cont 79#; + L _ ITlam -> cont 80#; + L _ ITlcase -> cont 81#; + L _ ITvbar -> cont 82#; + L _ (ITlarrow _) -> cont 83#; + L _ (ITrarrow _) -> cont 84#; + L _ ITat -> cont 85#; + L _ ITtilde -> cont 86#; + L _ (ITdarrow _) -> cont 87#; + L _ ITminus -> cont 88#; + L _ ITbang -> cont 89#; + L _ (ITstar _) -> cont 90#; + L _ (ITlarrowtail _) -> cont 91#; + L _ (ITrarrowtail _) -> cont 92#; + L _ (ITLarrowtail _) -> cont 93#; + L _ (ITRarrowtail _) -> cont 94#; + L _ ITdot -> cont 95#; + L _ ITtypeApp -> cont 96#; + L _ ITocurly -> cont 97#; + L _ ITccurly -> cont 98#; + L _ ITvocurly -> cont 99#; + L _ ITvccurly -> cont 100#; + L _ ITobrack -> cont 101#; + L _ ITcbrack -> cont 102#; + L _ ITopabrack -> cont 103#; + L _ ITcpabrack -> cont 104#; + L _ IToparen -> cont 105#; + L _ ITcparen -> cont 106#; + L _ IToubxparen -> cont 107#; + L _ ITcubxparen -> cont 108#; + L _ (IToparenbar _) -> cont 109#; + L _ (ITcparenbar _) -> cont 110#; + L _ ITsemi -> cont 111#; + L _ ITcomma -> cont 112#; + L _ ITbackquote -> cont 113#; + L _ ITsimpleQuote -> cont 114#; + L _ (ITvarid _) -> cont 115#; + L _ (ITconid _) -> cont 116#; + L _ (ITvarsym _) -> cont 117#; + L _ (ITconsym _) -> cont 118#; + L _ (ITqvarid _) -> cont 119#; + L _ (ITqconid _) -> cont 120#; + L _ (ITqvarsym _) -> cont 121#; + L _ (ITqconsym _) -> cont 122#; + L _ (ITdupipvarid _) -> cont 123#; + L _ (ITlabelvarid _) -> cont 124#; + L _ (ITchar _ _) -> cont 125#; + L _ (ITstring _ _) -> cont 126#; + L _ (ITinteger _) -> cont 127#; + L _ (ITrational _) -> cont 128#; + L _ (ITprimchar _ _) -> cont 129#; + L _ (ITprimstring _ _) -> cont 130#; + L _ (ITprimint _ _) -> cont 131#; + L _ (ITprimword _ _) -> cont 132#; + L _ (ITprimfloat _) -> cont 133#; + L _ (ITprimdouble _) -> cont 134#; + L _ (ITdocCommentNext _) -> cont 135#; + L _ (ITdocCommentPrev _) -> cont 136#; + L _ (ITdocCommentNamed _) -> cont 137#; + L _ (ITdocSection _ _) -> cont 138#; + L _ (ITopenExpQuote _ _) -> cont 139#; + L _ ITopenPatQuote -> cont 140#; + L _ ITopenTypQuote -> cont 141#; + L _ ITopenDecQuote -> cont 142#; + L _ (ITcloseQuote _) -> cont 143#; + L _ (ITopenTExpQuote _) -> cont 144#; + L _ ITcloseTExpQuote -> cont 145#; + L _ (ITidEscape _) -> cont 146#; + L _ ITparenEscape -> cont 147#; + L _ (ITidTyEscape _) -> cont 148#; + L _ ITparenTyEscape -> cont 149#; + L _ ITtyQuote -> cont 150#; + L _ (ITquasiQuote _) -> cont 151#; + L _ (ITqQuasiQuote _) -> cont 152#; + _ -> happyError' (tk, []) + }) + +happyError_ explist 153# tk = happyError' (tk, explist) +happyError_ explist _ tk = happyError' (tk, explist) + +happyThen :: () => P a -> (a -> P b) -> P b +happyThen = (>>=) +happyReturn :: () => a -> P a +happyReturn = (return) +happyParse :: () => Happy_GHC_Exts.Int# -> P (HappyAbsSyn ) + +happyNewToken :: () => Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) + +happyDoAction :: () => Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn ) + +happyReduceArr :: () => Happy_Data_Array.Array Int (Happy_GHC_Exts.Int# -> (Located Token) -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> P (HappyAbsSyn )) + +happyThen1 :: () => P a -> (a -> P b) -> P b +happyThen1 = happyThen +happyReturn1 :: () => a -> P a +happyReturn1 = happyReturn +happyError' :: () => (((Located Token)), [String]) -> P a +happyError' tk = (\(tokens, explist) -> happyError) tk +parseModule = happySomeParser where + happySomeParser = happyThen (happyParse 0#) (\x -> case x of {HappyAbsSyn33 z -> happyReturn z; _other -> notHappyAtAll }) + +parseSignature = happySomeParser where + happySomeParser = happyThen (happyParse 1#) (\x -> case x of {HappyAbsSyn33 z -> happyReturn z; _other -> notHappyAtAll }) + +parseImport = happySomeParser where + happySomeParser = happyThen (happyParse 2#) (\x -> case x of {HappyAbsSyn64 z -> happyReturn z; _other -> notHappyAtAll }) + +parseStatement = happySomeParser where + happySomeParser = happyThen (happyParse 3#) (\x -> case x of {HappyAbsSyn254 z -> happyReturn z; _other -> notHappyAtAll }) + +parseDeclaration = happySomeParser where + happySomeParser = happyThen (happyParse 4#) (\x -> case x of {HappyAbsSyn77 z -> happyReturn z; _other -> notHappyAtAll }) + +parseExpression = happySomeParser where + happySomeParser = happyThen (happyParse 5#) (\x -> case x of {HappyAbsSyn207 z -> happyReturn z; _other -> notHappyAtAll }) + +parsePattern = happySomeParser where + happySomeParser = happyThen (happyParse 6#) (\x -> case x of {HappyAbsSyn247 z -> happyReturn z; _other -> notHappyAtAll }) + +parseTypeSignature = happySomeParser where + happySomeParser = happyThen (happyParse 7#) (\x -> case x of {HappyAbsSyn77 z -> happyReturn z; _other -> notHappyAtAll }) + +parseStmt = happySomeParser where + happySomeParser = happyThen (happyParse 8#) (\x -> case x of {HappyAbsSyn253 z -> happyReturn z; _other -> notHappyAtAll }) + +parseIdentifier = happySomeParser where + happySomeParser = happyThen (happyParse 9#) (\x -> case x of {HappyAbsSyn16 z -> happyReturn z; _other -> notHappyAtAll }) + +parseType = happySomeParser where + happySomeParser = happyThen (happyParse 10#) (\x -> case x of {HappyAbsSyn147 z -> happyReturn z; _other -> notHappyAtAll }) + +parseBackpack = happySomeParser where + happySomeParser = happyThen (happyParse 11#) (\x -> case x of {HappyAbsSyn17 z -> happyReturn z; _other -> notHappyAtAll }) + +parseHeader = happySomeParser where + happySomeParser = happyThen (happyParse 12#) (\x -> case x of {HappyAbsSyn33 z -> happyReturn z; _other -> notHappyAtAll }) + +happySeq = happyDoSeq + + +happyError :: P a +happyError = srcParseFail + +getVARID (dL->L _ (ITvarid x)) = x +getCONID (dL->L _ (ITconid x)) = x +getVARSYM (dL->L _ (ITvarsym x)) = x +getCONSYM (dL->L _ (ITconsym x)) = x +getQVARID (dL->L _ (ITqvarid x)) = x +getQCONID (dL->L _ (ITqconid x)) = x +getQVARSYM (dL->L _ (ITqvarsym x)) = x +getQCONSYM (dL->L _ (ITqconsym x)) = x +getIPDUPVARID (dL->L _ (ITdupipvarid x)) = x +getLABELVARID (dL->L _ (ITlabelvarid x)) = x +getCHAR (dL->L _ (ITchar _ x)) = x +getSTRING (dL->L _ (ITstring _ x)) = x +getINTEGER (dL->L _ (ITinteger x)) = x +getRATIONAL (dL->L _ (ITrational x)) = x +getPRIMCHAR (dL->L _ (ITprimchar _ x)) = x +getPRIMSTRING (dL->L _ (ITprimstring _ x)) = x +getPRIMINTEGER (dL->L _ (ITprimint _ x)) = x +getPRIMWORD (dL->L _ (ITprimword _ x)) = x +getPRIMFLOAT (dL->L _ (ITprimfloat x)) = x +getPRIMDOUBLE (dL->L _ (ITprimdouble x)) = x +getTH_ID_SPLICE (dL->L _ (ITidEscape x)) = x +getTH_ID_TY_SPLICE (dL->L _ (ITidTyEscape x)) = x +getINLINE (dL->L _ (ITinline_prag _ inl conl)) = (inl,conl) +getSPEC_INLINE (dL->L _ (ITspec_inline_prag _ True)) = (Inline, FunLike) +getSPEC_INLINE (dL->L _ (ITspec_inline_prag _ False)) = (NoInline,FunLike) +getCOMPLETE_PRAGs (dL->L _ (ITcomplete_prag x)) = x + +getDOCNEXT (dL->L _ (ITdocCommentNext x)) = x +getDOCPREV (dL->L _ (ITdocCommentPrev x)) = x +getDOCNAMED (dL->L _ (ITdocCommentNamed x)) = x +getDOCSECTION (dL->L _ (ITdocSection n x)) = (n, x) + +getINTEGERs (dL->L _ (ITinteger (IL src _ _))) = src +getCHARs (dL->L _ (ITchar src _)) = src +getSTRINGs (dL->L _ (ITstring src _)) = src +getPRIMCHARs (dL->L _ (ITprimchar src _)) = src +getPRIMSTRINGs (dL->L _ (ITprimstring src _)) = src +getPRIMINTEGERs (dL->L _ (ITprimint src _)) = src +getPRIMWORDs (dL->L _ (ITprimword src _)) = src + +-- See Note [Pragma source text] in BasicTypes for the following +getINLINE_PRAGs (dL->L _ (ITinline_prag src _ _)) = src +getSPEC_PRAGs (dL->L _ (ITspec_prag src)) = src +getSPEC_INLINE_PRAGs (dL->L _ (ITspec_inline_prag src _)) = src +getSOURCE_PRAGs (dL->L _ (ITsource_prag src)) = src +getRULES_PRAGs (dL->L _ (ITrules_prag src)) = src +getWARNING_PRAGs (dL->L _ (ITwarning_prag src)) = src +getDEPRECATED_PRAGs (dL->L _ (ITdeprecated_prag src)) = src +getSCC_PRAGs (dL->L _ (ITscc_prag src)) = src +getGENERATED_PRAGs (dL->L _ (ITgenerated_prag src)) = src +getCORE_PRAGs (dL->L _ (ITcore_prag src)) = src +getUNPACK_PRAGs (dL->L _ (ITunpack_prag src)) = src +getNOUNPACK_PRAGs (dL->L _ (ITnounpack_prag src)) = src +getANN_PRAGs (dL->L _ (ITann_prag src)) = src +getMINIMAL_PRAGs (dL->L _ (ITminimal_prag src)) = src +getOVERLAPPABLE_PRAGs (dL->L _ (IToverlappable_prag src)) = src +getOVERLAPPING_PRAGs (dL->L _ (IToverlapping_prag src)) = src +getOVERLAPS_PRAGs (dL->L _ (IToverlaps_prag src)) = src +getINCOHERENT_PRAGs (dL->L _ (ITincoherent_prag src)) = src +getCTYPEs (dL->L _ (ITctype src)) = src + +getStringLiteral l = StringLiteral (getSTRINGs l) (getSTRING l) + +isUnicode :: Located Token -> Bool +isUnicode (dL->L _ (ITforall iu)) = iu == UnicodeSyntax +isUnicode (dL->L _ (ITdarrow iu)) = iu == UnicodeSyntax +isUnicode (dL->L _ (ITdcolon iu)) = iu == UnicodeSyntax +isUnicode (dL->L _ (ITlarrow iu)) = iu == UnicodeSyntax +isUnicode (dL->L _ (ITrarrow iu)) = iu == UnicodeSyntax +isUnicode (dL->L _ (ITlarrowtail iu)) = iu == UnicodeSyntax +isUnicode (dL->L _ (ITrarrowtail iu)) = iu == UnicodeSyntax +isUnicode (dL->L _ (ITLarrowtail iu)) = iu == UnicodeSyntax +isUnicode (dL->L _ (ITRarrowtail iu)) = iu == UnicodeSyntax +isUnicode (dL->L _ (IToparenbar iu)) = iu == UnicodeSyntax +isUnicode (dL->L _ (ITcparenbar iu)) = iu == UnicodeSyntax +isUnicode (dL->L _ (ITopenExpQuote _ iu)) = iu == UnicodeSyntax +isUnicode (dL->L _ (ITcloseQuote iu)) = iu == UnicodeSyntax +isUnicode (dL->L _ (ITstar iu)) = iu == UnicodeSyntax +isUnicode _ = False + +hasE :: Located Token -> Bool +hasE (dL->L _ (ITopenExpQuote HasE _)) = True +hasE (dL->L _ (ITopenTExpQuote HasE)) = True +hasE _ = False + +getSCC :: Located Token -> P FastString +getSCC lt = do let s = getSTRING lt + err = "Spaces are not allowed in SCCs" + -- We probably actually want to be more restrictive than this + if ' ' `elem` unpackFS s + then addFatalError (getLoc lt) (text err) + else return s + +-- Utilities for combining source spans +comb2 :: (HasSrcSpan a , HasSrcSpan b) => a -> b -> SrcSpan +comb2 a b = a `seq` b `seq` combineLocs a b + +comb3 :: (HasSrcSpan a , HasSrcSpan b , HasSrcSpan c) => + a -> b -> c -> SrcSpan +comb3 a b c = a `seq` b `seq` c `seq` + combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLoc c)) + +comb4 :: (HasSrcSpan a , HasSrcSpan b , HasSrcSpan c , HasSrcSpan d) => + a -> b -> c -> d -> SrcSpan +comb4 a b c d = a `seq` b `seq` c `seq` d `seq` + (combineSrcSpans (getLoc a) $ combineSrcSpans (getLoc b) $ + combineSrcSpans (getLoc c) (getLoc d)) + +-- strict constructor version: +{-# INLINE sL #-} +sL :: HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a +sL span a = span `seq` a `seq` cL span a + +-- See Note [Adding location info] for how these utility functions are used + +-- replaced last 3 CPP macros in this file +{-# INLINE sL0 #-} +sL0 :: HasSrcSpan a => SrcSpanLess a -> a +sL0 = cL noSrcSpan -- #define L0 L noSrcSpan + +{-# INLINE sL1 #-} +sL1 :: (HasSrcSpan a , HasSrcSpan b) => a -> SrcSpanLess b -> b +sL1 x = sL (getLoc x) -- #define sL1 sL (getLoc $1) + +{-# INLINE sLL #-} +sLL :: (HasSrcSpan a , HasSrcSpan b , HasSrcSpan c) => + a -> b -> SrcSpanLess c -> c +sLL x y = sL (comb2 x y) -- #define LL sL (comb2 $1 $>) + +{- Note [Adding location info] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +This is done using the three functions below, sL0, sL1 +and sLL. Note that these functions were mechanically +converted from the three macros that used to exist before, +namely L0, L1 and LL. + +They each add a SrcSpan to their argument. + + sL0 adds 'noSrcSpan', used for empty productions + -- This doesn't seem to work anymore -=chak + + sL1 for a production with a single token on the lhs. Grabs the SrcSpan + from that token. + + sLL for a production with >1 token on the lhs. Makes up a SrcSpan from + the first and last tokens. + +These suffice for the majority of cases. However, we must be +especially careful with empty productions: sLL won't work if the first +or last token on the lhs can represent an empty span. In these cases, +we have to calculate the span using more of the tokens from the lhs, eg. + + | 'newtype' tycl_hdr '=' newconstr deriving + { L (comb3 $1 $4 $5) + (mkTyData NewType (unLoc $2) $4 (unLoc $5)) } + +We provide comb3 and comb4 functions which are useful in such cases. + +Be careful: there's no checking that you actually got this right, the +only symptom will be that the SrcSpans of your syntax will be +incorrect. + +-} + +-- Make a source location for the file. We're a bit lazy here and just +-- make a point SrcSpan at line 1, column 0. Strictly speaking we should +-- try to find the span of the whole file (ToDo). +fileSrcSpan :: P SrcSpan +fileSrcSpan = do + l <- getRealSrcLoc; + let loc = mkSrcLoc (srcLocFile l) 1 1; + return (mkSrcSpan loc loc) + +-- Hint about the MultiWayIf extension +hintMultiWayIf :: SrcSpan -> P () +hintMultiWayIf span = do + mwiEnabled <- getBit MultiWayIfBit + unless mwiEnabled $ addError span $ + text "Multi-way if-expressions need MultiWayIf turned on" + +-- Hint about explicit-forall +hintExplicitForall :: Located Token -> P () +hintExplicitForall tok = do + forall <- getBit ExplicitForallBit + rulePrag <- getBit InRulePragBit + unless (forall || rulePrag) $ addError (getLoc tok) $ vcat + [ text "Illegal symbol" <+> quotes forallSymDoc <+> text "in type" + , text "Perhaps you intended to use RankNTypes or a similar language" + , text "extension to enable explicit-forall syntax:" <+> + forallSymDoc <+> text ". " + ] + where + forallSymDoc = text (forallSym (isUnicode tok)) + +checkIfBang :: LHsExpr GhcPs -> Bool +checkIfBang (dL->L _ (HsVar _ (dL->L _ op))) = op == bang_RDR +checkIfBang _ = False + +-- | Warn about missing space after bang +warnSpaceAfterBang :: SrcSpan -> P () +warnSpaceAfterBang span = do + bang_on <- getBit BangPatBit + unless bang_on $ + addWarning Opt_WarnSpaceAfterBang span msg + where + msg = text "Did you forget to enable BangPatterns?" $$ + text "If you mean to bind (!) then perhaps you want" $$ + text "to add a space after the bang for clarity." + +-- When two single quotes don't followed by tyvar or gtycon, we report the +-- error as empty character literal, or TH quote that missing proper type +-- variable or constructor. See #13450. +reportEmptyDoubleQuotes :: SrcSpan -> P a +reportEmptyDoubleQuotes span = do + thQuotes <- getBit ThQuotesBit + if thQuotes + then addFatalError span $ vcat + [ text "Parser error on `''`" + , text "Character literals may not be empty" + , text "Or perhaps you intended to use quotation syntax of TemplateHaskell," + , text "but the type variable or constructor is missing" + ] + else addFatalError span $ vcat + [ text "Parser error on `''`" + , text "Character literals may not be empty" + ] + +{- +%************************************************************************ +%* * + Helper functions for generating annotations in the parser +%* * +%************************************************************************ + +For the general principles of the following routines, see Note [Api annotations] +in ApiAnnotation.hs + +-} + +-- |Construct an AddAnn from the annotation keyword and the location +-- of the keyword itself +mj :: HasSrcSpan e => AnnKeywordId -> e -> AddAnn +mj a l s = addAnnotation s a (gl l) + +mjL :: AnnKeywordId -> SrcSpan -> AddAnn +mjL a l s = addAnnotation s a l + + + +-- |Construct an AddAnn from the annotation keyword and the Located Token. If +-- the token has a unicode equivalent and this has been used, provide the +-- unicode variant of the annotation. +mu :: AnnKeywordId -> Located Token -> AddAnn +mu a lt@(dL->L l t) = (\s -> addAnnotation s (toUnicodeAnn a lt) l) + +-- | If the 'Token' is using its unicode variant return the unicode variant of +-- the annotation +toUnicodeAnn :: AnnKeywordId -> Located Token -> AnnKeywordId +toUnicodeAnn a t = if isUnicode t then unicodeAnn a else a + +gl :: HasSrcSpan a => a -> SrcSpan +gl = getLoc + +-- |Add an annotation to the located element, and return the located +-- element as a pass through +aa :: (HasSrcSpan a , HasSrcSpan c) => a -> (AnnKeywordId, c) -> P a +aa a@(dL->L l _) (b,s) = addAnnotation l b (gl s) >> return a + +-- |Add an annotation to a located element resulting from a monadic action +am :: (HasSrcSpan a , HasSrcSpan b) => P a -> (AnnKeywordId, b) -> P a +am a (b,s) = do + av@(dL->L l _) <- a + addAnnotation l b (gl s) + return av + +-- | Add a list of AddAnns to the given AST element. For example, +-- the parsing rule for @let@ looks like: +-- +-- @ +-- | 'let' binds 'in' exp {% ams (sLL $1 $> $ HsLet (snd $ unLoc $2) $4) +-- (mj AnnLet $1:mj AnnIn $3 +-- :(fst $ unLoc $2)) } +-- @ +-- +-- This adds an AnnLet annotation for @let@, an AnnIn for @in@, as well +-- as any annotations that may arise in the binds. This will include open +-- and closing braces if they are used to delimit the let expressions. +-- +ams :: Located a -> [AddAnn] -> P (Located a) +ams a@(dL->L l _) bs = addAnnsAt l bs >> return a + +amsL :: SrcSpan -> [AddAnn] -> P () +amsL sp bs = addAnnsAt sp bs >> return () + +-- |Add all [AddAnn] to an AST element wrapped in a Just +ajs a@(Just (dL->L l _)) bs = addAnnsAt l bs >> return a + +-- |Add a list of AddAnns to the given AST element, where the AST element is the +-- result of a monadic action +amms :: HasSrcSpan a => P a -> [AddAnn] -> P a +amms a bs = do { av@(dL->L l _) <- a + ; addAnnsAt l bs + ; return av } + +-- |Add a list of AddAnns to the AST element, and return the element as a +-- OrdList +amsu :: HasSrcSpan a => a -> [AddAnn] -> P (OrdList a) +amsu a@(dL->L l _) bs = addAnnsAt l bs >> return (unitOL a) + +-- |Synonyms for AddAnn versions of AnnOpen and AnnClose +mo,mc :: Located Token -> AddAnn +mo ll = mj AnnOpen ll +mc ll = mj AnnClose ll + +moc,mcc :: Located Token -> AddAnn +moc ll = mj AnnOpenC ll +mcc ll = mj AnnCloseC ll + +mop,mcp :: Located Token -> AddAnn +mop ll = mj AnnOpenP ll +mcp ll = mj AnnCloseP ll + +mos,mcs :: Located Token -> AddAnn +mos ll = mj AnnOpenS ll +mcs ll = mj AnnCloseS ll + +-- |Given a list of the locations of commas, provide a [AddAnn] with an AnnComma +-- entry for each SrcSpan +mcommas :: [SrcSpan] -> [AddAnn] +mcommas ss = map (mjL AnnCommaTuple) ss + +-- |Given a list of the locations of '|'s, provide a [AddAnn] with an AnnVbar +-- entry for each SrcSpan +mvbars :: [SrcSpan] -> [AddAnn] +mvbars ss = map (mjL AnnVbar) ss + +-- |Get the location of the last element of a OrdList, or noSrcSpan +oll :: HasSrcSpan a => OrdList a -> SrcSpan +oll l = + if isNilOL l then noSrcSpan + else getLoc (lastOL l) + +-- |Add a semicolon annotation in the right place in a list. If the +-- leading list is empty, add it to the tail +asl :: (HasSrcSpan a , HasSrcSpan b) => [a] -> b -> a -> P() +asl [] (dL->L ls _) (dL->L l _) = addAnnotation l AnnSemi ls +asl (x:_xs) (dL->L ls _) _x = addAnnotation (getLoc x) AnnSemi ls +{-# LINE 1 "templates/GenericTemplate.hs" #-} +{-# LINE 1 "templates/GenericTemplate.hs" #-} +{-# LINE 1 "" #-} +{-# LINE 17 "" #-} +{-# LINE 1 "/Users/shaynefletcher/.stack/programs/x86_64-osx/ghc-8.6.4/lib/ghc-8.6.4/include/ghcversion.h" #-} + + + + + + + + + + + + + + + + +{-# LINE 18 "" #-} +{-# LINE 1 "/var/folders/f_/bb4zyb7d2_z9bqm3hrqrjgp40000gn/T/ghc75776_0/ghc_2.h" #-} + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +{-# LINE 19 "" #-} +{-# LINE 1 "templates/GenericTemplate.hs" #-} +-- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp + + + + + + + + + + + + + +-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. +#if __GLASGOW_HASKELL__ > 706 +#define LT(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.<# m)) :: Bool) +#define GTE(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.>=# m)) :: Bool) +#define EQ(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.==# m)) :: Bool) +#else +#define LT(n,m) (n Happy_GHC_Exts.<# m) +#define GTE(n,m) (n Happy_GHC_Exts.>=# m) +#define EQ(n,m) (n Happy_GHC_Exts.==# m) +#endif + +{-# LINE 43 "templates/GenericTemplate.hs" #-} + +data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList + + + + + + + + +{-# LINE 65 "templates/GenericTemplate.hs" #-} + + +{-# LINE 75 "templates/GenericTemplate.hs" #-} + + + + + + + + + + +infixr 9 `HappyStk` +data HappyStk a = HappyStk a (HappyStk a) + +----------------------------------------------------------------------------- +-- starting the parse + +happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll + +----------------------------------------------------------------------------- +-- Accepting the parse + +-- If the current token is 0#, it means we've just accepted a partial +-- parse (a %partial parser). We must ignore the saved token on the top of +-- the stack in this case. +happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) = + happyReturn1 ans +happyAccept j tk st sts (HappyStk ans _) = + (happyTcHack j (happyTcHack st)) (happyReturn1 ans) + +----------------------------------------------------------------------------- +-- Arrays only: do the next action + + + +happyDoAction i tk st + = {- nothing -} + + + case action of + 0# -> {- nothing -} + happyFail (happyExpListPerState ((Happy_GHC_Exts.I# (st)) :: Int)) i tk st + -1# -> {- nothing -} + happyAccept i tk st + n | LT(n,(0# :: Happy_GHC_Exts.Int#)) -> {- nothing -} + + (happyReduceArr Happy_Data_Array.! rule) i tk st + where rule = (Happy_GHC_Exts.I# ((Happy_GHC_Exts.negateInt# ((n Happy_GHC_Exts.+# (1# :: Happy_GHC_Exts.Int#)))))) + n -> {- nothing -} + + + happyShift new_state i tk st + where new_state = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) + where off = happyAdjustOffset (indexShortOffAddr happyActOffsets st) + off_i = (off Happy_GHC_Exts.+# i) + check = if GTE(off_i,(0# :: Happy_GHC_Exts.Int#)) + then EQ(indexShortOffAddr happyCheck off_i, i) + else False + action + | check = indexShortOffAddr happyTable off_i + | otherwise = indexShortOffAddr happyDefActions st + + + + +indexShortOffAddr (HappyA# arr) off = + Happy_GHC_Exts.narrow16Int# i + where + i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low) + high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#))) + low = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off')) + off' = off Happy_GHC_Exts.*# 2# + + + + +{-# INLINE happyLt #-} +happyLt x y = LT(x,y) + + +readArrayBit arr bit = + Bits.testBit (Happy_GHC_Exts.I# (indexShortOffAddr arr ((unbox_int bit) `Happy_GHC_Exts.iShiftRA#` 4#))) (bit `mod` 16) + where unbox_int (Happy_GHC_Exts.I# x) = x + + + + + + +data HappyAddr = HappyA# Happy_GHC_Exts.Addr# + + +----------------------------------------------------------------------------- +-- HappyState data type (not arrays) + + +{-# LINE 180 "templates/GenericTemplate.hs" #-} + +----------------------------------------------------------------------------- +-- Shifting a token + +happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = + let i = (case x of { HappyErrorToken (Happy_GHC_Exts.I# (i)) -> i }) in +-- trace "shifting the error token" $ + happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) + +happyShift new_state i tk st sts stk = + happyNewToken new_state (HappyCons (st) (sts)) ((HappyTerminal (tk))`HappyStk`stk) + +-- happyReduce is specialised for the common cases. + +happySpecReduce_0 i fn 0# tk st sts stk + = happyFail [] 0# tk st sts stk +happySpecReduce_0 nt fn j tk st@((action)) sts stk + = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk) + +happySpecReduce_1 i fn 0# tk st sts stk + = happyFail [] 0# tk st sts stk +happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk') + = let r = fn v1 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_2 i fn 0# tk st sts stk + = happyFail [] 0# tk st sts stk +happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk') + = let r = fn v1 v2 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happySpecReduce_3 i fn 0# tk st sts stk + = happyFail [] 0# tk st sts stk +happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk') + = let r = fn v1 v2 v3 in + happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk')) + +happyReduce k i fn 0# tk st sts stk + = happyFail [] 0# tk st sts stk +happyReduce k nt fn j tk st sts stk + = case happyDrop (k Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) sts of + sts1@((HappyCons (st1@(action)) (_))) -> + let r = fn stk in -- it doesn't hurt to always seq here... + happyDoSeq r (happyGoto nt j tk st1 sts1 r) + +happyMonadReduce k nt fn 0# tk st sts stk + = happyFail [] 0# tk st sts stk +happyMonadReduce k nt fn j tk st sts stk = + case happyDrop k (HappyCons (st) (sts)) of + sts1@((HappyCons (st1@(action)) (_))) -> + let drop_stk = happyDropStk k stk in + happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) + +happyMonad2Reduce k nt fn 0# tk st sts stk + = happyFail [] 0# tk st sts stk +happyMonad2Reduce k nt fn j tk st sts stk = + case happyDrop k (HappyCons (st) (sts)) of + sts1@((HappyCons (st1@(action)) (_))) -> + let drop_stk = happyDropStk k stk + + off = happyAdjustOffset (indexShortOffAddr happyGotoOffsets st1) + off_i = (off Happy_GHC_Exts.+# nt) + new_state = indexShortOffAddr happyTable off_i + + + + + in + happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) + +happyDrop 0# l = l +happyDrop n (HappyCons (_) (t)) = happyDrop (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) t + +happyDropStk 0# l = l +happyDropStk n (x `HappyStk` xs) = happyDropStk (n Happy_GHC_Exts.-# (1#::Happy_GHC_Exts.Int#)) xs + +----------------------------------------------------------------------------- +-- Moving to a new state after a reduction + + +happyGoto nt j tk st = + {- nothing -} + happyDoAction j tk new_state + where off = happyAdjustOffset (indexShortOffAddr happyGotoOffsets st) + off_i = (off Happy_GHC_Exts.+# nt) + new_state = indexShortOffAddr happyTable off_i + + + + +----------------------------------------------------------------------------- +-- Error recovery (0# is the error token) + +-- parse error if we are in recovery and we fail again +happyFail explist 0# tk old_st _ stk@(x `HappyStk` _) = + let i = (case x of { HappyErrorToken (Happy_GHC_Exts.I# (i)) -> i }) in +-- trace "failing" $ + happyError_ explist i tk + +{- We don't need state discarding for our restricted implementation of + "error". In fact, it can cause some bogus parses, so I've disabled it + for now --SDM + +-- discard a state +happyFail 0# tk old_st (HappyCons ((action)) (sts)) + (saved_tok `HappyStk` _ `HappyStk` stk) = +-- trace ("discarding state, depth " ++ show (length stk)) $ + happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) +-} + +-- Enter error recovery: generate an error token, +-- save the old token and carry on. +happyFail explist i tk (action) sts stk = +-- trace "entering error recovery" $ + happyDoAction 0# tk action sts ( (HappyErrorToken (Happy_GHC_Exts.I# (i))) `HappyStk` stk) + +-- Internal happy errors: + +notHappyAtAll :: a +notHappyAtAll = error "Internal Happy error\n" + +----------------------------------------------------------------------------- +-- Hack to get the typechecker to accept our action functions + + +happyTcHack :: Happy_GHC_Exts.Int# -> a -> a +happyTcHack x y = y +{-# INLINE happyTcHack #-} + + +----------------------------------------------------------------------------- +-- Seq-ing. If the --strict flag is given, then Happy emits +-- happySeq = happyDoSeq +-- otherwise it emits +-- happySeq = happyDontSeq + +happyDoSeq, happyDontSeq :: a -> b -> b +happyDoSeq a b = a `seq` b +happyDontSeq a b = b + +----------------------------------------------------------------------------- +-- Don't inline any functions from the template. GHC has a nasty habit +-- of deciding to inline happyGoto everywhere, which increases the size of +-- the generated parser quite a bit. + + +{-# NOINLINE happyDoAction #-} +{-# NOINLINE happyTable #-} +{-# NOINLINE happyCheck #-} +{-# NOINLINE happyActOffsets #-} +{-# NOINLINE happyGotoOffsets #-} +{-# NOINLINE happyDefActions #-} + +{-# NOINLINE happyShift #-} +{-# NOINLINE happySpecReduce_0 #-} +{-# NOINLINE happySpecReduce_1 #-} +{-# NOINLINE happySpecReduce_2 #-} +{-# NOINLINE happySpecReduce_3 #-} +{-# NOINLINE happyReduce #-} +{-# NOINLINE happyMonadReduce #-} +{-# NOINLINE happyGoto #-} +{-# NOINLINE happyFail #-} + +-- end of Happy Template. + diff --git a/ghc-lib/stage1/compiler/build/Config.hs b/ghc-lib/stage1/compiler/build/Config.hs new file mode 100644 --- /dev/null +++ b/ghc-lib/stage1/compiler/build/Config.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE CPP #-} +module Config where + +import GhcPrelude + +#include "ghc_boot_platform.h" + +data IntegerLibrary = IntegerGMP + | IntegerSimple + deriving Eq + +cBuildPlatformString :: String +cBuildPlatformString = BuildPlatform_NAME +cHostPlatformString :: String +cHostPlatformString = HostPlatform_NAME +cTargetPlatformString :: String +cTargetPlatformString = TargetPlatform_NAME + +cProjectName :: String +cProjectName = "The Glorious Glasgow Haskell Compilation System" +cProjectGitCommitId :: String +cProjectGitCommitId = "bf73419518ca550e85188616f860961c7e2a336b" +cProjectVersion :: String +cProjectVersion = "8.9.20190402" +cProjectVersionInt :: String +cProjectVersionInt = "809" +cProjectPatchLevel :: String +cProjectPatchLevel = "20190402" +cProjectPatchLevel1 :: String +cProjectPatchLevel1 = "20190402" +cProjectPatchLevel2 :: String +cProjectPatchLevel2 = "" +cBooterVersion :: String +cBooterVersion = "8.6.4" +cStage :: String +cStage = show (STAGE :: Int) +cIntegerLibrary :: String +cIntegerLibrary = "integer-simple" +cIntegerLibraryType :: IntegerLibrary +cIntegerLibraryType = IntegerSimple +cGhcWithInterpreter :: String +cGhcWithInterpreter = "YES" +cGhcWithNativeCodeGen :: String +cGhcWithNativeCodeGen = "YES" +cGhcWithSMP :: String +cGhcWithSMP = "YES" +cGhcRTSWays :: String +cGhcRTSWays = "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" +cGhcEnableTablesNextToCode :: String +cGhcEnableTablesNextToCode = "YES" +cLeadingUnderscore :: String +cLeadingUnderscore = "YES" +cGHC_UNLIT_PGM :: String +cGHC_UNLIT_PGM = "unlit" +cLibFFI :: Bool +cLibFFI = False +cGhcThreaded :: Bool +cGhcThreaded = True +cGhcDebugged :: Bool +cGhcDebugged = False +cGhcRtsWithLibdw :: Bool +cGhcRtsWithLibdw = False diff --git a/ghc-lib/stage1/compiler/build/ghc_boot_platform.h b/ghc-lib/stage1/compiler/build/ghc_boot_platform.h new file mode 100644 --- /dev/null +++ b/ghc-lib/stage1/compiler/build/ghc_boot_platform.h @@ -0,0 +1,34 @@ +#ifndef __PLATFORM_H__ +#define __PLATFORM_H__ + +#define BuildPlatform_NAME "x86_64-apple-darwin" +#define HostPlatform_NAME "x86_64-apple-darwin" +#define TargetPlatform_NAME "x86_64-apple-darwin" + +#define x86_64_apple_darwin_BUILD 1 +#define x86_64_apple_darwin_HOST 1 +#define x86_64_apple_darwin_TARGET 1 + +#define x86_64_BUILD_ARCH 1 +#define x86_64_HOST_ARCH 1 +#define x86_64_TARGET_ARCH 1 +#define BUILD_ARCH "x86_64" +#define HOST_ARCH "x86_64" +#define TARGET_ARCH "x86_64" +#define LLVM_TARGET "x86_64-apple-darwin" + +#define darwin_BUILD_OS 1 +#define darwin_HOST_OS 1 +#define darwin_TARGET_OS 1 +#define BUILD_OS "darwin" +#define HOST_OS "darwin" +#define TARGET_OS "darwin" + +#define apple_BUILD_VENDOR 1 +#define apple_HOST_VENDOR 1 +#define apple_TARGET_VENDOR 1 +#define BUILD_VENDOR "apple" +#define HOST_VENDOR "apple" +#define TARGET_VENDOR "apple" + +#endif /* __PLATFORM_H__ */ diff --git a/ghc-lib/stage1/compiler/build/primop-can-fail.hs-incl b/ghc-lib/stage1/compiler/build/primop-can-fail.hs-incl new file mode 100644 --- /dev/null +++ b/ghc-lib/stage1/compiler/build/primop-can-fail.hs-incl @@ -0,0 +1,231 @@ +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 DoubleAsinOp = True +primOpCanFail DoubleAcosOp = True +primOpCanFail FloatDivOp = True +primOpCanFail FloatLogOp = 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 diff --git a/ghc-lib/stage1/compiler/build/primop-code-size.hs-incl b/ghc-lib/stage1/compiler/build/primop-code-size.hs-incl new file mode 100644 --- /dev/null +++ b/ghc-lib/stage1/compiler/build/primop-code-size.hs-incl @@ -0,0 +1,57 @@ +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 DoubleLogOp = 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 FloatLogOp = 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 diff --git a/ghc-lib/stage1/compiler/build/primop-commutable.hs-incl b/ghc-lib/stage1/compiler/build/primop-commutable.hs-incl new file mode 100644 --- /dev/null +++ b/ghc-lib/stage1/compiler/build/primop-commutable.hs-incl @@ -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 diff --git a/ghc-lib/stage1/compiler/build/primop-data-decl.hs-incl b/ghc-lib/stage1/compiler/build/primop-data-decl.hs-incl new file mode 100644 --- /dev/null +++ b/ghc-lib/stage1/compiler/build/primop-data-decl.hs-incl @@ -0,0 +1,580 @@ +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 + | DoubleLogOp + | 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 + | FloatLogOp + | 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 + | GetThreadAllocationCounter + | 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 diff --git a/ghc-lib/stage1/compiler/build/primop-fixity.hs-incl b/ghc-lib/stage1/compiler/build/primop-fixity.hs-incl new file mode 100644 --- /dev/null +++ b/ghc-lib/stage1/compiler/build/primop-fixity.hs-incl @@ -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 diff --git a/ghc-lib/stage1/compiler/build/primop-has-side-effects.hs-incl b/ghc-lib/stage1/compiler/build/primop-has-side-effects.hs-incl new file mode 100644 --- /dev/null +++ b/ghc-lib/stage1/compiler/build/primop-has-side-effects.hs-incl @@ -0,0 +1,242 @@ +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 GetThreadAllocationCounter = 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 diff --git a/ghc-lib/stage1/compiler/build/primop-list.hs-incl b/ghc-lib/stage1/compiler/build/primop-list.hs-incl new file mode 100644 --- /dev/null +++ b/ghc-lib/stage1/compiler/build/primop-list.hs-incl @@ -0,0 +1,1199 @@ + [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 + , DoubleLogOp + , 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 + , FloatLogOp + , 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 + , GetThreadAllocationCounter + , 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 + ] diff --git a/ghc-lib/stage1/compiler/build/primop-out-of-line.hs-incl b/ghc-lib/stage1/compiler/build/primop-out-of-line.hs-incl new file mode 100644 --- /dev/null +++ b/ghc-lib/stage1/compiler/build/primop-out-of-line.hs-incl @@ -0,0 +1,102 @@ +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 GetThreadAllocationCounter = True +primOpOutOfLine SetThreadAllocationCounter = True +primOpOutOfLine _ = False diff --git a/ghc-lib/stage1/compiler/build/primop-primop-info.hs-incl b/ghc-lib/stage1/compiler/build/primop-primop-info.hs-incl new file mode 100644 --- /dev/null +++ b/ghc-lib/stage1/compiler/build/primop-primop-info.hs-incl @@ -0,0 +1,1198 @@ +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 DoubleLogOp = mkMonadic (fsLit "logDouble#") 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 FloatLogOp = mkMonadic (fsLit "logFloat#") 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 GetThreadAllocationCounter = mkGenPrimOp (fsLit "getThreadAllocationCounter#") [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy])) +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) diff --git a/ghc-lib/stage1/compiler/build/primop-strictness.hs-incl b/ghc-lib/stage1/compiler/build/primop-strictness.hs-incl new file mode 100644 --- /dev/null +++ b/ghc-lib/stage1/compiler/build/primop-strictness.hs-incl @@ -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 diff --git a/ghc-lib/stage1/compiler/build/primop-tag.hs-incl b/ghc-lib/stage1/compiler/build/primop-tag.hs-incl new file mode 100644 --- /dev/null +++ b/ghc-lib/stage1/compiler/build/primop-tag.hs-incl @@ -0,0 +1,1201 @@ +maxPrimOpTag :: Int +maxPrimOpTag = 1198 +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 DoubleLogOp = 176 +primOpTag DoubleSqrtOp = 177 +primOpTag DoubleSinOp = 178 +primOpTag DoubleCosOp = 179 +primOpTag DoubleTanOp = 180 +primOpTag DoubleAsinOp = 181 +primOpTag DoubleAcosOp = 182 +primOpTag DoubleAtanOp = 183 +primOpTag DoubleSinhOp = 184 +primOpTag DoubleCoshOp = 185 +primOpTag DoubleTanhOp = 186 +primOpTag DoubleAsinhOp = 187 +primOpTag DoubleAcoshOp = 188 +primOpTag DoubleAtanhOp = 189 +primOpTag DoublePowerOp = 190 +primOpTag DoubleDecode_2IntOp = 191 +primOpTag DoubleDecode_Int64Op = 192 +primOpTag FloatGtOp = 193 +primOpTag FloatGeOp = 194 +primOpTag FloatEqOp = 195 +primOpTag FloatNeOp = 196 +primOpTag FloatLtOp = 197 +primOpTag FloatLeOp = 198 +primOpTag FloatAddOp = 199 +primOpTag FloatSubOp = 200 +primOpTag FloatMulOp = 201 +primOpTag FloatDivOp = 202 +primOpTag FloatNegOp = 203 +primOpTag FloatFabsOp = 204 +primOpTag Float2IntOp = 205 +primOpTag FloatExpOp = 206 +primOpTag FloatLogOp = 207 +primOpTag FloatSqrtOp = 208 +primOpTag FloatSinOp = 209 +primOpTag FloatCosOp = 210 +primOpTag FloatTanOp = 211 +primOpTag FloatAsinOp = 212 +primOpTag FloatAcosOp = 213 +primOpTag FloatAtanOp = 214 +primOpTag FloatSinhOp = 215 +primOpTag FloatCoshOp = 216 +primOpTag FloatTanhOp = 217 +primOpTag FloatAsinhOp = 218 +primOpTag FloatAcoshOp = 219 +primOpTag FloatAtanhOp = 220 +primOpTag FloatPowerOp = 221 +primOpTag Float2DoubleOp = 222 +primOpTag FloatDecode_IntOp = 223 +primOpTag NewArrayOp = 224 +primOpTag SameMutableArrayOp = 225 +primOpTag ReadArrayOp = 226 +primOpTag WriteArrayOp = 227 +primOpTag SizeofArrayOp = 228 +primOpTag SizeofMutableArrayOp = 229 +primOpTag IndexArrayOp = 230 +primOpTag UnsafeFreezeArrayOp = 231 +primOpTag UnsafeThawArrayOp = 232 +primOpTag CopyArrayOp = 233 +primOpTag CopyMutableArrayOp = 234 +primOpTag CloneArrayOp = 235 +primOpTag CloneMutableArrayOp = 236 +primOpTag FreezeArrayOp = 237 +primOpTag ThawArrayOp = 238 +primOpTag CasArrayOp = 239 +primOpTag NewSmallArrayOp = 240 +primOpTag SameSmallMutableArrayOp = 241 +primOpTag ReadSmallArrayOp = 242 +primOpTag WriteSmallArrayOp = 243 +primOpTag SizeofSmallArrayOp = 244 +primOpTag SizeofSmallMutableArrayOp = 245 +primOpTag IndexSmallArrayOp = 246 +primOpTag UnsafeFreezeSmallArrayOp = 247 +primOpTag UnsafeThawSmallArrayOp = 248 +primOpTag CopySmallArrayOp = 249 +primOpTag CopySmallMutableArrayOp = 250 +primOpTag CloneSmallArrayOp = 251 +primOpTag CloneSmallMutableArrayOp = 252 +primOpTag FreezeSmallArrayOp = 253 +primOpTag ThawSmallArrayOp = 254 +primOpTag CasSmallArrayOp = 255 +primOpTag NewByteArrayOp_Char = 256 +primOpTag NewPinnedByteArrayOp_Char = 257 +primOpTag NewAlignedPinnedByteArrayOp_Char = 258 +primOpTag MutableByteArrayIsPinnedOp = 259 +primOpTag ByteArrayIsPinnedOp = 260 +primOpTag ByteArrayContents_Char = 261 +primOpTag SameMutableByteArrayOp = 262 +primOpTag ShrinkMutableByteArrayOp_Char = 263 +primOpTag ResizeMutableByteArrayOp_Char = 264 +primOpTag UnsafeFreezeByteArrayOp = 265 +primOpTag SizeofByteArrayOp = 266 +primOpTag SizeofMutableByteArrayOp = 267 +primOpTag GetSizeofMutableByteArrayOp = 268 +primOpTag IndexByteArrayOp_Char = 269 +primOpTag IndexByteArrayOp_WideChar = 270 +primOpTag IndexByteArrayOp_Int = 271 +primOpTag IndexByteArrayOp_Word = 272 +primOpTag IndexByteArrayOp_Addr = 273 +primOpTag IndexByteArrayOp_Float = 274 +primOpTag IndexByteArrayOp_Double = 275 +primOpTag IndexByteArrayOp_StablePtr = 276 +primOpTag IndexByteArrayOp_Int8 = 277 +primOpTag IndexByteArrayOp_Int16 = 278 +primOpTag IndexByteArrayOp_Int32 = 279 +primOpTag IndexByteArrayOp_Int64 = 280 +primOpTag IndexByteArrayOp_Word8 = 281 +primOpTag IndexByteArrayOp_Word16 = 282 +primOpTag IndexByteArrayOp_Word32 = 283 +primOpTag IndexByteArrayOp_Word64 = 284 +primOpTag IndexByteArrayOp_Word8AsChar = 285 +primOpTag IndexByteArrayOp_Word8AsWideChar = 286 +primOpTag IndexByteArrayOp_Word8AsAddr = 287 +primOpTag IndexByteArrayOp_Word8AsFloat = 288 +primOpTag IndexByteArrayOp_Word8AsDouble = 289 +primOpTag IndexByteArrayOp_Word8AsStablePtr = 290 +primOpTag IndexByteArrayOp_Word8AsInt16 = 291 +primOpTag IndexByteArrayOp_Word8AsInt32 = 292 +primOpTag IndexByteArrayOp_Word8AsInt64 = 293 +primOpTag IndexByteArrayOp_Word8AsInt = 294 +primOpTag IndexByteArrayOp_Word8AsWord16 = 295 +primOpTag IndexByteArrayOp_Word8AsWord32 = 296 +primOpTag IndexByteArrayOp_Word8AsWord64 = 297 +primOpTag IndexByteArrayOp_Word8AsWord = 298 +primOpTag ReadByteArrayOp_Char = 299 +primOpTag ReadByteArrayOp_WideChar = 300 +primOpTag ReadByteArrayOp_Int = 301 +primOpTag ReadByteArrayOp_Word = 302 +primOpTag ReadByteArrayOp_Addr = 303 +primOpTag ReadByteArrayOp_Float = 304 +primOpTag ReadByteArrayOp_Double = 305 +primOpTag ReadByteArrayOp_StablePtr = 306 +primOpTag ReadByteArrayOp_Int8 = 307 +primOpTag ReadByteArrayOp_Int16 = 308 +primOpTag ReadByteArrayOp_Int32 = 309 +primOpTag ReadByteArrayOp_Int64 = 310 +primOpTag ReadByteArrayOp_Word8 = 311 +primOpTag ReadByteArrayOp_Word16 = 312 +primOpTag ReadByteArrayOp_Word32 = 313 +primOpTag ReadByteArrayOp_Word64 = 314 +primOpTag ReadByteArrayOp_Word8AsChar = 315 +primOpTag ReadByteArrayOp_Word8AsWideChar = 316 +primOpTag ReadByteArrayOp_Word8AsAddr = 317 +primOpTag ReadByteArrayOp_Word8AsFloat = 318 +primOpTag ReadByteArrayOp_Word8AsDouble = 319 +primOpTag ReadByteArrayOp_Word8AsStablePtr = 320 +primOpTag ReadByteArrayOp_Word8AsInt16 = 321 +primOpTag ReadByteArrayOp_Word8AsInt32 = 322 +primOpTag ReadByteArrayOp_Word8AsInt64 = 323 +primOpTag ReadByteArrayOp_Word8AsInt = 324 +primOpTag ReadByteArrayOp_Word8AsWord16 = 325 +primOpTag ReadByteArrayOp_Word8AsWord32 = 326 +primOpTag ReadByteArrayOp_Word8AsWord64 = 327 +primOpTag ReadByteArrayOp_Word8AsWord = 328 +primOpTag WriteByteArrayOp_Char = 329 +primOpTag WriteByteArrayOp_WideChar = 330 +primOpTag WriteByteArrayOp_Int = 331 +primOpTag WriteByteArrayOp_Word = 332 +primOpTag WriteByteArrayOp_Addr = 333 +primOpTag WriteByteArrayOp_Float = 334 +primOpTag WriteByteArrayOp_Double = 335 +primOpTag WriteByteArrayOp_StablePtr = 336 +primOpTag WriteByteArrayOp_Int8 = 337 +primOpTag WriteByteArrayOp_Int16 = 338 +primOpTag WriteByteArrayOp_Int32 = 339 +primOpTag WriteByteArrayOp_Int64 = 340 +primOpTag WriteByteArrayOp_Word8 = 341 +primOpTag WriteByteArrayOp_Word16 = 342 +primOpTag WriteByteArrayOp_Word32 = 343 +primOpTag WriteByteArrayOp_Word64 = 344 +primOpTag WriteByteArrayOp_Word8AsChar = 345 +primOpTag WriteByteArrayOp_Word8AsWideChar = 346 +primOpTag WriteByteArrayOp_Word8AsAddr = 347 +primOpTag WriteByteArrayOp_Word8AsFloat = 348 +primOpTag WriteByteArrayOp_Word8AsDouble = 349 +primOpTag WriteByteArrayOp_Word8AsStablePtr = 350 +primOpTag WriteByteArrayOp_Word8AsInt16 = 351 +primOpTag WriteByteArrayOp_Word8AsInt32 = 352 +primOpTag WriteByteArrayOp_Word8AsInt64 = 353 +primOpTag WriteByteArrayOp_Word8AsInt = 354 +primOpTag WriteByteArrayOp_Word8AsWord16 = 355 +primOpTag WriteByteArrayOp_Word8AsWord32 = 356 +primOpTag WriteByteArrayOp_Word8AsWord64 = 357 +primOpTag WriteByteArrayOp_Word8AsWord = 358 +primOpTag CompareByteArraysOp = 359 +primOpTag CopyByteArrayOp = 360 +primOpTag CopyMutableByteArrayOp = 361 +primOpTag CopyByteArrayToAddrOp = 362 +primOpTag CopyMutableByteArrayToAddrOp = 363 +primOpTag CopyAddrToByteArrayOp = 364 +primOpTag SetByteArrayOp = 365 +primOpTag AtomicReadByteArrayOp_Int = 366 +primOpTag AtomicWriteByteArrayOp_Int = 367 +primOpTag CasByteArrayOp_Int = 368 +primOpTag FetchAddByteArrayOp_Int = 369 +primOpTag FetchSubByteArrayOp_Int = 370 +primOpTag FetchAndByteArrayOp_Int = 371 +primOpTag FetchNandByteArrayOp_Int = 372 +primOpTag FetchOrByteArrayOp_Int = 373 +primOpTag FetchXorByteArrayOp_Int = 374 +primOpTag NewArrayArrayOp = 375 +primOpTag SameMutableArrayArrayOp = 376 +primOpTag UnsafeFreezeArrayArrayOp = 377 +primOpTag SizeofArrayArrayOp = 378 +primOpTag SizeofMutableArrayArrayOp = 379 +primOpTag IndexArrayArrayOp_ByteArray = 380 +primOpTag IndexArrayArrayOp_ArrayArray = 381 +primOpTag ReadArrayArrayOp_ByteArray = 382 +primOpTag ReadArrayArrayOp_MutableByteArray = 383 +primOpTag ReadArrayArrayOp_ArrayArray = 384 +primOpTag ReadArrayArrayOp_MutableArrayArray = 385 +primOpTag WriteArrayArrayOp_ByteArray = 386 +primOpTag WriteArrayArrayOp_MutableByteArray = 387 +primOpTag WriteArrayArrayOp_ArrayArray = 388 +primOpTag WriteArrayArrayOp_MutableArrayArray = 389 +primOpTag CopyArrayArrayOp = 390 +primOpTag CopyMutableArrayArrayOp = 391 +primOpTag AddrAddOp = 392 +primOpTag AddrSubOp = 393 +primOpTag AddrRemOp = 394 +primOpTag Addr2IntOp = 395 +primOpTag Int2AddrOp = 396 +primOpTag AddrGtOp = 397 +primOpTag AddrGeOp = 398 +primOpTag AddrEqOp = 399 +primOpTag AddrNeOp = 400 +primOpTag AddrLtOp = 401 +primOpTag AddrLeOp = 402 +primOpTag IndexOffAddrOp_Char = 403 +primOpTag IndexOffAddrOp_WideChar = 404 +primOpTag IndexOffAddrOp_Int = 405 +primOpTag IndexOffAddrOp_Word = 406 +primOpTag IndexOffAddrOp_Addr = 407 +primOpTag IndexOffAddrOp_Float = 408 +primOpTag IndexOffAddrOp_Double = 409 +primOpTag IndexOffAddrOp_StablePtr = 410 +primOpTag IndexOffAddrOp_Int8 = 411 +primOpTag IndexOffAddrOp_Int16 = 412 +primOpTag IndexOffAddrOp_Int32 = 413 +primOpTag IndexOffAddrOp_Int64 = 414 +primOpTag IndexOffAddrOp_Word8 = 415 +primOpTag IndexOffAddrOp_Word16 = 416 +primOpTag IndexOffAddrOp_Word32 = 417 +primOpTag IndexOffAddrOp_Word64 = 418 +primOpTag ReadOffAddrOp_Char = 419 +primOpTag ReadOffAddrOp_WideChar = 420 +primOpTag ReadOffAddrOp_Int = 421 +primOpTag ReadOffAddrOp_Word = 422 +primOpTag ReadOffAddrOp_Addr = 423 +primOpTag ReadOffAddrOp_Float = 424 +primOpTag ReadOffAddrOp_Double = 425 +primOpTag ReadOffAddrOp_StablePtr = 426 +primOpTag ReadOffAddrOp_Int8 = 427 +primOpTag ReadOffAddrOp_Int16 = 428 +primOpTag ReadOffAddrOp_Int32 = 429 +primOpTag ReadOffAddrOp_Int64 = 430 +primOpTag ReadOffAddrOp_Word8 = 431 +primOpTag ReadOffAddrOp_Word16 = 432 +primOpTag ReadOffAddrOp_Word32 = 433 +primOpTag ReadOffAddrOp_Word64 = 434 +primOpTag WriteOffAddrOp_Char = 435 +primOpTag WriteOffAddrOp_WideChar = 436 +primOpTag WriteOffAddrOp_Int = 437 +primOpTag WriteOffAddrOp_Word = 438 +primOpTag WriteOffAddrOp_Addr = 439 +primOpTag WriteOffAddrOp_Float = 440 +primOpTag WriteOffAddrOp_Double = 441 +primOpTag WriteOffAddrOp_StablePtr = 442 +primOpTag WriteOffAddrOp_Int8 = 443 +primOpTag WriteOffAddrOp_Int16 = 444 +primOpTag WriteOffAddrOp_Int32 = 445 +primOpTag WriteOffAddrOp_Int64 = 446 +primOpTag WriteOffAddrOp_Word8 = 447 +primOpTag WriteOffAddrOp_Word16 = 448 +primOpTag WriteOffAddrOp_Word32 = 449 +primOpTag WriteOffAddrOp_Word64 = 450 +primOpTag NewMutVarOp = 451 +primOpTag ReadMutVarOp = 452 +primOpTag WriteMutVarOp = 453 +primOpTag SameMutVarOp = 454 +primOpTag AtomicModifyMutVar2Op = 455 +primOpTag AtomicModifyMutVar_Op = 456 +primOpTag CasMutVarOp = 457 +primOpTag CatchOp = 458 +primOpTag RaiseOp = 459 +primOpTag RaiseIOOp = 460 +primOpTag MaskAsyncExceptionsOp = 461 +primOpTag MaskUninterruptibleOp = 462 +primOpTag UnmaskAsyncExceptionsOp = 463 +primOpTag MaskStatus = 464 +primOpTag AtomicallyOp = 465 +primOpTag RetryOp = 466 +primOpTag CatchRetryOp = 467 +primOpTag CatchSTMOp = 468 +primOpTag NewTVarOp = 469 +primOpTag ReadTVarOp = 470 +primOpTag ReadTVarIOOp = 471 +primOpTag WriteTVarOp = 472 +primOpTag SameTVarOp = 473 +primOpTag NewMVarOp = 474 +primOpTag TakeMVarOp = 475 +primOpTag TryTakeMVarOp = 476 +primOpTag PutMVarOp = 477 +primOpTag TryPutMVarOp = 478 +primOpTag ReadMVarOp = 479 +primOpTag TryReadMVarOp = 480 +primOpTag SameMVarOp = 481 +primOpTag IsEmptyMVarOp = 482 +primOpTag DelayOp = 483 +primOpTag WaitReadOp = 484 +primOpTag WaitWriteOp = 485 +primOpTag ForkOp = 486 +primOpTag ForkOnOp = 487 +primOpTag KillThreadOp = 488 +primOpTag YieldOp = 489 +primOpTag MyThreadIdOp = 490 +primOpTag LabelThreadOp = 491 +primOpTag IsCurrentThreadBoundOp = 492 +primOpTag NoDuplicateOp = 493 +primOpTag ThreadStatusOp = 494 +primOpTag MkWeakOp = 495 +primOpTag MkWeakNoFinalizerOp = 496 +primOpTag AddCFinalizerToWeakOp = 497 +primOpTag DeRefWeakOp = 498 +primOpTag FinalizeWeakOp = 499 +primOpTag TouchOp = 500 +primOpTag MakeStablePtrOp = 501 +primOpTag DeRefStablePtrOp = 502 +primOpTag EqStablePtrOp = 503 +primOpTag MakeStableNameOp = 504 +primOpTag EqStableNameOp = 505 +primOpTag StableNameToIntOp = 506 +primOpTag CompactNewOp = 507 +primOpTag CompactResizeOp = 508 +primOpTag CompactContainsOp = 509 +primOpTag CompactContainsAnyOp = 510 +primOpTag CompactGetFirstBlockOp = 511 +primOpTag CompactGetNextBlockOp = 512 +primOpTag CompactAllocateBlockOp = 513 +primOpTag CompactFixupPointersOp = 514 +primOpTag CompactAdd = 515 +primOpTag CompactAddWithSharing = 516 +primOpTag CompactSize = 517 +primOpTag ReallyUnsafePtrEqualityOp = 518 +primOpTag ParOp = 519 +primOpTag SparkOp = 520 +primOpTag SeqOp = 521 +primOpTag GetSparkOp = 522 +primOpTag NumSparks = 523 +primOpTag DataToTagOp = 524 +primOpTag TagToEnumOp = 525 +primOpTag AddrToAnyOp = 526 +primOpTag AnyToAddrOp = 527 +primOpTag MkApUpd0_Op = 528 +primOpTag NewBCOOp = 529 +primOpTag UnpackClosureOp = 530 +primOpTag ClosureSizeOp = 531 +primOpTag GetApStackValOp = 532 +primOpTag GetCCSOfOp = 533 +primOpTag GetCurrentCCSOp = 534 +primOpTag ClearCCSOp = 535 +primOpTag TraceEventOp = 536 +primOpTag TraceEventBinaryOp = 537 +primOpTag TraceMarkerOp = 538 +primOpTag GetThreadAllocationCounter = 539 +primOpTag SetThreadAllocationCounter = 540 +primOpTag (VecBroadcastOp IntVec 16 W8) = 541 +primOpTag (VecBroadcastOp IntVec 8 W16) = 542 +primOpTag (VecBroadcastOp IntVec 4 W32) = 543 +primOpTag (VecBroadcastOp IntVec 2 W64) = 544 +primOpTag (VecBroadcastOp IntVec 32 W8) = 545 +primOpTag (VecBroadcastOp IntVec 16 W16) = 546 +primOpTag (VecBroadcastOp IntVec 8 W32) = 547 +primOpTag (VecBroadcastOp IntVec 4 W64) = 548 +primOpTag (VecBroadcastOp IntVec 64 W8) = 549 +primOpTag (VecBroadcastOp IntVec 32 W16) = 550 +primOpTag (VecBroadcastOp IntVec 16 W32) = 551 +primOpTag (VecBroadcastOp IntVec 8 W64) = 552 +primOpTag (VecBroadcastOp WordVec 16 W8) = 553 +primOpTag (VecBroadcastOp WordVec 8 W16) = 554 +primOpTag (VecBroadcastOp WordVec 4 W32) = 555 +primOpTag (VecBroadcastOp WordVec 2 W64) = 556 +primOpTag (VecBroadcastOp WordVec 32 W8) = 557 +primOpTag (VecBroadcastOp WordVec 16 W16) = 558 +primOpTag (VecBroadcastOp WordVec 8 W32) = 559 +primOpTag (VecBroadcastOp WordVec 4 W64) = 560 +primOpTag (VecBroadcastOp WordVec 64 W8) = 561 +primOpTag (VecBroadcastOp WordVec 32 W16) = 562 +primOpTag (VecBroadcastOp WordVec 16 W32) = 563 +primOpTag (VecBroadcastOp WordVec 8 W64) = 564 +primOpTag (VecBroadcastOp FloatVec 4 W32) = 565 +primOpTag (VecBroadcastOp FloatVec 2 W64) = 566 +primOpTag (VecBroadcastOp FloatVec 8 W32) = 567 +primOpTag (VecBroadcastOp FloatVec 4 W64) = 568 +primOpTag (VecBroadcastOp FloatVec 16 W32) = 569 +primOpTag (VecBroadcastOp FloatVec 8 W64) = 570 +primOpTag (VecPackOp IntVec 16 W8) = 571 +primOpTag (VecPackOp IntVec 8 W16) = 572 +primOpTag (VecPackOp IntVec 4 W32) = 573 +primOpTag (VecPackOp IntVec 2 W64) = 574 +primOpTag (VecPackOp IntVec 32 W8) = 575 +primOpTag (VecPackOp IntVec 16 W16) = 576 +primOpTag (VecPackOp IntVec 8 W32) = 577 +primOpTag (VecPackOp IntVec 4 W64) = 578 +primOpTag (VecPackOp IntVec 64 W8) = 579 +primOpTag (VecPackOp IntVec 32 W16) = 580 +primOpTag (VecPackOp IntVec 16 W32) = 581 +primOpTag (VecPackOp IntVec 8 W64) = 582 +primOpTag (VecPackOp WordVec 16 W8) = 583 +primOpTag (VecPackOp WordVec 8 W16) = 584 +primOpTag (VecPackOp WordVec 4 W32) = 585 +primOpTag (VecPackOp WordVec 2 W64) = 586 +primOpTag (VecPackOp WordVec 32 W8) = 587 +primOpTag (VecPackOp WordVec 16 W16) = 588 +primOpTag (VecPackOp WordVec 8 W32) = 589 +primOpTag (VecPackOp WordVec 4 W64) = 590 +primOpTag (VecPackOp WordVec 64 W8) = 591 +primOpTag (VecPackOp WordVec 32 W16) = 592 +primOpTag (VecPackOp WordVec 16 W32) = 593 +primOpTag (VecPackOp WordVec 8 W64) = 594 +primOpTag (VecPackOp FloatVec 4 W32) = 595 +primOpTag (VecPackOp FloatVec 2 W64) = 596 +primOpTag (VecPackOp FloatVec 8 W32) = 597 +primOpTag (VecPackOp FloatVec 4 W64) = 598 +primOpTag (VecPackOp FloatVec 16 W32) = 599 +primOpTag (VecPackOp FloatVec 8 W64) = 600 +primOpTag (VecUnpackOp IntVec 16 W8) = 601 +primOpTag (VecUnpackOp IntVec 8 W16) = 602 +primOpTag (VecUnpackOp IntVec 4 W32) = 603 +primOpTag (VecUnpackOp IntVec 2 W64) = 604 +primOpTag (VecUnpackOp IntVec 32 W8) = 605 +primOpTag (VecUnpackOp IntVec 16 W16) = 606 +primOpTag (VecUnpackOp IntVec 8 W32) = 607 +primOpTag (VecUnpackOp IntVec 4 W64) = 608 +primOpTag (VecUnpackOp IntVec 64 W8) = 609 +primOpTag (VecUnpackOp IntVec 32 W16) = 610 +primOpTag (VecUnpackOp IntVec 16 W32) = 611 +primOpTag (VecUnpackOp IntVec 8 W64) = 612 +primOpTag (VecUnpackOp WordVec 16 W8) = 613 +primOpTag (VecUnpackOp WordVec 8 W16) = 614 +primOpTag (VecUnpackOp WordVec 4 W32) = 615 +primOpTag (VecUnpackOp WordVec 2 W64) = 616 +primOpTag (VecUnpackOp WordVec 32 W8) = 617 +primOpTag (VecUnpackOp WordVec 16 W16) = 618 +primOpTag (VecUnpackOp WordVec 8 W32) = 619 +primOpTag (VecUnpackOp WordVec 4 W64) = 620 +primOpTag (VecUnpackOp WordVec 64 W8) = 621 +primOpTag (VecUnpackOp WordVec 32 W16) = 622 +primOpTag (VecUnpackOp WordVec 16 W32) = 623 +primOpTag (VecUnpackOp WordVec 8 W64) = 624 +primOpTag (VecUnpackOp FloatVec 4 W32) = 625 +primOpTag (VecUnpackOp FloatVec 2 W64) = 626 +primOpTag (VecUnpackOp FloatVec 8 W32) = 627 +primOpTag (VecUnpackOp FloatVec 4 W64) = 628 +primOpTag (VecUnpackOp FloatVec 16 W32) = 629 +primOpTag (VecUnpackOp FloatVec 8 W64) = 630 +primOpTag (VecInsertOp IntVec 16 W8) = 631 +primOpTag (VecInsertOp IntVec 8 W16) = 632 +primOpTag (VecInsertOp IntVec 4 W32) = 633 +primOpTag (VecInsertOp IntVec 2 W64) = 634 +primOpTag (VecInsertOp IntVec 32 W8) = 635 +primOpTag (VecInsertOp IntVec 16 W16) = 636 +primOpTag (VecInsertOp IntVec 8 W32) = 637 +primOpTag (VecInsertOp IntVec 4 W64) = 638 +primOpTag (VecInsertOp IntVec 64 W8) = 639 +primOpTag (VecInsertOp IntVec 32 W16) = 640 +primOpTag (VecInsertOp IntVec 16 W32) = 641 +primOpTag (VecInsertOp IntVec 8 W64) = 642 +primOpTag (VecInsertOp WordVec 16 W8) = 643 +primOpTag (VecInsertOp WordVec 8 W16) = 644 +primOpTag (VecInsertOp WordVec 4 W32) = 645 +primOpTag (VecInsertOp WordVec 2 W64) = 646 +primOpTag (VecInsertOp WordVec 32 W8) = 647 +primOpTag (VecInsertOp WordVec 16 W16) = 648 +primOpTag (VecInsertOp WordVec 8 W32) = 649 +primOpTag (VecInsertOp WordVec 4 W64) = 650 +primOpTag (VecInsertOp WordVec 64 W8) = 651 +primOpTag (VecInsertOp WordVec 32 W16) = 652 +primOpTag (VecInsertOp WordVec 16 W32) = 653 +primOpTag (VecInsertOp WordVec 8 W64) = 654 +primOpTag (VecInsertOp FloatVec 4 W32) = 655 +primOpTag (VecInsertOp FloatVec 2 W64) = 656 +primOpTag (VecInsertOp FloatVec 8 W32) = 657 +primOpTag (VecInsertOp FloatVec 4 W64) = 658 +primOpTag (VecInsertOp FloatVec 16 W32) = 659 +primOpTag (VecInsertOp FloatVec 8 W64) = 660 +primOpTag (VecAddOp IntVec 16 W8) = 661 +primOpTag (VecAddOp IntVec 8 W16) = 662 +primOpTag (VecAddOp IntVec 4 W32) = 663 +primOpTag (VecAddOp IntVec 2 W64) = 664 +primOpTag (VecAddOp IntVec 32 W8) = 665 +primOpTag (VecAddOp IntVec 16 W16) = 666 +primOpTag (VecAddOp IntVec 8 W32) = 667 +primOpTag (VecAddOp IntVec 4 W64) = 668 +primOpTag (VecAddOp IntVec 64 W8) = 669 +primOpTag (VecAddOp IntVec 32 W16) = 670 +primOpTag (VecAddOp IntVec 16 W32) = 671 +primOpTag (VecAddOp IntVec 8 W64) = 672 +primOpTag (VecAddOp WordVec 16 W8) = 673 +primOpTag (VecAddOp WordVec 8 W16) = 674 +primOpTag (VecAddOp WordVec 4 W32) = 675 +primOpTag (VecAddOp WordVec 2 W64) = 676 +primOpTag (VecAddOp WordVec 32 W8) = 677 +primOpTag (VecAddOp WordVec 16 W16) = 678 +primOpTag (VecAddOp WordVec 8 W32) = 679 +primOpTag (VecAddOp WordVec 4 W64) = 680 +primOpTag (VecAddOp WordVec 64 W8) = 681 +primOpTag (VecAddOp WordVec 32 W16) = 682 +primOpTag (VecAddOp WordVec 16 W32) = 683 +primOpTag (VecAddOp WordVec 8 W64) = 684 +primOpTag (VecAddOp FloatVec 4 W32) = 685 +primOpTag (VecAddOp FloatVec 2 W64) = 686 +primOpTag (VecAddOp FloatVec 8 W32) = 687 +primOpTag (VecAddOp FloatVec 4 W64) = 688 +primOpTag (VecAddOp FloatVec 16 W32) = 689 +primOpTag (VecAddOp FloatVec 8 W64) = 690 +primOpTag (VecSubOp IntVec 16 W8) = 691 +primOpTag (VecSubOp IntVec 8 W16) = 692 +primOpTag (VecSubOp IntVec 4 W32) = 693 +primOpTag (VecSubOp IntVec 2 W64) = 694 +primOpTag (VecSubOp IntVec 32 W8) = 695 +primOpTag (VecSubOp IntVec 16 W16) = 696 +primOpTag (VecSubOp IntVec 8 W32) = 697 +primOpTag (VecSubOp IntVec 4 W64) = 698 +primOpTag (VecSubOp IntVec 64 W8) = 699 +primOpTag (VecSubOp IntVec 32 W16) = 700 +primOpTag (VecSubOp IntVec 16 W32) = 701 +primOpTag (VecSubOp IntVec 8 W64) = 702 +primOpTag (VecSubOp WordVec 16 W8) = 703 +primOpTag (VecSubOp WordVec 8 W16) = 704 +primOpTag (VecSubOp WordVec 4 W32) = 705 +primOpTag (VecSubOp WordVec 2 W64) = 706 +primOpTag (VecSubOp WordVec 32 W8) = 707 +primOpTag (VecSubOp WordVec 16 W16) = 708 +primOpTag (VecSubOp WordVec 8 W32) = 709 +primOpTag (VecSubOp WordVec 4 W64) = 710 +primOpTag (VecSubOp WordVec 64 W8) = 711 +primOpTag (VecSubOp WordVec 32 W16) = 712 +primOpTag (VecSubOp WordVec 16 W32) = 713 +primOpTag (VecSubOp WordVec 8 W64) = 714 +primOpTag (VecSubOp FloatVec 4 W32) = 715 +primOpTag (VecSubOp FloatVec 2 W64) = 716 +primOpTag (VecSubOp FloatVec 8 W32) = 717 +primOpTag (VecSubOp FloatVec 4 W64) = 718 +primOpTag (VecSubOp FloatVec 16 W32) = 719 +primOpTag (VecSubOp FloatVec 8 W64) = 720 +primOpTag (VecMulOp IntVec 16 W8) = 721 +primOpTag (VecMulOp IntVec 8 W16) = 722 +primOpTag (VecMulOp IntVec 4 W32) = 723 +primOpTag (VecMulOp IntVec 2 W64) = 724 +primOpTag (VecMulOp IntVec 32 W8) = 725 +primOpTag (VecMulOp IntVec 16 W16) = 726 +primOpTag (VecMulOp IntVec 8 W32) = 727 +primOpTag (VecMulOp IntVec 4 W64) = 728 +primOpTag (VecMulOp IntVec 64 W8) = 729 +primOpTag (VecMulOp IntVec 32 W16) = 730 +primOpTag (VecMulOp IntVec 16 W32) = 731 +primOpTag (VecMulOp IntVec 8 W64) = 732 +primOpTag (VecMulOp WordVec 16 W8) = 733 +primOpTag (VecMulOp WordVec 8 W16) = 734 +primOpTag (VecMulOp WordVec 4 W32) = 735 +primOpTag (VecMulOp WordVec 2 W64) = 736 +primOpTag (VecMulOp WordVec 32 W8) = 737 +primOpTag (VecMulOp WordVec 16 W16) = 738 +primOpTag (VecMulOp WordVec 8 W32) = 739 +primOpTag (VecMulOp WordVec 4 W64) = 740 +primOpTag (VecMulOp WordVec 64 W8) = 741 +primOpTag (VecMulOp WordVec 32 W16) = 742 +primOpTag (VecMulOp WordVec 16 W32) = 743 +primOpTag (VecMulOp WordVec 8 W64) = 744 +primOpTag (VecMulOp FloatVec 4 W32) = 745 +primOpTag (VecMulOp FloatVec 2 W64) = 746 +primOpTag (VecMulOp FloatVec 8 W32) = 747 +primOpTag (VecMulOp FloatVec 4 W64) = 748 +primOpTag (VecMulOp FloatVec 16 W32) = 749 +primOpTag (VecMulOp FloatVec 8 W64) = 750 +primOpTag (VecDivOp FloatVec 4 W32) = 751 +primOpTag (VecDivOp FloatVec 2 W64) = 752 +primOpTag (VecDivOp FloatVec 8 W32) = 753 +primOpTag (VecDivOp FloatVec 4 W64) = 754 +primOpTag (VecDivOp FloatVec 16 W32) = 755 +primOpTag (VecDivOp FloatVec 8 W64) = 756 +primOpTag (VecQuotOp IntVec 16 W8) = 757 +primOpTag (VecQuotOp IntVec 8 W16) = 758 +primOpTag (VecQuotOp IntVec 4 W32) = 759 +primOpTag (VecQuotOp IntVec 2 W64) = 760 +primOpTag (VecQuotOp IntVec 32 W8) = 761 +primOpTag (VecQuotOp IntVec 16 W16) = 762 +primOpTag (VecQuotOp IntVec 8 W32) = 763 +primOpTag (VecQuotOp IntVec 4 W64) = 764 +primOpTag (VecQuotOp IntVec 64 W8) = 765 +primOpTag (VecQuotOp IntVec 32 W16) = 766 +primOpTag (VecQuotOp IntVec 16 W32) = 767 +primOpTag (VecQuotOp IntVec 8 W64) = 768 +primOpTag (VecQuotOp WordVec 16 W8) = 769 +primOpTag (VecQuotOp WordVec 8 W16) = 770 +primOpTag (VecQuotOp WordVec 4 W32) = 771 +primOpTag (VecQuotOp WordVec 2 W64) = 772 +primOpTag (VecQuotOp WordVec 32 W8) = 773 +primOpTag (VecQuotOp WordVec 16 W16) = 774 +primOpTag (VecQuotOp WordVec 8 W32) = 775 +primOpTag (VecQuotOp WordVec 4 W64) = 776 +primOpTag (VecQuotOp WordVec 64 W8) = 777 +primOpTag (VecQuotOp WordVec 32 W16) = 778 +primOpTag (VecQuotOp WordVec 16 W32) = 779 +primOpTag (VecQuotOp WordVec 8 W64) = 780 +primOpTag (VecRemOp IntVec 16 W8) = 781 +primOpTag (VecRemOp IntVec 8 W16) = 782 +primOpTag (VecRemOp IntVec 4 W32) = 783 +primOpTag (VecRemOp IntVec 2 W64) = 784 +primOpTag (VecRemOp IntVec 32 W8) = 785 +primOpTag (VecRemOp IntVec 16 W16) = 786 +primOpTag (VecRemOp IntVec 8 W32) = 787 +primOpTag (VecRemOp IntVec 4 W64) = 788 +primOpTag (VecRemOp IntVec 64 W8) = 789 +primOpTag (VecRemOp IntVec 32 W16) = 790 +primOpTag (VecRemOp IntVec 16 W32) = 791 +primOpTag (VecRemOp IntVec 8 W64) = 792 +primOpTag (VecRemOp WordVec 16 W8) = 793 +primOpTag (VecRemOp WordVec 8 W16) = 794 +primOpTag (VecRemOp WordVec 4 W32) = 795 +primOpTag (VecRemOp WordVec 2 W64) = 796 +primOpTag (VecRemOp WordVec 32 W8) = 797 +primOpTag (VecRemOp WordVec 16 W16) = 798 +primOpTag (VecRemOp WordVec 8 W32) = 799 +primOpTag (VecRemOp WordVec 4 W64) = 800 +primOpTag (VecRemOp WordVec 64 W8) = 801 +primOpTag (VecRemOp WordVec 32 W16) = 802 +primOpTag (VecRemOp WordVec 16 W32) = 803 +primOpTag (VecRemOp WordVec 8 W64) = 804 +primOpTag (VecNegOp IntVec 16 W8) = 805 +primOpTag (VecNegOp IntVec 8 W16) = 806 +primOpTag (VecNegOp IntVec 4 W32) = 807 +primOpTag (VecNegOp IntVec 2 W64) = 808 +primOpTag (VecNegOp IntVec 32 W8) = 809 +primOpTag (VecNegOp IntVec 16 W16) = 810 +primOpTag (VecNegOp IntVec 8 W32) = 811 +primOpTag (VecNegOp IntVec 4 W64) = 812 +primOpTag (VecNegOp IntVec 64 W8) = 813 +primOpTag (VecNegOp IntVec 32 W16) = 814 +primOpTag (VecNegOp IntVec 16 W32) = 815 +primOpTag (VecNegOp IntVec 8 W64) = 816 +primOpTag (VecNegOp FloatVec 4 W32) = 817 +primOpTag (VecNegOp FloatVec 2 W64) = 818 +primOpTag (VecNegOp FloatVec 8 W32) = 819 +primOpTag (VecNegOp FloatVec 4 W64) = 820 +primOpTag (VecNegOp FloatVec 16 W32) = 821 +primOpTag (VecNegOp FloatVec 8 W64) = 822 +primOpTag (VecIndexByteArrayOp IntVec 16 W8) = 823 +primOpTag (VecIndexByteArrayOp IntVec 8 W16) = 824 +primOpTag (VecIndexByteArrayOp IntVec 4 W32) = 825 +primOpTag (VecIndexByteArrayOp IntVec 2 W64) = 826 +primOpTag (VecIndexByteArrayOp IntVec 32 W8) = 827 +primOpTag (VecIndexByteArrayOp IntVec 16 W16) = 828 +primOpTag (VecIndexByteArrayOp IntVec 8 W32) = 829 +primOpTag (VecIndexByteArrayOp IntVec 4 W64) = 830 +primOpTag (VecIndexByteArrayOp IntVec 64 W8) = 831 +primOpTag (VecIndexByteArrayOp IntVec 32 W16) = 832 +primOpTag (VecIndexByteArrayOp IntVec 16 W32) = 833 +primOpTag (VecIndexByteArrayOp IntVec 8 W64) = 834 +primOpTag (VecIndexByteArrayOp WordVec 16 W8) = 835 +primOpTag (VecIndexByteArrayOp WordVec 8 W16) = 836 +primOpTag (VecIndexByteArrayOp WordVec 4 W32) = 837 +primOpTag (VecIndexByteArrayOp WordVec 2 W64) = 838 +primOpTag (VecIndexByteArrayOp WordVec 32 W8) = 839 +primOpTag (VecIndexByteArrayOp WordVec 16 W16) = 840 +primOpTag (VecIndexByteArrayOp WordVec 8 W32) = 841 +primOpTag (VecIndexByteArrayOp WordVec 4 W64) = 842 +primOpTag (VecIndexByteArrayOp WordVec 64 W8) = 843 +primOpTag (VecIndexByteArrayOp WordVec 32 W16) = 844 +primOpTag (VecIndexByteArrayOp WordVec 16 W32) = 845 +primOpTag (VecIndexByteArrayOp WordVec 8 W64) = 846 +primOpTag (VecIndexByteArrayOp FloatVec 4 W32) = 847 +primOpTag (VecIndexByteArrayOp FloatVec 2 W64) = 848 +primOpTag (VecIndexByteArrayOp FloatVec 8 W32) = 849 +primOpTag (VecIndexByteArrayOp FloatVec 4 W64) = 850 +primOpTag (VecIndexByteArrayOp FloatVec 16 W32) = 851 +primOpTag (VecIndexByteArrayOp FloatVec 8 W64) = 852 +primOpTag (VecReadByteArrayOp IntVec 16 W8) = 853 +primOpTag (VecReadByteArrayOp IntVec 8 W16) = 854 +primOpTag (VecReadByteArrayOp IntVec 4 W32) = 855 +primOpTag (VecReadByteArrayOp IntVec 2 W64) = 856 +primOpTag (VecReadByteArrayOp IntVec 32 W8) = 857 +primOpTag (VecReadByteArrayOp IntVec 16 W16) = 858 +primOpTag (VecReadByteArrayOp IntVec 8 W32) = 859 +primOpTag (VecReadByteArrayOp IntVec 4 W64) = 860 +primOpTag (VecReadByteArrayOp IntVec 64 W8) = 861 +primOpTag (VecReadByteArrayOp IntVec 32 W16) = 862 +primOpTag (VecReadByteArrayOp IntVec 16 W32) = 863 +primOpTag (VecReadByteArrayOp IntVec 8 W64) = 864 +primOpTag (VecReadByteArrayOp WordVec 16 W8) = 865 +primOpTag (VecReadByteArrayOp WordVec 8 W16) = 866 +primOpTag (VecReadByteArrayOp WordVec 4 W32) = 867 +primOpTag (VecReadByteArrayOp WordVec 2 W64) = 868 +primOpTag (VecReadByteArrayOp WordVec 32 W8) = 869 +primOpTag (VecReadByteArrayOp WordVec 16 W16) = 870 +primOpTag (VecReadByteArrayOp WordVec 8 W32) = 871 +primOpTag (VecReadByteArrayOp WordVec 4 W64) = 872 +primOpTag (VecReadByteArrayOp WordVec 64 W8) = 873 +primOpTag (VecReadByteArrayOp WordVec 32 W16) = 874 +primOpTag (VecReadByteArrayOp WordVec 16 W32) = 875 +primOpTag (VecReadByteArrayOp WordVec 8 W64) = 876 +primOpTag (VecReadByteArrayOp FloatVec 4 W32) = 877 +primOpTag (VecReadByteArrayOp FloatVec 2 W64) = 878 +primOpTag (VecReadByteArrayOp FloatVec 8 W32) = 879 +primOpTag (VecReadByteArrayOp FloatVec 4 W64) = 880 +primOpTag (VecReadByteArrayOp FloatVec 16 W32) = 881 +primOpTag (VecReadByteArrayOp FloatVec 8 W64) = 882 +primOpTag (VecWriteByteArrayOp IntVec 16 W8) = 883 +primOpTag (VecWriteByteArrayOp IntVec 8 W16) = 884 +primOpTag (VecWriteByteArrayOp IntVec 4 W32) = 885 +primOpTag (VecWriteByteArrayOp IntVec 2 W64) = 886 +primOpTag (VecWriteByteArrayOp IntVec 32 W8) = 887 +primOpTag (VecWriteByteArrayOp IntVec 16 W16) = 888 +primOpTag (VecWriteByteArrayOp IntVec 8 W32) = 889 +primOpTag (VecWriteByteArrayOp IntVec 4 W64) = 890 +primOpTag (VecWriteByteArrayOp IntVec 64 W8) = 891 +primOpTag (VecWriteByteArrayOp IntVec 32 W16) = 892 +primOpTag (VecWriteByteArrayOp IntVec 16 W32) = 893 +primOpTag (VecWriteByteArrayOp IntVec 8 W64) = 894 +primOpTag (VecWriteByteArrayOp WordVec 16 W8) = 895 +primOpTag (VecWriteByteArrayOp WordVec 8 W16) = 896 +primOpTag (VecWriteByteArrayOp WordVec 4 W32) = 897 +primOpTag (VecWriteByteArrayOp WordVec 2 W64) = 898 +primOpTag (VecWriteByteArrayOp WordVec 32 W8) = 899 +primOpTag (VecWriteByteArrayOp WordVec 16 W16) = 900 +primOpTag (VecWriteByteArrayOp WordVec 8 W32) = 901 +primOpTag (VecWriteByteArrayOp WordVec 4 W64) = 902 +primOpTag (VecWriteByteArrayOp WordVec 64 W8) = 903 +primOpTag (VecWriteByteArrayOp WordVec 32 W16) = 904 +primOpTag (VecWriteByteArrayOp WordVec 16 W32) = 905 +primOpTag (VecWriteByteArrayOp WordVec 8 W64) = 906 +primOpTag (VecWriteByteArrayOp FloatVec 4 W32) = 907 +primOpTag (VecWriteByteArrayOp FloatVec 2 W64) = 908 +primOpTag (VecWriteByteArrayOp FloatVec 8 W32) = 909 +primOpTag (VecWriteByteArrayOp FloatVec 4 W64) = 910 +primOpTag (VecWriteByteArrayOp FloatVec 16 W32) = 911 +primOpTag (VecWriteByteArrayOp FloatVec 8 W64) = 912 +primOpTag (VecIndexOffAddrOp IntVec 16 W8) = 913 +primOpTag (VecIndexOffAddrOp IntVec 8 W16) = 914 +primOpTag (VecIndexOffAddrOp IntVec 4 W32) = 915 +primOpTag (VecIndexOffAddrOp IntVec 2 W64) = 916 +primOpTag (VecIndexOffAddrOp IntVec 32 W8) = 917 +primOpTag (VecIndexOffAddrOp IntVec 16 W16) = 918 +primOpTag (VecIndexOffAddrOp IntVec 8 W32) = 919 +primOpTag (VecIndexOffAddrOp IntVec 4 W64) = 920 +primOpTag (VecIndexOffAddrOp IntVec 64 W8) = 921 +primOpTag (VecIndexOffAddrOp IntVec 32 W16) = 922 +primOpTag (VecIndexOffAddrOp IntVec 16 W32) = 923 +primOpTag (VecIndexOffAddrOp IntVec 8 W64) = 924 +primOpTag (VecIndexOffAddrOp WordVec 16 W8) = 925 +primOpTag (VecIndexOffAddrOp WordVec 8 W16) = 926 +primOpTag (VecIndexOffAddrOp WordVec 4 W32) = 927 +primOpTag (VecIndexOffAddrOp WordVec 2 W64) = 928 +primOpTag (VecIndexOffAddrOp WordVec 32 W8) = 929 +primOpTag (VecIndexOffAddrOp WordVec 16 W16) = 930 +primOpTag (VecIndexOffAddrOp WordVec 8 W32) = 931 +primOpTag (VecIndexOffAddrOp WordVec 4 W64) = 932 +primOpTag (VecIndexOffAddrOp WordVec 64 W8) = 933 +primOpTag (VecIndexOffAddrOp WordVec 32 W16) = 934 +primOpTag (VecIndexOffAddrOp WordVec 16 W32) = 935 +primOpTag (VecIndexOffAddrOp WordVec 8 W64) = 936 +primOpTag (VecIndexOffAddrOp FloatVec 4 W32) = 937 +primOpTag (VecIndexOffAddrOp FloatVec 2 W64) = 938 +primOpTag (VecIndexOffAddrOp FloatVec 8 W32) = 939 +primOpTag (VecIndexOffAddrOp FloatVec 4 W64) = 940 +primOpTag (VecIndexOffAddrOp FloatVec 16 W32) = 941 +primOpTag (VecIndexOffAddrOp FloatVec 8 W64) = 942 +primOpTag (VecReadOffAddrOp IntVec 16 W8) = 943 +primOpTag (VecReadOffAddrOp IntVec 8 W16) = 944 +primOpTag (VecReadOffAddrOp IntVec 4 W32) = 945 +primOpTag (VecReadOffAddrOp IntVec 2 W64) = 946 +primOpTag (VecReadOffAddrOp IntVec 32 W8) = 947 +primOpTag (VecReadOffAddrOp IntVec 16 W16) = 948 +primOpTag (VecReadOffAddrOp IntVec 8 W32) = 949 +primOpTag (VecReadOffAddrOp IntVec 4 W64) = 950 +primOpTag (VecReadOffAddrOp IntVec 64 W8) = 951 +primOpTag (VecReadOffAddrOp IntVec 32 W16) = 952 +primOpTag (VecReadOffAddrOp IntVec 16 W32) = 953 +primOpTag (VecReadOffAddrOp IntVec 8 W64) = 954 +primOpTag (VecReadOffAddrOp WordVec 16 W8) = 955 +primOpTag (VecReadOffAddrOp WordVec 8 W16) = 956 +primOpTag (VecReadOffAddrOp WordVec 4 W32) = 957 +primOpTag (VecReadOffAddrOp WordVec 2 W64) = 958 +primOpTag (VecReadOffAddrOp WordVec 32 W8) = 959 +primOpTag (VecReadOffAddrOp WordVec 16 W16) = 960 +primOpTag (VecReadOffAddrOp WordVec 8 W32) = 961 +primOpTag (VecReadOffAddrOp WordVec 4 W64) = 962 +primOpTag (VecReadOffAddrOp WordVec 64 W8) = 963 +primOpTag (VecReadOffAddrOp WordVec 32 W16) = 964 +primOpTag (VecReadOffAddrOp WordVec 16 W32) = 965 +primOpTag (VecReadOffAddrOp WordVec 8 W64) = 966 +primOpTag (VecReadOffAddrOp FloatVec 4 W32) = 967 +primOpTag (VecReadOffAddrOp FloatVec 2 W64) = 968 +primOpTag (VecReadOffAddrOp FloatVec 8 W32) = 969 +primOpTag (VecReadOffAddrOp FloatVec 4 W64) = 970 +primOpTag (VecReadOffAddrOp FloatVec 16 W32) = 971 +primOpTag (VecReadOffAddrOp FloatVec 8 W64) = 972 +primOpTag (VecWriteOffAddrOp IntVec 16 W8) = 973 +primOpTag (VecWriteOffAddrOp IntVec 8 W16) = 974 +primOpTag (VecWriteOffAddrOp IntVec 4 W32) = 975 +primOpTag (VecWriteOffAddrOp IntVec 2 W64) = 976 +primOpTag (VecWriteOffAddrOp IntVec 32 W8) = 977 +primOpTag (VecWriteOffAddrOp IntVec 16 W16) = 978 +primOpTag (VecWriteOffAddrOp IntVec 8 W32) = 979 +primOpTag (VecWriteOffAddrOp IntVec 4 W64) = 980 +primOpTag (VecWriteOffAddrOp IntVec 64 W8) = 981 +primOpTag (VecWriteOffAddrOp IntVec 32 W16) = 982 +primOpTag (VecWriteOffAddrOp IntVec 16 W32) = 983 +primOpTag (VecWriteOffAddrOp IntVec 8 W64) = 984 +primOpTag (VecWriteOffAddrOp WordVec 16 W8) = 985 +primOpTag (VecWriteOffAddrOp WordVec 8 W16) = 986 +primOpTag (VecWriteOffAddrOp WordVec 4 W32) = 987 +primOpTag (VecWriteOffAddrOp WordVec 2 W64) = 988 +primOpTag (VecWriteOffAddrOp WordVec 32 W8) = 989 +primOpTag (VecWriteOffAddrOp WordVec 16 W16) = 990 +primOpTag (VecWriteOffAddrOp WordVec 8 W32) = 991 +primOpTag (VecWriteOffAddrOp WordVec 4 W64) = 992 +primOpTag (VecWriteOffAddrOp WordVec 64 W8) = 993 +primOpTag (VecWriteOffAddrOp WordVec 32 W16) = 994 +primOpTag (VecWriteOffAddrOp WordVec 16 W32) = 995 +primOpTag (VecWriteOffAddrOp WordVec 8 W64) = 996 +primOpTag (VecWriteOffAddrOp FloatVec 4 W32) = 997 +primOpTag (VecWriteOffAddrOp FloatVec 2 W64) = 998 +primOpTag (VecWriteOffAddrOp FloatVec 8 W32) = 999 +primOpTag (VecWriteOffAddrOp FloatVec 4 W64) = 1000 +primOpTag (VecWriteOffAddrOp FloatVec 16 W32) = 1001 +primOpTag (VecWriteOffAddrOp FloatVec 8 W64) = 1002 +primOpTag (VecIndexScalarByteArrayOp IntVec 16 W8) = 1003 +primOpTag (VecIndexScalarByteArrayOp IntVec 8 W16) = 1004 +primOpTag (VecIndexScalarByteArrayOp IntVec 4 W32) = 1005 +primOpTag (VecIndexScalarByteArrayOp IntVec 2 W64) = 1006 +primOpTag (VecIndexScalarByteArrayOp IntVec 32 W8) = 1007 +primOpTag (VecIndexScalarByteArrayOp IntVec 16 W16) = 1008 +primOpTag (VecIndexScalarByteArrayOp IntVec 8 W32) = 1009 +primOpTag (VecIndexScalarByteArrayOp IntVec 4 W64) = 1010 +primOpTag (VecIndexScalarByteArrayOp IntVec 64 W8) = 1011 +primOpTag (VecIndexScalarByteArrayOp IntVec 32 W16) = 1012 +primOpTag (VecIndexScalarByteArrayOp IntVec 16 W32) = 1013 +primOpTag (VecIndexScalarByteArrayOp IntVec 8 W64) = 1014 +primOpTag (VecIndexScalarByteArrayOp WordVec 16 W8) = 1015 +primOpTag (VecIndexScalarByteArrayOp WordVec 8 W16) = 1016 +primOpTag (VecIndexScalarByteArrayOp WordVec 4 W32) = 1017 +primOpTag (VecIndexScalarByteArrayOp WordVec 2 W64) = 1018 +primOpTag (VecIndexScalarByteArrayOp WordVec 32 W8) = 1019 +primOpTag (VecIndexScalarByteArrayOp WordVec 16 W16) = 1020 +primOpTag (VecIndexScalarByteArrayOp WordVec 8 W32) = 1021 +primOpTag (VecIndexScalarByteArrayOp WordVec 4 W64) = 1022 +primOpTag (VecIndexScalarByteArrayOp WordVec 64 W8) = 1023 +primOpTag (VecIndexScalarByteArrayOp WordVec 32 W16) = 1024 +primOpTag (VecIndexScalarByteArrayOp WordVec 16 W32) = 1025 +primOpTag (VecIndexScalarByteArrayOp WordVec 8 W64) = 1026 +primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W32) = 1027 +primOpTag (VecIndexScalarByteArrayOp FloatVec 2 W64) = 1028 +primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W32) = 1029 +primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W64) = 1030 +primOpTag (VecIndexScalarByteArrayOp FloatVec 16 W32) = 1031 +primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W64) = 1032 +primOpTag (VecReadScalarByteArrayOp IntVec 16 W8) = 1033 +primOpTag (VecReadScalarByteArrayOp IntVec 8 W16) = 1034 +primOpTag (VecReadScalarByteArrayOp IntVec 4 W32) = 1035 +primOpTag (VecReadScalarByteArrayOp IntVec 2 W64) = 1036 +primOpTag (VecReadScalarByteArrayOp IntVec 32 W8) = 1037 +primOpTag (VecReadScalarByteArrayOp IntVec 16 W16) = 1038 +primOpTag (VecReadScalarByteArrayOp IntVec 8 W32) = 1039 +primOpTag (VecReadScalarByteArrayOp IntVec 4 W64) = 1040 +primOpTag (VecReadScalarByteArrayOp IntVec 64 W8) = 1041 +primOpTag (VecReadScalarByteArrayOp IntVec 32 W16) = 1042 +primOpTag (VecReadScalarByteArrayOp IntVec 16 W32) = 1043 +primOpTag (VecReadScalarByteArrayOp IntVec 8 W64) = 1044 +primOpTag (VecReadScalarByteArrayOp WordVec 16 W8) = 1045 +primOpTag (VecReadScalarByteArrayOp WordVec 8 W16) = 1046 +primOpTag (VecReadScalarByteArrayOp WordVec 4 W32) = 1047 +primOpTag (VecReadScalarByteArrayOp WordVec 2 W64) = 1048 +primOpTag (VecReadScalarByteArrayOp WordVec 32 W8) = 1049 +primOpTag (VecReadScalarByteArrayOp WordVec 16 W16) = 1050 +primOpTag (VecReadScalarByteArrayOp WordVec 8 W32) = 1051 +primOpTag (VecReadScalarByteArrayOp WordVec 4 W64) = 1052 +primOpTag (VecReadScalarByteArrayOp WordVec 64 W8) = 1053 +primOpTag (VecReadScalarByteArrayOp WordVec 32 W16) = 1054 +primOpTag (VecReadScalarByteArrayOp WordVec 16 W32) = 1055 +primOpTag (VecReadScalarByteArrayOp WordVec 8 W64) = 1056 +primOpTag (VecReadScalarByteArrayOp FloatVec 4 W32) = 1057 +primOpTag (VecReadScalarByteArrayOp FloatVec 2 W64) = 1058 +primOpTag (VecReadScalarByteArrayOp FloatVec 8 W32) = 1059 +primOpTag (VecReadScalarByteArrayOp FloatVec 4 W64) = 1060 +primOpTag (VecReadScalarByteArrayOp FloatVec 16 W32) = 1061 +primOpTag (VecReadScalarByteArrayOp FloatVec 8 W64) = 1062 +primOpTag (VecWriteScalarByteArrayOp IntVec 16 W8) = 1063 +primOpTag (VecWriteScalarByteArrayOp IntVec 8 W16) = 1064 +primOpTag (VecWriteScalarByteArrayOp IntVec 4 W32) = 1065 +primOpTag (VecWriteScalarByteArrayOp IntVec 2 W64) = 1066 +primOpTag (VecWriteScalarByteArrayOp IntVec 32 W8) = 1067 +primOpTag (VecWriteScalarByteArrayOp IntVec 16 W16) = 1068 +primOpTag (VecWriteScalarByteArrayOp IntVec 8 W32) = 1069 +primOpTag (VecWriteScalarByteArrayOp IntVec 4 W64) = 1070 +primOpTag (VecWriteScalarByteArrayOp IntVec 64 W8) = 1071 +primOpTag (VecWriteScalarByteArrayOp IntVec 32 W16) = 1072 +primOpTag (VecWriteScalarByteArrayOp IntVec 16 W32) = 1073 +primOpTag (VecWriteScalarByteArrayOp IntVec 8 W64) = 1074 +primOpTag (VecWriteScalarByteArrayOp WordVec 16 W8) = 1075 +primOpTag (VecWriteScalarByteArrayOp WordVec 8 W16) = 1076 +primOpTag (VecWriteScalarByteArrayOp WordVec 4 W32) = 1077 +primOpTag (VecWriteScalarByteArrayOp WordVec 2 W64) = 1078 +primOpTag (VecWriteScalarByteArrayOp WordVec 32 W8) = 1079 +primOpTag (VecWriteScalarByteArrayOp WordVec 16 W16) = 1080 +primOpTag (VecWriteScalarByteArrayOp WordVec 8 W32) = 1081 +primOpTag (VecWriteScalarByteArrayOp WordVec 4 W64) = 1082 +primOpTag (VecWriteScalarByteArrayOp WordVec 64 W8) = 1083 +primOpTag (VecWriteScalarByteArrayOp WordVec 32 W16) = 1084 +primOpTag (VecWriteScalarByteArrayOp WordVec 16 W32) = 1085 +primOpTag (VecWriteScalarByteArrayOp WordVec 8 W64) = 1086 +primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W32) = 1087 +primOpTag (VecWriteScalarByteArrayOp FloatVec 2 W64) = 1088 +primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W32) = 1089 +primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W64) = 1090 +primOpTag (VecWriteScalarByteArrayOp FloatVec 16 W32) = 1091 +primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W64) = 1092 +primOpTag (VecIndexScalarOffAddrOp IntVec 16 W8) = 1093 +primOpTag (VecIndexScalarOffAddrOp IntVec 8 W16) = 1094 +primOpTag (VecIndexScalarOffAddrOp IntVec 4 W32) = 1095 +primOpTag (VecIndexScalarOffAddrOp IntVec 2 W64) = 1096 +primOpTag (VecIndexScalarOffAddrOp IntVec 32 W8) = 1097 +primOpTag (VecIndexScalarOffAddrOp IntVec 16 W16) = 1098 +primOpTag (VecIndexScalarOffAddrOp IntVec 8 W32) = 1099 +primOpTag (VecIndexScalarOffAddrOp IntVec 4 W64) = 1100 +primOpTag (VecIndexScalarOffAddrOp IntVec 64 W8) = 1101 +primOpTag (VecIndexScalarOffAddrOp IntVec 32 W16) = 1102 +primOpTag (VecIndexScalarOffAddrOp IntVec 16 W32) = 1103 +primOpTag (VecIndexScalarOffAddrOp IntVec 8 W64) = 1104 +primOpTag (VecIndexScalarOffAddrOp WordVec 16 W8) = 1105 +primOpTag (VecIndexScalarOffAddrOp WordVec 8 W16) = 1106 +primOpTag (VecIndexScalarOffAddrOp WordVec 4 W32) = 1107 +primOpTag (VecIndexScalarOffAddrOp WordVec 2 W64) = 1108 +primOpTag (VecIndexScalarOffAddrOp WordVec 32 W8) = 1109 +primOpTag (VecIndexScalarOffAddrOp WordVec 16 W16) = 1110 +primOpTag (VecIndexScalarOffAddrOp WordVec 8 W32) = 1111 +primOpTag (VecIndexScalarOffAddrOp WordVec 4 W64) = 1112 +primOpTag (VecIndexScalarOffAddrOp WordVec 64 W8) = 1113 +primOpTag (VecIndexScalarOffAddrOp WordVec 32 W16) = 1114 +primOpTag (VecIndexScalarOffAddrOp WordVec 16 W32) = 1115 +primOpTag (VecIndexScalarOffAddrOp WordVec 8 W64) = 1116 +primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W32) = 1117 +primOpTag (VecIndexScalarOffAddrOp FloatVec 2 W64) = 1118 +primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W32) = 1119 +primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W64) = 1120 +primOpTag (VecIndexScalarOffAddrOp FloatVec 16 W32) = 1121 +primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W64) = 1122 +primOpTag (VecReadScalarOffAddrOp IntVec 16 W8) = 1123 +primOpTag (VecReadScalarOffAddrOp IntVec 8 W16) = 1124 +primOpTag (VecReadScalarOffAddrOp IntVec 4 W32) = 1125 +primOpTag (VecReadScalarOffAddrOp IntVec 2 W64) = 1126 +primOpTag (VecReadScalarOffAddrOp IntVec 32 W8) = 1127 +primOpTag (VecReadScalarOffAddrOp IntVec 16 W16) = 1128 +primOpTag (VecReadScalarOffAddrOp IntVec 8 W32) = 1129 +primOpTag (VecReadScalarOffAddrOp IntVec 4 W64) = 1130 +primOpTag (VecReadScalarOffAddrOp IntVec 64 W8) = 1131 +primOpTag (VecReadScalarOffAddrOp IntVec 32 W16) = 1132 +primOpTag (VecReadScalarOffAddrOp IntVec 16 W32) = 1133 +primOpTag (VecReadScalarOffAddrOp IntVec 8 W64) = 1134 +primOpTag (VecReadScalarOffAddrOp WordVec 16 W8) = 1135 +primOpTag (VecReadScalarOffAddrOp WordVec 8 W16) = 1136 +primOpTag (VecReadScalarOffAddrOp WordVec 4 W32) = 1137 +primOpTag (VecReadScalarOffAddrOp WordVec 2 W64) = 1138 +primOpTag (VecReadScalarOffAddrOp WordVec 32 W8) = 1139 +primOpTag (VecReadScalarOffAddrOp WordVec 16 W16) = 1140 +primOpTag (VecReadScalarOffAddrOp WordVec 8 W32) = 1141 +primOpTag (VecReadScalarOffAddrOp WordVec 4 W64) = 1142 +primOpTag (VecReadScalarOffAddrOp WordVec 64 W8) = 1143 +primOpTag (VecReadScalarOffAddrOp WordVec 32 W16) = 1144 +primOpTag (VecReadScalarOffAddrOp WordVec 16 W32) = 1145 +primOpTag (VecReadScalarOffAddrOp WordVec 8 W64) = 1146 +primOpTag (VecReadScalarOffAddrOp FloatVec 4 W32) = 1147 +primOpTag (VecReadScalarOffAddrOp FloatVec 2 W64) = 1148 +primOpTag (VecReadScalarOffAddrOp FloatVec 8 W32) = 1149 +primOpTag (VecReadScalarOffAddrOp FloatVec 4 W64) = 1150 +primOpTag (VecReadScalarOffAddrOp FloatVec 16 W32) = 1151 +primOpTag (VecReadScalarOffAddrOp FloatVec 8 W64) = 1152 +primOpTag (VecWriteScalarOffAddrOp IntVec 16 W8) = 1153 +primOpTag (VecWriteScalarOffAddrOp IntVec 8 W16) = 1154 +primOpTag (VecWriteScalarOffAddrOp IntVec 4 W32) = 1155 +primOpTag (VecWriteScalarOffAddrOp IntVec 2 W64) = 1156 +primOpTag (VecWriteScalarOffAddrOp IntVec 32 W8) = 1157 +primOpTag (VecWriteScalarOffAddrOp IntVec 16 W16) = 1158 +primOpTag (VecWriteScalarOffAddrOp IntVec 8 W32) = 1159 +primOpTag (VecWriteScalarOffAddrOp IntVec 4 W64) = 1160 +primOpTag (VecWriteScalarOffAddrOp IntVec 64 W8) = 1161 +primOpTag (VecWriteScalarOffAddrOp IntVec 32 W16) = 1162 +primOpTag (VecWriteScalarOffAddrOp IntVec 16 W32) = 1163 +primOpTag (VecWriteScalarOffAddrOp IntVec 8 W64) = 1164 +primOpTag (VecWriteScalarOffAddrOp WordVec 16 W8) = 1165 +primOpTag (VecWriteScalarOffAddrOp WordVec 8 W16) = 1166 +primOpTag (VecWriteScalarOffAddrOp WordVec 4 W32) = 1167 +primOpTag (VecWriteScalarOffAddrOp WordVec 2 W64) = 1168 +primOpTag (VecWriteScalarOffAddrOp WordVec 32 W8) = 1169 +primOpTag (VecWriteScalarOffAddrOp WordVec 16 W16) = 1170 +primOpTag (VecWriteScalarOffAddrOp WordVec 8 W32) = 1171 +primOpTag (VecWriteScalarOffAddrOp WordVec 4 W64) = 1172 +primOpTag (VecWriteScalarOffAddrOp WordVec 64 W8) = 1173 +primOpTag (VecWriteScalarOffAddrOp WordVec 32 W16) = 1174 +primOpTag (VecWriteScalarOffAddrOp WordVec 16 W32) = 1175 +primOpTag (VecWriteScalarOffAddrOp WordVec 8 W64) = 1176 +primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W32) = 1177 +primOpTag (VecWriteScalarOffAddrOp FloatVec 2 W64) = 1178 +primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W32) = 1179 +primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W64) = 1180 +primOpTag (VecWriteScalarOffAddrOp FloatVec 16 W32) = 1181 +primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W64) = 1182 +primOpTag PrefetchByteArrayOp3 = 1183 +primOpTag PrefetchMutableByteArrayOp3 = 1184 +primOpTag PrefetchAddrOp3 = 1185 +primOpTag PrefetchValueOp3 = 1186 +primOpTag PrefetchByteArrayOp2 = 1187 +primOpTag PrefetchMutableByteArrayOp2 = 1188 +primOpTag PrefetchAddrOp2 = 1189 +primOpTag PrefetchValueOp2 = 1190 +primOpTag PrefetchByteArrayOp1 = 1191 +primOpTag PrefetchMutableByteArrayOp1 = 1192 +primOpTag PrefetchAddrOp1 = 1193 +primOpTag PrefetchValueOp1 = 1194 +primOpTag PrefetchByteArrayOp0 = 1195 +primOpTag PrefetchMutableByteArrayOp0 = 1196 +primOpTag PrefetchAddrOp0 = 1197 +primOpTag PrefetchValueOp0 = 1198 diff --git a/ghc-lib/stage1/compiler/build/primop-vector-tycons.hs-incl b/ghc-lib/stage1/compiler/build/primop-vector-tycons.hs-incl new file mode 100644 --- /dev/null +++ b/ghc-lib/stage1/compiler/build/primop-vector-tycons.hs-incl @@ -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 diff --git a/ghc-lib/stage1/compiler/build/primop-vector-tys-exports.hs-incl b/ghc-lib/stage1/compiler/build/primop-vector-tys-exports.hs-incl new file mode 100644 --- /dev/null +++ b/ghc-lib/stage1/compiler/build/primop-vector-tys-exports.hs-incl @@ -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, diff --git a/ghc-lib/stage1/compiler/build/primop-vector-tys.hs-incl b/ghc-lib/stage1/compiler/build/primop-vector-tys.hs-incl new file mode 100644 --- /dev/null +++ b/ghc-lib/stage1/compiler/build/primop-vector-tys.hs-incl @@ -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) diff --git a/ghc-lib/stage1/compiler/build/primop-vector-uniques.hs-incl b/ghc-lib/stage1/compiler/build/primop-vector-uniques.hs-incl new file mode 100644 --- /dev/null +++ b/ghc-lib/stage1/compiler/build/primop-vector-uniques.hs-incl @@ -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 diff --git a/ghc-lib/stage1/lib/llvm-passes b/ghc-lib/stage1/lib/llvm-passes new file mode 100644 --- /dev/null +++ b/ghc-lib/stage1/lib/llvm-passes @@ -0,0 +1,5 @@ +[ +(0, "-mem2reg -globalopt"), +(1, "-O1 -globalopt"), +(2, "-O2") +] diff --git a/ghc-lib/stage1/lib/llvm-targets b/ghc-lib/stage1/lib/llvm-targets new file mode 100644 --- /dev/null +++ b/ghc-lib/stage1/lib/llvm-targets @@ -0,0 +1,31 @@ +[("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", "")) +,("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", "")) +,("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")) +,("powerpc64le-unknown-linux", ("e-m:e-i64:64-n32:64", "ppc64le", "")) +,("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", "")) +,("arm-unknown-nto-qnx-eabi", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "arm7tdmi", "+strict-align")) +,("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", "")) +,("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")) +] diff --git a/ghc-lib/stage1/lib/platformConstants b/ghc-lib/stage1/lib/platformConstants new file mode 100644 --- /dev/null +++ b/ghc-lib/stage1/lib/platformConstants @@ -0,0 +1,134 @@ +PlatformConstants { + pc_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 = 16 + , 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 + } diff --git a/ghc-lib/stage1/lib/settings b/ghc-lib/stage1/lib/settings new file mode 100644 --- /dev/null +++ b/ghc-lib/stage1/lib/settings @@ -0,0 +1,35 @@ +[("GCC extra via C opts", " -fwrapv -fno-builtin"), + ("C compiler command", "gcc"), + ("C compiler flags", ""), + ("C compiler link flags", " "), + ("C compiler supports -no-pie", "NO"), + ("Haskell CPP command","gcc"), + ("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"), + ("cross compiling", "NO"), + ("target os", "OSDarwin"), + ("target arch", "ArchX86_64"), + ("target word size", "8"), + ("target has GNU nonexec stack", "False"), + ("target has .ident directive", "True"), + ("target has subsections via symbols", "True"), + ("target has RTS linker", "YES"), + ("Unregisterised", "NO"), + ("LLVM llc command", "llc"), + ("LLVM opt command", "opt"), + ("LLVM clang command", "clang") + ] + diff --git a/includes/Cmm.h b/includes/Cmm.h new file mode 100644 --- /dev/null +++ b/includes/Cmm.h @@ -0,0 +1,931 @@ +/* ----------------------------------------------------------------------------- + * + * (c) The University of Glasgow 2004-2013 + * + * This file is included at the top of all .cmm source files (and + * *only* .cmm files). It defines a collection of useful macros for + * making .cmm code a bit less error-prone to write, and a bit easier + * on the eye for the reader. + * + * For the syntax of .cmm files, see the parser in ghc/compiler/cmm/CmmParse.y. + * + * Accessing fields of structures defined in the RTS header files is + * done via automatically-generated macros in DerivedConstants.h. For + * example, where previously we used + * + * CurrentTSO->what_next = x + * + * in C-- we now use + * + * StgTSO_what_next(CurrentTSO) = x + * + * where the StgTSO_what_next() macro is automatically generated by + * mkDerivedConstants.c. If you need to access a field that doesn't + * already have a macro, edit that file (it's pretty self-explanatory). + * + * -------------------------------------------------------------------------- */ + +#pragma once + +/* + * In files that are included into both C and C-- (and perhaps + * Haskell) sources, we sometimes need to conditionally compile bits + * depending on the language. CMINUSMINUS==1 in .cmm sources: + */ +#define CMINUSMINUS 1 + +#include "ghcconfig.h" + +/* ----------------------------------------------------------------------------- + Types + + The following synonyms for C-- types are declared here: + + I8, I16, I32, I64 MachRep-style names for convenience + + W_ is shorthand for the word type (== StgWord) + F_ shorthand for float (F_ == StgFloat == C's float) + D_ shorthand for double (D_ == StgDouble == C's double) + + CInt has the same size as an int in C on this platform + CLong has the same size as a long in C on this platform + CBool has the same size as a bool in C on this platform + + --------------------------------------------------------------------------- */ + +#define I8 bits8 +#define I16 bits16 +#define I32 bits32 +#define I64 bits64 +#define P_ gcptr + +#if SIZEOF_VOID_P == 4 +#define W_ bits32 +/* Maybe it's better to include MachDeps.h */ +#define TAG_BITS 2 +#elif SIZEOF_VOID_P == 8 +#define W_ bits64 +/* Maybe it's better to include MachDeps.h */ +#define TAG_BITS 3 +#else +#error Unknown word size +#endif + +/* + * The RTS must sometimes UNTAG a pointer before dereferencing it. + * See the wiki page commentary/rts/haskell-execution/pointer-tagging + */ +#define TAG_MASK ((1 << TAG_BITS) - 1) +#define UNTAG(p) (p & ~TAG_MASK) +#define GETTAG(p) (p & TAG_MASK) + +#if SIZEOF_INT == 4 +#define CInt bits32 +#elif SIZEOF_INT == 8 +#define CInt bits64 +#else +#error Unknown int size +#endif + +#if SIZEOF_LONG == 4 +#define CLong bits32 +#elif SIZEOF_LONG == 8 +#define CLong bits64 +#else +#error Unknown long size +#endif + +#define CBool bits8 + +#define F_ float32 +#define D_ float64 +#define L_ bits64 +#define V16_ bits128 +#define V32_ bits256 +#define V64_ bits512 + +#define SIZEOF_StgDouble 8 +#define SIZEOF_StgWord64 8 + +/* ----------------------------------------------------------------------------- + Misc useful stuff + -------------------------------------------------------------------------- */ + +#define ccall foreign "C" + +#define NULL (0::W_) + +#define STRING(name,str) \ + section "rodata" { \ + name : bits8[] str; \ + } \ + +#if defined(TABLES_NEXT_TO_CODE) +#define RET_LBL(f) f##_info +#else +#define RET_LBL(f) f##_ret +#endif + +#if defined(TABLES_NEXT_TO_CODE) +#define ENTRY_LBL(f) f##_info +#else +#define ENTRY_LBL(f) f##_entry +#endif + +/* ----------------------------------------------------------------------------- + Byte/word macros + + Everything in C-- is in byte offsets (well, most things). We use + some macros to allow us to express offsets in words and to try to + avoid byte/word confusion. + -------------------------------------------------------------------------- */ + +#define SIZEOF_W SIZEOF_VOID_P +#define W_MASK (SIZEOF_W-1) + +#if SIZEOF_W == 4 +#define W_SHIFT 2 +#elif SIZEOF_W == 8 +#define W_SHIFT 3 +#endif + +/* Converting quantities of words to bytes */ +#define WDS(n) ((n)*SIZEOF_W) + +/* + * Converting quantities of bytes to words + * NB. these work on *unsigned* values only + */ +#define BYTES_TO_WDS(n) ((n) / SIZEOF_W) +#define ROUNDUP_BYTES_TO_WDS(n) (((n) + SIZEOF_W - 1) / SIZEOF_W) + +/* TO_W_(n) converts n to W_ type from a smaller type */ +#if SIZEOF_W == 4 +#define TO_I64(x) %sx64(x) +#define TO_W_(x) %sx32(x) +#define HALF_W_(x) %lobits16(x) +#elif SIZEOF_W == 8 +#define TO_I64(x) (x) +#define TO_W_(x) %sx64(x) +#define HALF_W_(x) %lobits32(x) +#endif + +#if SIZEOF_INT == 4 && SIZEOF_W == 8 +#define W_TO_INT(x) %lobits32(x) +#elif SIZEOF_INT == SIZEOF_W +#define W_TO_INT(x) (x) +#endif + +#if SIZEOF_LONG == 4 && SIZEOF_W == 8 +#define W_TO_LONG(x) %lobits32(x) +#elif SIZEOF_LONG == SIZEOF_W +#define W_TO_LONG(x) (x) +#endif + +/* ----------------------------------------------------------------------------- + Atomic memory operations. + -------------------------------------------------------------------------- */ + +#if SIZEOF_W == 4 +#define cmpxchgW cmpxchg32 +#elif SIZEOF_W == 8 +#define cmpxchgW cmpxchg64 +#endif + +/* ----------------------------------------------------------------------------- + Heap/stack access, and adjusting the heap/stack pointers. + -------------------------------------------------------------------------- */ + +#define Sp(n) W_[Sp + WDS(n)] +#define Hp(n) W_[Hp + WDS(n)] + +#define Sp_adj(n) Sp = Sp + WDS(n) /* pronounced "spadge" */ +#define Hp_adj(n) Hp = Hp + WDS(n) + +/* ----------------------------------------------------------------------------- + Assertions and Debuggery + -------------------------------------------------------------------------- */ + +#if defined(DEBUG) +#define ASSERT(predicate) \ + if (predicate) { \ + /*null*/; \ + } else { \ + foreign "C" _assertFail(__FILE__, __LINE__) never returns; \ + } +#else +#define ASSERT(p) /* nothing */ +#endif + +#if defined(DEBUG) +#define DEBUG_ONLY(s) s +#else +#define DEBUG_ONLY(s) /* nothing */ +#endif + +/* + * The IF_DEBUG macro is useful for debug messages that depend on one + * of the RTS debug options. For example: + * + * IF_DEBUG(RtsFlags_DebugFlags_apply, + * foreign "C" fprintf(stderr, stg_ap_0_ret_str)); + * + * Note the syntax is slightly different to the C version of this macro. + */ +#if defined(DEBUG) +#define IF_DEBUG(c,s) if (RtsFlags_DebugFlags_##c(RtsFlags) != 0::CBool) { s; } +#else +#define IF_DEBUG(c,s) /* nothing */ +#endif + +/* ----------------------------------------------------------------------------- + Entering + + It isn't safe to "enter" every closure. Functions in particular + have no entry code as such; their entry point contains the code to + apply the function. + + ToDo: range should end in N_CLOSURE_TYPES-1, not N_CLOSURE_TYPES, + but switch doesn't allow us to use exprs there yet. + + If R1 points to a tagged object it points either to + * A constructor. + * A function with arity <= TAG_MASK. + In both cases the right thing to do is to return. + Note: it is rather lucky that we can use the tag bits to do this + for both objects. Maybe it points to a brittle design? + + Indirections can contain tagged pointers, so their tag is checked. + -------------------------------------------------------------------------- */ + +#if defined(PROFILING) + +// When profiling, we cannot shortcut ENTER() by checking the tag, +// because LDV profiling relies on entering closures to mark them as +// "used". + +#define LOAD_INFO(ret,x) \ + info = %INFO_PTR(UNTAG(x)); + +#define UNTAG_IF_PROF(x) UNTAG(x) + +#else + +#define LOAD_INFO(ret,x) \ + if (GETTAG(x) != 0) { \ + ret(x); \ + } \ + info = %INFO_PTR(x); + +#define UNTAG_IF_PROF(x) (x) /* already untagged */ + +#endif + +// We need two versions of ENTER(): +// - ENTER(x) takes the closure as an argument and uses return(), +// for use in civilized code where the stack is handled by GHC +// +// - ENTER_NOSTACK() where the closure is in R1, and returns are +// explicit jumps, for use when we are doing the stack management +// ourselves. + +#if defined(PROFILING) +// See Note [Evaluating functions with profiling] in rts/Apply.cmm +#define ENTER(x) jump stg_ap_0_fast(x); +#else +#define ENTER(x) ENTER_(return,x) +#endif + +#define ENTER_R1() ENTER_(RET_R1,R1) + +#define RET_R1(x) jump %ENTRY_CODE(Sp(0)) [R1] + +#define ENTER_(ret,x) \ + again: \ + W_ info; \ + LOAD_INFO(ret,x) \ + switch [INVALID_OBJECT .. N_CLOSURE_TYPES] \ + (TO_W_( %INFO_TYPE(%STD_INFO(info)) )) { \ + case \ + IND, \ + IND_STATIC: \ + { \ + x = StgInd_indirectee(x); \ + goto again; \ + } \ + case \ + FUN, \ + FUN_1_0, \ + FUN_0_1, \ + FUN_2_0, \ + FUN_1_1, \ + FUN_0_2, \ + FUN_STATIC, \ + BCO, \ + PAP: \ + { \ + ret(x); \ + } \ + default: \ + { \ + x = UNTAG_IF_PROF(x); \ + jump %ENTRY_CODE(info) (x); \ + } \ + } + +// The FUN cases almost never happen: a pointer to a non-static FUN +// should always be tagged. This unfortunately isn't true for the +// interpreter right now, which leaves untagged FUNs on the stack. + +/* ----------------------------------------------------------------------------- + Constants. + -------------------------------------------------------------------------- */ + +#include "rts/Constants.h" +#include "DerivedConstants.h" +#include "rts/storage/ClosureTypes.h" +#include "rts/storage/FunTypes.h" +#include "rts/OSThreads.h" + +/* + * Need MachRegs, because some of the RTS code is conditionally + * compiled based on REG_R1, REG_R2, etc. + */ +#include "stg/RtsMachRegs.h" + +#include "rts/prof/LDV.h" + +#undef BLOCK_SIZE +#undef MBLOCK_SIZE +#include "rts/storage/Block.h" /* For Bdescr() */ + + +#define MyCapability() (BaseReg - OFFSET_Capability_r) + +/* ------------------------------------------------------------------------- + Info tables + ------------------------------------------------------------------------- */ + +#if defined(PROFILING) +#define PROF_HDR_FIELDS(w_,hdr1,hdr2) \ + w_ hdr1, \ + w_ hdr2, +#else +#define PROF_HDR_FIELDS(w_,hdr1,hdr2) /* nothing */ +#endif + +/* ------------------------------------------------------------------------- + Allocation and garbage collection + ------------------------------------------------------------------------- */ + +/* + * ALLOC_PRIM is for allocating memory on the heap for a primitive + * object. It is used all over PrimOps.cmm. + * + * We make the simplifying assumption that the "admin" part of a + * primitive closure is just the header when calculating sizes for + * ticky-ticky. It's not clear whether eg. the size field of an array + * should be counted as "admin", or the various fields of a BCO. + */ +#define ALLOC_PRIM(bytes) \ + HP_CHK_GEN_TICKY(bytes); \ + TICK_ALLOC_PRIM(SIZEOF_StgHeader,bytes-SIZEOF_StgHeader,0); \ + CCCS_ALLOC(bytes); + +#define HEAP_CHECK(bytes,failure) \ + TICK_BUMP(HEAP_CHK_ctr); \ + Hp = Hp + (bytes); \ + if (Hp > HpLim) { HpAlloc = (bytes); failure; } \ + TICK_ALLOC_HEAP_NOCTR(bytes); + +#define ALLOC_PRIM_WITH_CUSTOM_FAILURE(bytes,failure) \ + HEAP_CHECK(bytes,failure) \ + TICK_ALLOC_PRIM(SIZEOF_StgHeader,bytes-SIZEOF_StgHeader,0); \ + CCCS_ALLOC(bytes); + +#define ALLOC_PRIM_(bytes,fun) \ + ALLOC_PRIM_WITH_CUSTOM_FAILURE(bytes,GC_PRIM(fun)); + +#define ALLOC_PRIM_P(bytes,fun,arg) \ + ALLOC_PRIM_WITH_CUSTOM_FAILURE(bytes,GC_PRIM_P(fun,arg)); + +#define ALLOC_PRIM_N(bytes,fun,arg) \ + ALLOC_PRIM_WITH_CUSTOM_FAILURE(bytes,GC_PRIM_N(fun,arg)); + +/* CCS_ALLOC wants the size in words, because ccs->mem_alloc is in words */ +#define CCCS_ALLOC(__alloc) CCS_ALLOC(BYTES_TO_WDS(__alloc), CCCS) + +#define HP_CHK_GEN_TICKY(bytes) \ + HP_CHK_GEN(bytes); \ + TICK_ALLOC_HEAP_NOCTR(bytes); + +#define HP_CHK_P(bytes, fun, arg) \ + HEAP_CHECK(bytes, GC_PRIM_P(fun,arg)) + +// TODO I'm not seeing where ALLOC_P_TICKY is used; can it be removed? +// -NSF March 2013 +#define ALLOC_P_TICKY(bytes, fun, arg) \ + HP_CHK_P(bytes); \ + TICK_ALLOC_HEAP_NOCTR(bytes); + +#define CHECK_GC() \ + (bdescr_link(CurrentNursery) == NULL || \ + generation_n_new_large_words(W_[g0]) >= TO_W_(CLong[large_alloc_lim])) + +// allocate() allocates from the nursery, so we check to see +// whether the nursery is nearly empty in any function that uses +// allocate() - this includes many of the primops. +// +// HACK alert: the __L__ stuff is here to coax the common-block +// eliminator into commoning up the call stg_gc_noregs() with the same +// code that gets generated by a STK_CHK_GEN() in the same proc. We +// also need an if (0) { goto __L__; } so that the __L__ label isn't +// optimised away by the control-flow optimiser prior to common-block +// elimination (it will be optimised away later). +// +// This saves some code in gmp-wrappers.cmm where we have lots of +// MAYBE_GC() in the same proc as STK_CHK_GEN(). +// +#define MAYBE_GC(retry) \ + if (CHECK_GC()) { \ + HpAlloc = 0; \ + goto __L__; \ + __L__: \ + call stg_gc_noregs(); \ + goto retry; \ + } \ + if (0) { goto __L__; } + +#define GC_PRIM(fun) \ + jump stg_gc_prim(fun); + +// Version of GC_PRIM for use in low-level Cmm. We can call +// stg_gc_prim, because it takes one argument and therefore has a +// platform-independent calling convention (Note [Syntax of .cmm +// files] in CmmParse.y). +#define GC_PRIM_LL(fun) \ + R1 = fun; \ + jump stg_gc_prim [R1]; + +// We pass the fun as the second argument, because the arg is +// usually already in the first argument position (R1), so this +// avoids moving it to a different register / stack slot. +#define GC_PRIM_N(fun,arg) \ + jump stg_gc_prim_n(arg,fun); + +#define GC_PRIM_P(fun,arg) \ + jump stg_gc_prim_p(arg,fun); + +#define GC_PRIM_P_LL(fun,arg) \ + R1 = arg; \ + R2 = fun; \ + jump stg_gc_prim_p_ll [R1,R2]; + +#define GC_PRIM_PP(fun,arg1,arg2) \ + jump stg_gc_prim_pp(arg1,arg2,fun); + +#define MAYBE_GC_(fun) \ + if (CHECK_GC()) { \ + HpAlloc = 0; \ + GC_PRIM(fun) \ + } + +#define MAYBE_GC_N(fun,arg) \ + if (CHECK_GC()) { \ + HpAlloc = 0; \ + GC_PRIM_N(fun,arg) \ + } + +#define MAYBE_GC_P(fun,arg) \ + if (CHECK_GC()) { \ + HpAlloc = 0; \ + GC_PRIM_P(fun,arg) \ + } + +#define MAYBE_GC_PP(fun,arg1,arg2) \ + if (CHECK_GC()) { \ + HpAlloc = 0; \ + GC_PRIM_PP(fun,arg1,arg2) \ + } + +#define STK_CHK_LL(n, fun) \ + TICK_BUMP(STK_CHK_ctr); \ + if (Sp - (n) < SpLim) { \ + GC_PRIM_LL(fun) \ + } + +#define STK_CHK_P_LL(n, fun, arg) \ + TICK_BUMP(STK_CHK_ctr); \ + if (Sp - (n) < SpLim) { \ + GC_PRIM_P_LL(fun,arg) \ + } + +#define STK_CHK_PP(n, fun, arg1, arg2) \ + TICK_BUMP(STK_CHK_ctr); \ + if (Sp - (n) < SpLim) { \ + GC_PRIM_PP(fun,arg1,arg2) \ + } + +#define STK_CHK_ENTER(n, closure) \ + TICK_BUMP(STK_CHK_ctr); \ + if (Sp - (n) < SpLim) { \ + jump __stg_gc_enter_1(closure); \ + } + +// A funky heap check used by AutoApply.cmm + +#define HP_CHK_NP_ASSIGN_SP0(size,f) \ + HEAP_CHECK(size, Sp(0) = f; jump __stg_gc_enter_1 [R1];) + +/* ----------------------------------------------------------------------------- + Closure headers + -------------------------------------------------------------------------- */ + +/* + * This is really ugly, since we don't do the rest of StgHeader this + * way. The problem is that values from DerivedConstants.h cannot be + * dependent on the way (SMP, PROF etc.). For SIZEOF_StgHeader we get + * the value from GHC, but it seems like too much trouble to do that + * for StgThunkHeader. + */ +#define SIZEOF_StgThunkHeader SIZEOF_StgHeader+SIZEOF_StgSMPThunkHeader + +#define StgThunk_payload(__ptr__,__ix__) \ + W_[__ptr__+SIZEOF_StgThunkHeader+ WDS(__ix__)] + +/* ----------------------------------------------------------------------------- + Closures + -------------------------------------------------------------------------- */ + +/* The offset of the payload of an array */ +#define BYTE_ARR_CTS(arr) ((arr) + SIZEOF_StgArrBytes) + +/* The number of words allocated in an array payload */ +#define BYTE_ARR_WDS(arr) ROUNDUP_BYTES_TO_WDS(StgArrBytes_bytes(arr)) + +/* Getting/setting the info pointer of a closure */ +#define SET_INFO(p,info) StgHeader_info(p) = info +#define GET_INFO(p) StgHeader_info(p) + +/* Determine the size of an ordinary closure from its info table */ +#define sizeW_fromITBL(itbl) \ + SIZEOF_StgHeader + WDS(%INFO_PTRS(itbl)) + WDS(%INFO_NPTRS(itbl)) + +/* NB. duplicated from InfoTables.h! */ +#define BITMAP_SIZE(bitmap) ((bitmap) & BITMAP_SIZE_MASK) +#define BITMAP_BITS(bitmap) ((bitmap) >> BITMAP_BITS_SHIFT) + +/* Debugging macros */ +#define LOOKS_LIKE_INFO_PTR(p) \ + ((p) != NULL && \ + LOOKS_LIKE_INFO_PTR_NOT_NULL(p)) + +#define LOOKS_LIKE_INFO_PTR_NOT_NULL(p) \ + ( (TO_W_(%INFO_TYPE(%STD_INFO(p))) != INVALID_OBJECT) && \ + (TO_W_(%INFO_TYPE(%STD_INFO(p))) < N_CLOSURE_TYPES)) + +#define LOOKS_LIKE_CLOSURE_PTR(p) (LOOKS_LIKE_INFO_PTR(GET_INFO(UNTAG(p)))) + +/* + * The layout of the StgFunInfoExtra part of an info table changes + * depending on TABLES_NEXT_TO_CODE. So we define field access + * macros which use the appropriate version here: + */ +#if defined(TABLES_NEXT_TO_CODE) +/* + * when TABLES_NEXT_TO_CODE, slow_apply is stored as an offset + * instead of the normal pointer. + */ + +#define StgFunInfoExtra_slow_apply(fun_info) \ + (TO_W_(StgFunInfoExtraRev_slow_apply_offset(fun_info)) \ + + (fun_info) + SIZEOF_StgFunInfoExtraRev + SIZEOF_StgInfoTable) + +#define StgFunInfoExtra_fun_type(i) StgFunInfoExtraRev_fun_type(i) +#define StgFunInfoExtra_arity(i) StgFunInfoExtraRev_arity(i) +#define StgFunInfoExtra_bitmap(i) StgFunInfoExtraRev_bitmap(i) +#else +#define StgFunInfoExtra_slow_apply(i) StgFunInfoExtraFwd_slow_apply(i) +#define StgFunInfoExtra_fun_type(i) StgFunInfoExtraFwd_fun_type(i) +#define StgFunInfoExtra_arity(i) StgFunInfoExtraFwd_arity(i) +#define StgFunInfoExtra_bitmap(i) StgFunInfoExtraFwd_bitmap(i) +#endif + +#define mutArrCardMask ((1 << MUT_ARR_PTRS_CARD_BITS) - 1) +#define mutArrPtrCardDown(i) ((i) >> MUT_ARR_PTRS_CARD_BITS) +#define mutArrPtrCardUp(i) (((i) + mutArrCardMask) >> MUT_ARR_PTRS_CARD_BITS) +#define mutArrPtrsCardWords(n) ROUNDUP_BYTES_TO_WDS(mutArrPtrCardUp(n)) + +#if defined(PROFILING) || (!defined(THREADED_RTS) && defined(DEBUG)) +#define OVERWRITING_CLOSURE_SIZE(c, size) foreign "C" overwritingClosureSize(c "ptr", size) +#define OVERWRITING_CLOSURE(c) foreign "C" overwritingClosure(c "ptr") +#define OVERWRITING_CLOSURE_OFS(c,n) foreign "C" overwritingClosureOfs(c "ptr", n) +#else +#define OVERWRITING_CLOSURE_SIZE(c, size) /* nothing */ +#define OVERWRITING_CLOSURE(c) /* nothing */ +#define OVERWRITING_CLOSURE_OFS(c,n) /* nothing */ +#endif + +#if defined(THREADED_RTS) +#define prim_write_barrier prim %write_barrier() +#else +#define prim_write_barrier /* nothing */ +#endif + +/* ----------------------------------------------------------------------------- + Ticky macros + -------------------------------------------------------------------------- */ + +#if defined(TICKY_TICKY) +#define TICK_BUMP_BY(ctr,n) CLong[ctr] = CLong[ctr] + n +#else +#define TICK_BUMP_BY(ctr,n) /* nothing */ +#endif + +#define TICK_BUMP(ctr) TICK_BUMP_BY(ctr,1) + +#define TICK_ENT_DYN_IND() TICK_BUMP(ENT_DYN_IND_ctr) +#define TICK_ENT_DYN_THK() TICK_BUMP(ENT_DYN_THK_ctr) +#define TICK_ENT_VIA_NODE() TICK_BUMP(ENT_VIA_NODE_ctr) +#define TICK_ENT_STATIC_IND() TICK_BUMP(ENT_STATIC_IND_ctr) +#define TICK_ENT_PERM_IND() TICK_BUMP(ENT_PERM_IND_ctr) +#define TICK_ENT_PAP() TICK_BUMP(ENT_PAP_ctr) +#define TICK_ENT_AP() TICK_BUMP(ENT_AP_ctr) +#define TICK_ENT_AP_STACK() TICK_BUMP(ENT_AP_STACK_ctr) +#define TICK_ENT_BH() TICK_BUMP(ENT_BH_ctr) +#define TICK_ENT_LNE() TICK_BUMP(ENT_LNE_ctr) +#define TICK_UNKNOWN_CALL() TICK_BUMP(UNKNOWN_CALL_ctr) +#define TICK_UPDF_PUSHED() TICK_BUMP(UPDF_PUSHED_ctr) +#define TICK_CATCHF_PUSHED() TICK_BUMP(CATCHF_PUSHED_ctr) +#define TICK_UPDF_OMITTED() TICK_BUMP(UPDF_OMITTED_ctr) +#define TICK_UPD_NEW_IND() TICK_BUMP(UPD_NEW_IND_ctr) +#define TICK_UPD_NEW_PERM_IND() TICK_BUMP(UPD_NEW_PERM_IND_ctr) +#define TICK_UPD_OLD_IND() TICK_BUMP(UPD_OLD_IND_ctr) +#define TICK_UPD_OLD_PERM_IND() TICK_BUMP(UPD_OLD_PERM_IND_ctr) + +#define TICK_SLOW_CALL_FUN_TOO_FEW() TICK_BUMP(SLOW_CALL_FUN_TOO_FEW_ctr) +#define TICK_SLOW_CALL_FUN_CORRECT() TICK_BUMP(SLOW_CALL_FUN_CORRECT_ctr) +#define TICK_SLOW_CALL_FUN_TOO_MANY() TICK_BUMP(SLOW_CALL_FUN_TOO_MANY_ctr) +#define TICK_SLOW_CALL_PAP_TOO_FEW() TICK_BUMP(SLOW_CALL_PAP_TOO_FEW_ctr) +#define TICK_SLOW_CALL_PAP_CORRECT() TICK_BUMP(SLOW_CALL_PAP_CORRECT_ctr) +#define TICK_SLOW_CALL_PAP_TOO_MANY() TICK_BUMP(SLOW_CALL_PAP_TOO_MANY_ctr) + +#define TICK_SLOW_CALL_fast_v16() TICK_BUMP(SLOW_CALL_fast_v16_ctr) +#define TICK_SLOW_CALL_fast_v() TICK_BUMP(SLOW_CALL_fast_v_ctr) +#define TICK_SLOW_CALL_fast_p() TICK_BUMP(SLOW_CALL_fast_p_ctr) +#define TICK_SLOW_CALL_fast_pv() TICK_BUMP(SLOW_CALL_fast_pv_ctr) +#define TICK_SLOW_CALL_fast_pp() TICK_BUMP(SLOW_CALL_fast_pp_ctr) +#define TICK_SLOW_CALL_fast_ppv() TICK_BUMP(SLOW_CALL_fast_ppv_ctr) +#define TICK_SLOW_CALL_fast_ppp() TICK_BUMP(SLOW_CALL_fast_ppp_ctr) +#define TICK_SLOW_CALL_fast_pppv() TICK_BUMP(SLOW_CALL_fast_pppv_ctr) +#define TICK_SLOW_CALL_fast_pppp() TICK_BUMP(SLOW_CALL_fast_pppp_ctr) +#define TICK_SLOW_CALL_fast_ppppp() TICK_BUMP(SLOW_CALL_fast_ppppp_ctr) +#define TICK_SLOW_CALL_fast_pppppp() TICK_BUMP(SLOW_CALL_fast_pppppp_ctr) +#define TICK_VERY_SLOW_CALL() TICK_BUMP(VERY_SLOW_CALL_ctr) + +/* NOTE: TICK_HISTO_BY and TICK_HISTO + currently have no effect. + The old code for it didn't typecheck and I + just commented it out to get ticky to work. + - krc 1/2007 */ + +#define TICK_HISTO_BY(histo,n,i) /* nothing */ + +#define TICK_HISTO(histo,n) TICK_HISTO_BY(histo,n,1) + +/* An unboxed tuple with n components. */ +#define TICK_RET_UNBOXED_TUP(n) \ + TICK_BUMP(RET_UNBOXED_TUP_ctr++); \ + TICK_HISTO(RET_UNBOXED_TUP,n) + +/* + * A slow call with n arguments. In the unevald case, this call has + * already been counted once, so don't count it again. + */ +#define TICK_SLOW_CALL(n) \ + TICK_BUMP(SLOW_CALL_ctr); \ + TICK_HISTO(SLOW_CALL,n) + +/* + * This slow call was found to be to an unevaluated function; undo the + * ticks we did in TICK_SLOW_CALL. + */ +#define TICK_SLOW_CALL_UNEVALD(n) \ + TICK_BUMP(SLOW_CALL_UNEVALD_ctr); \ + TICK_BUMP_BY(SLOW_CALL_ctr,-1); \ + TICK_HISTO_BY(SLOW_CALL,n,-1); + +/* Updating a closure with a new CON */ +#define TICK_UPD_CON_IN_NEW(n) \ + TICK_BUMP(UPD_CON_IN_NEW_ctr); \ + TICK_HISTO(UPD_CON_IN_NEW,n) + +#define TICK_ALLOC_HEAP_NOCTR(bytes) \ + TICK_BUMP(ALLOC_RTS_ctr); \ + TICK_BUMP_BY(ALLOC_RTS_tot,bytes) + +/* ----------------------------------------------------------------------------- + Saving and restoring STG registers + + STG registers must be saved around a C call, just in case the STG + register is mapped to a caller-saves machine register. Normally we + don't need to worry about this the code generator has already + loaded any live STG registers into variables for us, but in + hand-written low-level Cmm code where we don't know which registers + are live, we might have to save them all. + -------------------------------------------------------------------------- */ + +#define SAVE_STGREGS \ + W_ r1, r2, r3, r4, r5, r6, r7, r8; \ + F_ f1, f2, f3, f4, f5, f6; \ + D_ d1, d2, d3, d4, d5, d6; \ + L_ l1; \ + \ + r1 = R1; \ + r2 = R2; \ + r3 = R3; \ + r4 = R4; \ + r5 = R5; \ + r6 = R6; \ + r7 = R7; \ + r8 = R8; \ + \ + f1 = F1; \ + f2 = F2; \ + f3 = F3; \ + f4 = F4; \ + f5 = F5; \ + f6 = F6; \ + \ + d1 = D1; \ + d2 = D2; \ + d3 = D3; \ + d4 = D4; \ + d5 = D5; \ + d6 = D6; \ + \ + l1 = L1; + + +#define RESTORE_STGREGS \ + R1 = r1; \ + R2 = r2; \ + R3 = r3; \ + R4 = r4; \ + R5 = r5; \ + R6 = r6; \ + R7 = r7; \ + R8 = r8; \ + \ + F1 = f1; \ + F2 = f2; \ + F3 = f3; \ + F4 = f4; \ + F5 = f5; \ + F6 = f6; \ + \ + D1 = d1; \ + D2 = d2; \ + D3 = d3; \ + D4 = d4; \ + D5 = d5; \ + D6 = d6; \ + \ + L1 = l1; + +/* ----------------------------------------------------------------------------- + Misc junk + -------------------------------------------------------------------------- */ + +#define NO_TREC stg_NO_TREC_closure +#define END_TSO_QUEUE stg_END_TSO_QUEUE_closure +#define STM_AWOKEN stg_STM_AWOKEN_closure + +#define recordMutableCap(p, gen) \ + W_ __bd; \ + W_ mut_list; \ + mut_list = Capability_mut_lists(MyCapability()) + WDS(gen); \ + __bd = W_[mut_list]; \ + if (bdescr_free(__bd) >= bdescr_start(__bd) + BLOCK_SIZE) { \ + W_ __new_bd; \ + ("ptr" __new_bd) = foreign "C" allocBlock_lock(); \ + bdescr_link(__new_bd) = __bd; \ + __bd = __new_bd; \ + W_[mut_list] = __bd; \ + } \ + W_ free; \ + free = bdescr_free(__bd); \ + W_[free] = p; \ + bdescr_free(__bd) = free + WDS(1); + +#define recordMutable(p) \ + P_ __p; \ + W_ __bd; \ + W_ __gen; \ + __p = p; \ + __bd = Bdescr(__p); \ + __gen = TO_W_(bdescr_gen_no(__bd)); \ + if (__gen > 0) { recordMutableCap(__p, __gen); } + +/* ----------------------------------------------------------------------------- + Arrays + -------------------------------------------------------------------------- */ + +/* Complete function body for the clone family of (mutable) array ops. + Defined as a macro to avoid function call overhead or code + duplication. */ +#define cloneArray(info, src, offset, n) \ + W_ words, size; \ + gcptr dst, dst_p, src_p; \ + \ + again: MAYBE_GC(again); \ + \ + size = n + mutArrPtrsCardWords(n); \ + words = BYTES_TO_WDS(SIZEOF_StgMutArrPtrs) + size; \ + ("ptr" dst) = ccall allocate(MyCapability() "ptr", words); \ + TICK_ALLOC_PRIM(SIZEOF_StgMutArrPtrs, WDS(size), 0); \ + \ + SET_HDR(dst, info, CCCS); \ + StgMutArrPtrs_ptrs(dst) = n; \ + StgMutArrPtrs_size(dst) = size; \ + \ + dst_p = dst + SIZEOF_StgMutArrPtrs; \ + src_p = src + SIZEOF_StgMutArrPtrs + WDS(offset); \ + prim %memcpy(dst_p, src_p, n * SIZEOF_W, SIZEOF_W); \ + \ + return (dst); + +#define copyArray(src, src_off, dst, dst_off, n) \ + W_ dst_elems_p, dst_p, src_p, dst_cards_p, bytes; \ + \ + if ((n) != 0) { \ + SET_HDR(dst, stg_MUT_ARR_PTRS_DIRTY_info, CCCS); \ + \ + dst_elems_p = (dst) + SIZEOF_StgMutArrPtrs; \ + dst_p = dst_elems_p + WDS(dst_off); \ + src_p = (src) + SIZEOF_StgMutArrPtrs + WDS(src_off); \ + bytes = WDS(n); \ + \ + prim %memcpy(dst_p, src_p, bytes, SIZEOF_W); \ + \ + dst_cards_p = dst_elems_p + WDS(StgMutArrPtrs_ptrs(dst)); \ + setCards(dst_cards_p, dst_off, n); \ + } \ + \ + return (); + +#define copyMutableArray(src, src_off, dst, dst_off, n) \ + W_ dst_elems_p, dst_p, src_p, dst_cards_p, bytes; \ + \ + if ((n) != 0) { \ + SET_HDR(dst, stg_MUT_ARR_PTRS_DIRTY_info, CCCS); \ + \ + dst_elems_p = (dst) + SIZEOF_StgMutArrPtrs; \ + dst_p = dst_elems_p + WDS(dst_off); \ + src_p = (src) + SIZEOF_StgMutArrPtrs + WDS(src_off); \ + bytes = WDS(n); \ + \ + if ((src) == (dst)) { \ + prim %memmove(dst_p, src_p, bytes, SIZEOF_W); \ + } else { \ + prim %memcpy(dst_p, src_p, bytes, SIZEOF_W); \ + } \ + \ + dst_cards_p = dst_elems_p + WDS(StgMutArrPtrs_ptrs(dst)); \ + setCards(dst_cards_p, dst_off, n); \ + } \ + \ + return (); + +/* + * Set the cards in the cards table pointed to by dst_cards_p for an + * update to n elements, starting at element dst_off. + */ +#define setCards(dst_cards_p, dst_off, n) \ + W_ __start_card, __end_card, __cards; \ + __start_card = mutArrPtrCardDown(dst_off); \ + __end_card = mutArrPtrCardDown((dst_off) + (n) - 1); \ + __cards = __end_card - __start_card + 1; \ + prim %memset((dst_cards_p) + __start_card, 1, __cards, 1); + +/* Complete function body for the clone family of small (mutable) + array ops. Defined as a macro to avoid function call overhead or + code duplication. */ +#define cloneSmallArray(info, src, offset, n) \ + W_ words, size; \ + gcptr dst, dst_p, src_p; \ + \ + again: MAYBE_GC(again); \ + \ + words = BYTES_TO_WDS(SIZEOF_StgSmallMutArrPtrs) + n; \ + ("ptr" dst) = ccall allocate(MyCapability() "ptr", words); \ + TICK_ALLOC_PRIM(SIZEOF_StgSmallMutArrPtrs, WDS(n), 0); \ + \ + SET_HDR(dst, info, CCCS); \ + StgSmallMutArrPtrs_ptrs(dst) = n; \ + \ + dst_p = dst + SIZEOF_StgSmallMutArrPtrs; \ + src_p = src + SIZEOF_StgSmallMutArrPtrs + WDS(offset); \ + prim %memcpy(dst_p, src_p, n * SIZEOF_W, SIZEOF_W); \ + \ + return (dst); diff --git a/includes/CodeGen.Platform.hs b/includes/CodeGen.Platform.hs new file mode 100644 --- /dev/null +++ b/includes/CodeGen.Platform.hs @@ -0,0 +1,1069 @@ + +import CmmExpr +#if !(defined(MACHREGS_i386) || defined(MACHREGS_x86_64) \ + || defined(MACHREGS_sparc) || defined(MACHREGS_powerpc)) +import Panic +#endif +import Reg + +#include "ghcautoconf.h" +#include "stg/MachRegs.h" + +#if defined(MACHREGS_i386) || defined(MACHREGS_x86_64) + +# if defined(MACHREGS_i386) +# define eax 0 +# define ebx 1 +# define ecx 2 +# define edx 3 +# define esi 4 +# define edi 5 +# define ebp 6 +# define esp 7 +# endif + +# if defined(MACHREGS_x86_64) +# define rax 0 +# define rbx 1 +# define rcx 2 +# define rdx 3 +# define rsi 4 +# define rdi 5 +# define rbp 6 +# define rsp 7 +# define r8 8 +# define r9 9 +# define r10 10 +# define r11 11 +# define r12 12 +# define r13 13 +# define r14 14 +# define r15 15 +# endif + +# define fake0 16 +# define fake1 17 +# define fake2 18 +# define fake3 19 +# define fake4 20 +# define fake5 21 + +-- N.B. XMM, YMM, and ZMM are all aliased to the same hardware registers hence +-- being assigned the same RegNos. +# define xmm0 24 +# define xmm1 25 +# define xmm2 26 +# define xmm3 27 +# define xmm4 28 +# define xmm5 29 +# define xmm6 30 +# define xmm7 31 +# define xmm8 32 +# define xmm9 33 +# define xmm10 34 +# define xmm11 35 +# define xmm12 36 +# define xmm13 37 +# define xmm14 38 +# define xmm15 39 + +# define ymm0 24 +# define ymm1 25 +# define ymm2 26 +# define ymm3 27 +# define ymm4 28 +# define ymm5 29 +# define ymm6 30 +# define ymm7 31 +# define ymm8 32 +# define ymm9 33 +# define ymm10 34 +# define ymm11 35 +# define ymm12 36 +# define ymm13 37 +# define ymm14 38 +# define ymm15 39 + +# define zmm0 24 +# define zmm1 25 +# define zmm2 26 +# define zmm3 27 +# define zmm4 28 +# define zmm5 29 +# define zmm6 30 +# define zmm7 31 +# define zmm8 32 +# define zmm9 33 +# define zmm10 34 +# define zmm11 35 +# define zmm12 36 +# define zmm13 37 +# define zmm14 38 +# define zmm15 39 + +-- Note: these are only needed for ARM/ARM64 because globalRegMaybe is now used in CmmSink.hs. +-- Since it's only used to check 'isJust', the actual values don't matter, thus +-- I'm not sure if these are the correct numberings. +-- Normally, the register names are just stringified as part of the REG() macro + +#elif defined(MACHREGS_powerpc) || defined(MACHREGS_arm) \ + || defined(MACHREGS_aarch64) + +# define r0 0 +# define r1 1 +# define r2 2 +# define r3 3 +# define r4 4 +# define r5 5 +# define r6 6 +# define r7 7 +# define r8 8 +# define r9 9 +# define r10 10 +# define r11 11 +# define r12 12 +# define r13 13 +# define r14 14 +# define r15 15 +# define r16 16 +# define r17 17 +# define r18 18 +# define r19 19 +# define r20 20 +# define r21 21 +# define r22 22 +# define r23 23 +# define r24 24 +# define r25 25 +# define r26 26 +# define r27 27 +# define r28 28 +# define r29 29 +# define r30 30 +# define r31 31 + +-- See note above. These aren't actually used for anything except satisfying the compiler for globalRegMaybe +-- so I'm unsure if they're the correct numberings, should they ever be attempted to be used in the NCG. +#if defined(MACHREGS_aarch64) || defined(MACHREGS_arm) +# define s0 32 +# define s1 33 +# define s2 34 +# define s3 35 +# define s4 36 +# define s5 37 +# define s6 38 +# define s7 39 +# define s8 40 +# define s9 41 +# define s10 42 +# define s11 43 +# define s12 44 +# define s13 45 +# define s14 46 +# define s15 47 +# define s16 48 +# define s17 49 +# define s18 50 +# define s19 51 +# define s20 52 +# define s21 53 +# define s22 54 +# define s23 55 +# define s24 56 +# define s25 57 +# define s26 58 +# define s27 59 +# define s28 60 +# define s29 61 +# define s30 62 +# define s31 63 + +# define d0 32 +# define d1 33 +# define d2 34 +# define d3 35 +# define d4 36 +# define d5 37 +# define d6 38 +# define d7 39 +# define d8 40 +# define d9 41 +# define d10 42 +# define d11 43 +# define d12 44 +# define d13 45 +# define d14 46 +# define d15 47 +# define d16 48 +# define d17 49 +# define d18 50 +# define d19 51 +# define d20 52 +# define d21 53 +# define d22 54 +# define d23 55 +# define d24 56 +# define d25 57 +# define d26 58 +# define d27 59 +# define d28 60 +# define d29 61 +# define d30 62 +# define d31 63 +#endif + +# if defined(MACHREGS_darwin) +# define f0 32 +# define f1 33 +# define f2 34 +# define f3 35 +# define f4 36 +# define f5 37 +# define f6 38 +# define f7 39 +# define f8 40 +# define f9 41 +# define f10 42 +# define f11 43 +# define f12 44 +# define f13 45 +# define f14 46 +# define f15 47 +# define f16 48 +# define f17 49 +# define f18 50 +# define f19 51 +# define f20 52 +# define f21 53 +# define f22 54 +# define f23 55 +# define f24 56 +# define f25 57 +# define f26 58 +# define f27 59 +# define f28 60 +# define f29 61 +# define f30 62 +# define f31 63 +# else +# define fr0 32 +# define fr1 33 +# define fr2 34 +# define fr3 35 +# define fr4 36 +# define fr5 37 +# define fr6 38 +# define fr7 39 +# define fr8 40 +# define fr9 41 +# define fr10 42 +# define fr11 43 +# define fr12 44 +# define fr13 45 +# define fr14 46 +# define fr15 47 +# define fr16 48 +# define fr17 49 +# define fr18 50 +# define fr19 51 +# define fr20 52 +# define fr21 53 +# define fr22 54 +# define fr23 55 +# define fr24 56 +# define fr25 57 +# define fr26 58 +# define fr27 59 +# define fr28 60 +# define fr29 61 +# define fr30 62 +# define fr31 63 +# endif + +#elif defined(MACHREGS_sparc) + +# define g0 0 +# define g1 1 +# define g2 2 +# define g3 3 +# define g4 4 +# define g5 5 +# define g6 6 +# define g7 7 + +# define o0 8 +# define o1 9 +# define o2 10 +# define o3 11 +# define o4 12 +# define o5 13 +# define o6 14 +# define o7 15 + +# define l0 16 +# define l1 17 +# define l2 18 +# define l3 19 +# define l4 20 +# define l5 21 +# define l6 22 +# define l7 23 + +# define i0 24 +# define i1 25 +# define i2 26 +# define i3 27 +# define i4 28 +# define i5 29 +# define i6 30 +# define i7 31 + +# define f0 32 +# define f1 33 +# define f2 34 +# define f3 35 +# define f4 36 +# define f5 37 +# define f6 38 +# define f7 39 +# define f8 40 +# define f9 41 +# define f10 42 +# define f11 43 +# define f12 44 +# define f13 45 +# define f14 46 +# define f15 47 +# define f16 48 +# define f17 49 +# define f18 50 +# define f19 51 +# define f20 52 +# define f21 53 +# define f22 54 +# define f23 55 +# define f24 56 +# define f25 57 +# define f26 58 +# define f27 59 +# define f28 60 +# define f29 61 +# define f30 62 +# define f31 63 + +#endif + +callerSaves :: GlobalReg -> Bool +#if defined(CALLER_SAVES_Base) +callerSaves BaseReg = True +#endif +#if defined(CALLER_SAVES_R1) +callerSaves (VanillaReg 1 _) = True +#endif +#if defined(CALLER_SAVES_R2) +callerSaves (VanillaReg 2 _) = True +#endif +#if defined(CALLER_SAVES_R3) +callerSaves (VanillaReg 3 _) = True +#endif +#if defined(CALLER_SAVES_R4) +callerSaves (VanillaReg 4 _) = True +#endif +#if defined(CALLER_SAVES_R5) +callerSaves (VanillaReg 5 _) = True +#endif +#if defined(CALLER_SAVES_R6) +callerSaves (VanillaReg 6 _) = True +#endif +#if defined(CALLER_SAVES_R7) +callerSaves (VanillaReg 7 _) = True +#endif +#if defined(CALLER_SAVES_R8) +callerSaves (VanillaReg 8 _) = True +#endif +#if defined(CALLER_SAVES_R9) +callerSaves (VanillaReg 9 _) = True +#endif +#if defined(CALLER_SAVES_R10) +callerSaves (VanillaReg 10 _) = True +#endif +#if defined(CALLER_SAVES_F1) +callerSaves (FloatReg 1) = True +#endif +#if defined(CALLER_SAVES_F2) +callerSaves (FloatReg 2) = True +#endif +#if defined(CALLER_SAVES_F3) +callerSaves (FloatReg 3) = True +#endif +#if defined(CALLER_SAVES_F4) +callerSaves (FloatReg 4) = True +#endif +#if defined(CALLER_SAVES_F5) +callerSaves (FloatReg 5) = True +#endif +#if defined(CALLER_SAVES_F6) +callerSaves (FloatReg 6) = True +#endif +#if defined(CALLER_SAVES_D1) +callerSaves (DoubleReg 1) = True +#endif +#if defined(CALLER_SAVES_D2) +callerSaves (DoubleReg 2) = True +#endif +#if defined(CALLER_SAVES_D3) +callerSaves (DoubleReg 3) = True +#endif +#if defined(CALLER_SAVES_D4) +callerSaves (DoubleReg 4) = True +#endif +#if defined(CALLER_SAVES_D5) +callerSaves (DoubleReg 5) = True +#endif +#if defined(CALLER_SAVES_D6) +callerSaves (DoubleReg 6) = True +#endif +#if defined(CALLER_SAVES_L1) +callerSaves (LongReg 1) = True +#endif +#if defined(CALLER_SAVES_Sp) +callerSaves Sp = True +#endif +#if defined(CALLER_SAVES_SpLim) +callerSaves SpLim = True +#endif +#if defined(CALLER_SAVES_Hp) +callerSaves Hp = True +#endif +#if defined(CALLER_SAVES_HpLim) +callerSaves HpLim = True +#endif +#if defined(CALLER_SAVES_CCCS) +callerSaves CCCS = True +#endif +#if defined(CALLER_SAVES_CurrentTSO) +callerSaves CurrentTSO = True +#endif +#if defined(CALLER_SAVES_CurrentNursery) +callerSaves CurrentNursery = True +#endif +callerSaves _ = False + +activeStgRegs :: [GlobalReg] +activeStgRegs = [ +#if defined(REG_Base) + BaseReg +#endif +#if defined(REG_Sp) + ,Sp +#endif +#if defined(REG_Hp) + ,Hp +#endif +#if defined(REG_R1) + ,VanillaReg 1 VGcPtr +#endif +#if defined(REG_R2) + ,VanillaReg 2 VGcPtr +#endif +#if defined(REG_R3) + ,VanillaReg 3 VGcPtr +#endif +#if defined(REG_R4) + ,VanillaReg 4 VGcPtr +#endif +#if defined(REG_R5) + ,VanillaReg 5 VGcPtr +#endif +#if defined(REG_R6) + ,VanillaReg 6 VGcPtr +#endif +#if defined(REG_R7) + ,VanillaReg 7 VGcPtr +#endif +#if defined(REG_R8) + ,VanillaReg 8 VGcPtr +#endif +#if defined(REG_R9) + ,VanillaReg 9 VGcPtr +#endif +#if defined(REG_R10) + ,VanillaReg 10 VGcPtr +#endif +#if defined(REG_SpLim) + ,SpLim +#endif +#if MAX_REAL_XMM_REG != 0 +#if defined(REG_F1) + ,FloatReg 1 +#endif +#if defined(REG_D1) + ,DoubleReg 1 +#endif +#if defined(REG_XMM1) + ,XmmReg 1 +#endif +#if defined(REG_YMM1) + ,YmmReg 1 +#endif +#if defined(REG_ZMM1) + ,ZmmReg 1 +#endif +#if defined(REG_F2) + ,FloatReg 2 +#endif +#if defined(REG_D2) + ,DoubleReg 2 +#endif +#if defined(REG_XMM2) + ,XmmReg 2 +#endif +#if defined(REG_YMM2) + ,YmmReg 2 +#endif +#if defined(REG_ZMM2) + ,ZmmReg 2 +#endif +#if defined(REG_F3) + ,FloatReg 3 +#endif +#if defined(REG_D3) + ,DoubleReg 3 +#endif +#if defined(REG_XMM3) + ,XmmReg 3 +#endif +#if defined(REG_YMM3) + ,YmmReg 3 +#endif +#if defined(REG_ZMM3) + ,ZmmReg 3 +#endif +#if defined(REG_F4) + ,FloatReg 4 +#endif +#if defined(REG_D4) + ,DoubleReg 4 +#endif +#if defined(REG_XMM4) + ,XmmReg 4 +#endif +#if defined(REG_YMM4) + ,YmmReg 4 +#endif +#if defined(REG_ZMM4) + ,ZmmReg 4 +#endif +#if defined(REG_F5) + ,FloatReg 5 +#endif +#if defined(REG_D5) + ,DoubleReg 5 +#endif +#if defined(REG_XMM5) + ,XmmReg 5 +#endif +#if defined(REG_YMM5) + ,YmmReg 5 +#endif +#if defined(REG_ZMM5) + ,ZmmReg 5 +#endif +#if defined(REG_F6) + ,FloatReg 6 +#endif +#if defined(REG_D6) + ,DoubleReg 6 +#endif +#if defined(REG_XMM6) + ,XmmReg 6 +#endif +#if defined(REG_YMM6) + ,YmmReg 6 +#endif +#if defined(REG_ZMM6) + ,ZmmReg 6 +#endif +#else /* MAX_REAL_XMM_REG == 0 */ +#if defined(REG_F1) + ,FloatReg 1 +#endif +#if defined(REG_F2) + ,FloatReg 2 +#endif +#if defined(REG_F3) + ,FloatReg 3 +#endif +#if defined(REG_F4) + ,FloatReg 4 +#endif +#if defined(REG_F5) + ,FloatReg 5 +#endif +#if defined(REG_F6) + ,FloatReg 6 +#endif +#if defined(REG_D1) + ,DoubleReg 1 +#endif +#if defined(REG_D2) + ,DoubleReg 2 +#endif +#if defined(REG_D3) + ,DoubleReg 3 +#endif +#if defined(REG_D4) + ,DoubleReg 4 +#endif +#if defined(REG_D5) + ,DoubleReg 5 +#endif +#if defined(REG_D6) + ,DoubleReg 6 +#endif +#endif /* MAX_REAL_XMM_REG == 0 */ + ] + +haveRegBase :: Bool +#if defined(REG_Base) +haveRegBase = True +#else +haveRegBase = False +#endif + +-- | Returns 'Nothing' if this global register is not stored +-- in a real machine register, otherwise returns @'Just' reg@, where +-- reg is the machine register it is stored in. +globalRegMaybe :: GlobalReg -> Maybe RealReg +#if defined(MACHREGS_i386) || defined(MACHREGS_x86_64) \ + || defined(MACHREGS_sparc) || defined(MACHREGS_powerpc) \ + || defined(MACHREGS_arm) || defined(MACHREGS_aarch64) +# if defined(REG_Base) +globalRegMaybe BaseReg = Just (RealRegSingle REG_Base) +# endif +# if defined(REG_R1) +globalRegMaybe (VanillaReg 1 _) = Just (RealRegSingle REG_R1) +# endif +# if defined(REG_R2) +globalRegMaybe (VanillaReg 2 _) = Just (RealRegSingle REG_R2) +# endif +# if defined(REG_R3) +globalRegMaybe (VanillaReg 3 _) = Just (RealRegSingle REG_R3) +# endif +# if defined(REG_R4) +globalRegMaybe (VanillaReg 4 _) = Just (RealRegSingle REG_R4) +# endif +# if defined(REG_R5) +globalRegMaybe (VanillaReg 5 _) = Just (RealRegSingle REG_R5) +# endif +# if defined(REG_R6) +globalRegMaybe (VanillaReg 6 _) = Just (RealRegSingle REG_R6) +# endif +# if defined(REG_R7) +globalRegMaybe (VanillaReg 7 _) = Just (RealRegSingle REG_R7) +# endif +# if defined(REG_R8) +globalRegMaybe (VanillaReg 8 _) = Just (RealRegSingle REG_R8) +# endif +# if defined(REG_R9) +globalRegMaybe (VanillaReg 9 _) = Just (RealRegSingle REG_R9) +# endif +# if defined(REG_R10) +globalRegMaybe (VanillaReg 10 _) = Just (RealRegSingle REG_R10) +# endif +# if defined(REG_F1) +globalRegMaybe (FloatReg 1) = Just (RealRegSingle REG_F1) +# endif +# if defined(REG_F2) +globalRegMaybe (FloatReg 2) = Just (RealRegSingle REG_F2) +# endif +# if defined(REG_F3) +globalRegMaybe (FloatReg 3) = Just (RealRegSingle REG_F3) +# endif +# if defined(REG_F4) +globalRegMaybe (FloatReg 4) = Just (RealRegSingle REG_F4) +# endif +# if defined(REG_F5) +globalRegMaybe (FloatReg 5) = Just (RealRegSingle REG_F5) +# endif +# if defined(REG_F6) +globalRegMaybe (FloatReg 6) = Just (RealRegSingle REG_F6) +# endif +# if defined(REG_D1) +globalRegMaybe (DoubleReg 1) = +# if defined(MACHREGS_sparc) + Just (RealRegPair REG_D1 (REG_D1 + 1)) +# else + Just (RealRegSingle REG_D1) +# endif +# endif +# if defined(REG_D2) +globalRegMaybe (DoubleReg 2) = +# if defined(MACHREGS_sparc) + Just (RealRegPair REG_D2 (REG_D2 + 1)) +# else + Just (RealRegSingle REG_D2) +# endif +# endif +# if defined(REG_D3) +globalRegMaybe (DoubleReg 3) = +# if defined(MACHREGS_sparc) + Just (RealRegPair REG_D3 (REG_D3 + 1)) +# else + Just (RealRegSingle REG_D3) +# endif +# endif +# if defined(REG_D4) +globalRegMaybe (DoubleReg 4) = +# if defined(MACHREGS_sparc) + Just (RealRegPair REG_D4 (REG_D4 + 1)) +# else + Just (RealRegSingle REG_D4) +# endif +# endif +# if defined(REG_D5) +globalRegMaybe (DoubleReg 5) = +# if defined(MACHREGS_sparc) + Just (RealRegPair REG_D5 (REG_D5 + 1)) +# else + Just (RealRegSingle REG_D5) +# endif +# endif +# if defined(REG_D6) +globalRegMaybe (DoubleReg 6) = +# if defined(MACHREGS_sparc) + Just (RealRegPair REG_D6 (REG_D6 + 1)) +# else + Just (RealRegSingle REG_D6) +# endif +# endif +# if MAX_REAL_XMM_REG != 0 +# if defined(REG_XMM1) +globalRegMaybe (XmmReg 1) = Just (RealRegSingle REG_XMM1) +# endif +# if defined(REG_XMM2) +globalRegMaybe (XmmReg 2) = Just (RealRegSingle REG_XMM2) +# endif +# if defined(REG_XMM3) +globalRegMaybe (XmmReg 3) = Just (RealRegSingle REG_XMM3) +# endif +# if defined(REG_XMM4) +globalRegMaybe (XmmReg 4) = Just (RealRegSingle REG_XMM4) +# endif +# if defined(REG_XMM5) +globalRegMaybe (XmmReg 5) = Just (RealRegSingle REG_XMM5) +# endif +# if defined(REG_XMM6) +globalRegMaybe (XmmReg 6) = Just (RealRegSingle REG_XMM6) +# endif +# endif +# if defined(MAX_REAL_YMM_REG) && MAX_REAL_YMM_REG != 0 +# if defined(REG_YMM1) +globalRegMaybe (YmmReg 1) = Just (RealRegSingle REG_YMM1) +# endif +# if defined(REG_YMM2) +globalRegMaybe (YmmReg 2) = Just (RealRegSingle REG_YMM2) +# endif +# if defined(REG_YMM3) +globalRegMaybe (YmmReg 3) = Just (RealRegSingle REG_YMM3) +# endif +# if defined(REG_YMM4) +globalRegMaybe (YmmReg 4) = Just (RealRegSingle REG_YMM4) +# endif +# if defined(REG_YMM5) +globalRegMaybe (YmmReg 5) = Just (RealRegSingle REG_YMM5) +# endif +# if defined(REG_YMM6) +globalRegMaybe (YmmReg 6) = Just (RealRegSingle REG_YMM6) +# endif +# endif +# if defined(MAX_REAL_ZMM_REG) && MAX_REAL_ZMM_REG != 0 +# if defined(REG_ZMM1) +globalRegMaybe (ZmmReg 1) = Just (RealRegSingle REG_ZMM1) +# endif +# if defined(REG_ZMM2) +globalRegMaybe (ZmmReg 2) = Just (RealRegSingle REG_ZMM2) +# endif +# if defined(REG_ZMM3) +globalRegMaybe (ZmmReg 3) = Just (RealRegSingle REG_ZMM3) +# endif +# if defined(REG_ZMM4) +globalRegMaybe (ZmmReg 4) = Just (RealRegSingle REG_ZMM4) +# endif +# if defined(REG_ZMM5) +globalRegMaybe (ZmmReg 5) = Just (RealRegSingle REG_ZMM5) +# endif +# if defined(REG_ZMM6) +globalRegMaybe (ZmmReg 6) = Just (RealRegSingle REG_ZMM6) +# endif +# endif +# if defined(REG_Sp) +globalRegMaybe Sp = Just (RealRegSingle REG_Sp) +# endif +# if defined(REG_Lng1) +globalRegMaybe (LongReg 1) = Just (RealRegSingle REG_Lng1) +# endif +# if defined(REG_Lng2) +globalRegMaybe (LongReg 2) = Just (RealRegSingle REG_Lng2) +# endif +# if defined(REG_SpLim) +globalRegMaybe SpLim = Just (RealRegSingle REG_SpLim) +# endif +# if defined(REG_Hp) +globalRegMaybe Hp = Just (RealRegSingle REG_Hp) +# endif +# if defined(REG_HpLim) +globalRegMaybe HpLim = Just (RealRegSingle REG_HpLim) +# endif +# if defined(REG_CurrentTSO) +globalRegMaybe CurrentTSO = Just (RealRegSingle REG_CurrentTSO) +# endif +# if defined(REG_CurrentNursery) +globalRegMaybe CurrentNursery = Just (RealRegSingle REG_CurrentNursery) +# endif +# if defined(REG_MachSp) +globalRegMaybe MachSp = Just (RealRegSingle REG_MachSp) +# endif +globalRegMaybe _ = Nothing +#elif defined(MACHREGS_NO_REGS) +globalRegMaybe _ = Nothing +#else +globalRegMaybe = panic "globalRegMaybe not defined for this platform" +#endif + +freeReg :: RegNo -> Bool + +#if defined(MACHREGS_i386) || defined(MACHREGS_x86_64) + +# if defined(MACHREGS_i386) +freeReg esp = False -- %esp is the C stack pointer +freeReg esi = False -- Note [esi/edi/ebp not allocatable] +freeReg edi = False +freeReg ebp = False +# endif +# if defined(MACHREGS_x86_64) +freeReg rsp = False -- %rsp is the C stack pointer +# endif + +{- +Note [esi/edi/ebp not allocatable] + +%esi is mapped to R1, so %esi would normally be allocatable while it +is not being used for R1. However, %esi has no 8-bit version on x86, +and the linear register allocator is not sophisticated enough to +handle this irregularity (we need more RegClasses). The +graph-colouring allocator also cannot handle this - it was designed +with more flexibility in mind, but the current implementation is +restricted to the same set of classes as the linear allocator. + +Hence, on x86 esi, edi and ebp are treated as not allocatable. +-} + +-- split patterns in two functions to prevent overlaps +freeReg r = freeRegBase r + +freeRegBase :: RegNo -> Bool +# if defined(REG_Base) +freeRegBase REG_Base = False +# endif +# if defined(REG_Sp) +freeRegBase REG_Sp = False +# endif +# if defined(REG_SpLim) +freeRegBase REG_SpLim = False +# endif +# if defined(REG_Hp) +freeRegBase REG_Hp = False +# endif +# if defined(REG_HpLim) +freeRegBase REG_HpLim = False +# endif +-- All other regs are considered to be "free", because we can track +-- their liveness accurately. +freeRegBase _ = True + +#elif defined(MACHREGS_powerpc) + +freeReg 0 = False -- Used by code setting the back chain pointer + -- in stack reallocations on Linux. + -- Moreover r0 is not usable in all insns. +freeReg 1 = False -- The Stack Pointer +-- most ELF PowerPC OSes use r2 as a TOC pointer +freeReg 2 = False +freeReg 13 = False -- reserved for system thread ID on 64 bit +-- at least linux in -fPIC relies on r30 in PLT stubs +freeReg 30 = False +{- TODO: reserve r13 on 64 bit systems only and r30 on 32 bit respectively. + For now we use r30 on 64 bit and r13 on 32 bit as a temporary register + in stack handling code. See compiler/nativeGen/PPC/Instr.hs. + + Later we might want to reserve r13 and r30 only where it is required. + Then use r12 as temporary register, which is also what the C ABI does. +-} + +# if defined(REG_Base) +freeReg REG_Base = False +# endif +# if defined(REG_Sp) +freeReg REG_Sp = False +# endif +# if defined(REG_SpLim) +freeReg REG_SpLim = False +# endif +# if defined(REG_Hp) +freeReg REG_Hp = False +# endif +# if defined(REG_HpLim) +freeReg REG_HpLim = False +# endif +freeReg _ = True + +#elif defined(MACHREGS_sparc) + +-- SPARC regs used by the OS / ABI +-- %g0(r0) is always zero +freeReg g0 = False + +-- %g5(r5) - %g7(r7) +-- are reserved for the OS +freeReg g5 = False +freeReg g6 = False +freeReg g7 = False + +-- %o6(r14) +-- is the C stack pointer +freeReg o6 = False + +-- %o7(r15) +-- holds the C return address +freeReg o7 = False + +-- %i6(r30) +-- is the C frame pointer +freeReg i6 = False + +-- %i7(r31) +-- is used for C return addresses +freeReg i7 = False + +-- %f0(r32) - %f1(r32) +-- are C floating point return regs +freeReg f0 = False +freeReg f1 = False + +{- +freeReg regNo + -- don't release high half of double regs + | regNo >= f0 + , regNo < NCG_FirstFloatReg + , regNo `mod` 2 /= 0 + = False +-} + +# if defined(REG_Base) +freeReg REG_Base = False +# endif +# if defined(REG_R1) +freeReg REG_R1 = False +# endif +# if defined(REG_R2) +freeReg REG_R2 = False +# endif +# if defined(REG_R3) +freeReg REG_R3 = False +# endif +# if defined(REG_R4) +freeReg REG_R4 = False +# endif +# if defined(REG_R5) +freeReg REG_R5 = False +# endif +# if defined(REG_R6) +freeReg REG_R6 = False +# endif +# if defined(REG_R7) +freeReg REG_R7 = False +# endif +# if defined(REG_R8) +freeReg REG_R8 = False +# endif +# if defined(REG_R9) +freeReg REG_R9 = False +# endif +# if defined(REG_R10) +freeReg REG_R10 = False +# endif +# if defined(REG_F1) +freeReg REG_F1 = False +# endif +# if defined(REG_F2) +freeReg REG_F2 = False +# endif +# if defined(REG_F3) +freeReg REG_F3 = False +# endif +# if defined(REG_F4) +freeReg REG_F4 = False +# endif +# if defined(REG_F5) +freeReg REG_F5 = False +# endif +# if defined(REG_F6) +freeReg REG_F6 = False +# endif +# if defined(REG_D1) +freeReg REG_D1 = False +# endif +# if defined(REG_D1_2) +freeReg REG_D1_2 = False +# endif +# if defined(REG_D2) +freeReg REG_D2 = False +# endif +# if defined(REG_D2_2) +freeReg REG_D2_2 = False +# endif +# if defined(REG_D3) +freeReg REG_D3 = False +# endif +# if defined(REG_D3_2) +freeReg REG_D3_2 = False +# endif +# if defined(REG_D4) +freeReg REG_D4 = False +# endif +# if defined(REG_D4_2) +freeReg REG_D4_2 = False +# endif +# if defined(REG_D5) +freeReg REG_D5 = False +# endif +# if defined(REG_D5_2) +freeReg REG_D5_2 = False +# endif +# if defined(REG_D6) +freeReg REG_D6 = False +# endif +# if defined(REG_D6_2) +freeReg REG_D6_2 = False +# endif +# if defined(REG_Sp) +freeReg REG_Sp = False +# endif +# if defined(REG_SpLim) +freeReg REG_SpLim = False +# endif +# if defined(REG_Hp) +freeReg REG_Hp = False +# endif +# if defined(REG_HpLim) +freeReg REG_HpLim = False +# endif +freeReg _ = True + +#else + +freeReg = panic "freeReg not defined for this platform" + +#endif + diff --git a/includes/HsFFI.h b/includes/HsFFI.h new file mode 100644 --- /dev/null +++ b/includes/HsFFI.h @@ -0,0 +1,141 @@ +/* ----------------------------------------------------------------------------- + * + * (c) The GHC Team, 2000 + * + * A mapping for Haskell types to C types, including the corresponding bounds. + * Intended to be used in conjuction with the FFI. + * + * WARNING: Keep this file and StgTypes.h in synch! + * + * ---------------------------------------------------------------------------*/ + +#pragma once + +#if defined(__cplusplus) +extern "C" { +#endif + +/* get types from GHC's runtime system */ +#include "ghcconfig.h" +#include "stg/Types.h" + +/* get limits for floating point types */ +#include + +typedef StgChar HsChar; +typedef StgInt HsInt; +typedef StgInt8 HsInt8; +typedef StgInt16 HsInt16; +typedef StgInt32 HsInt32; +typedef StgInt64 HsInt64; +typedef StgWord HsWord; +typedef StgWord8 HsWord8; +typedef StgWord16 HsWord16; +typedef StgWord32 HsWord32; +typedef StgWord64 HsWord64; +typedef StgFloat HsFloat; +typedef StgDouble HsDouble; +typedef StgInt HsBool; +typedef void* HsPtr; /* this should better match StgAddr */ +typedef void (*HsFunPtr)(void); /* this should better match StgAddr */ +typedef void* HsStablePtr; + +/* this should correspond to the type of StgChar in StgTypes.h */ +#define HS_CHAR_MIN 0 +#define HS_CHAR_MAX 0x10FFFF + +/* is it true or not? */ +#define HS_BOOL_FALSE 0 +#define HS_BOOL_TRUE 1 + +#define HS_BOOL_MIN HS_BOOL_FALSE +#define HS_BOOL_MAX HS_BOOL_TRUE + + +#define HS_INT_MIN STG_INT_MIN +#define HS_INT_MAX STG_INT_MAX +#define HS_WORD_MAX STG_WORD_MAX + +#define HS_INT8_MIN STG_INT8_MIN +#define HS_INT8_MAX STG_INT8_MAX +#define HS_INT16_MIN STG_INT16_MIN +#define HS_INT16_MAX STG_INT16_MAX +#define HS_INT32_MIN STG_INT32_MIN +#define HS_INT32_MAX STG_INT32_MAX +#define HS_INT64_MIN STG_INT64_MIN +#define HS_INT64_MAX STG_INT64_MAX +#define HS_WORD8_MAX STG_WORD8_MAX +#define HS_WORD16_MAX STG_WORD16_MAX +#define HS_WORD32_MAX STG_WORD32_MAX +#define HS_WORD64_MAX STG_WORD64_MAX + +#define HS_FLOAT_RADIX FLT_RADIX +#define HS_FLOAT_ROUNDS FLT_ROUNDS +#define HS_FLOAT_EPSILON FLT_EPSILON +#define HS_FLOAT_DIG FLT_DIG +#define HS_FLOAT_MANT_DIG FLT_MANT_DIG +#define HS_FLOAT_MIN FLT_MIN +#define HS_FLOAT_MIN_EXP FLT_MIN_EXP +#define HS_FLOAT_MIN_10_EXP FLT_MIN_10_EXP +#define HS_FLOAT_MAX FLT_MAX +#define HS_FLOAT_MAX_EXP FLT_MAX_EXP +#define HS_FLOAT_MAX_10_EXP FLT_MAX_10_EXP + +#define HS_DOUBLE_RADIX DBL_RADIX +#define HS_DOUBLE_ROUNDS DBL_ROUNDS +#define HS_DOUBLE_EPSILON DBL_EPSILON +#define HS_DOUBLE_DIG DBL_DIG +#define HS_DOUBLE_MANT_DIG DBL_MANT_DIG +#define HS_DOUBLE_MIN DBL_MIN +#define HS_DOUBLE_MIN_EXP DBL_MIN_EXP +#define HS_DOUBLE_MIN_10_EXP DBL_MIN_10_EXP +#define HS_DOUBLE_MAX DBL_MAX +#define HS_DOUBLE_MAX_EXP DBL_MAX_EXP +#define HS_DOUBLE_MAX_10_EXP DBL_MAX_10_EXP + +extern void hs_init (int *argc, char **argv[]); +extern void hs_exit (void); +extern void hs_exit_nowait(void); +extern void hs_set_argv (int argc, char *argv[]); +extern void hs_thread_done (void); + +extern void hs_perform_gc (void); + +// Lock the stable pointer table. The table must be unlocked +// again before calling any Haskell functions, even if those +// functions do not manipulate stable pointers. The Haskell +// garbage collector will not be able to run until this lock +// is released! It is also forbidden to call hs_free_fun_ptr +// or any stable pointer-related FFI functions other than +// hs_free_stable_ptr_unsafe while the table is locked. +extern void hs_lock_stable_ptr_table (void); + +// A deprecated synonym. +extern void hs_lock_stable_tables (void); + +// Unlock the stable pointer table. +extern void hs_unlock_stable_ptr_table (void); + +// A deprecated synonym. +extern void hs_unlock_stable_tables (void); + +// Free a stable pointer assuming that the stable pointer +// table is already locked. +extern void hs_free_stable_ptr_unsafe (HsStablePtr sp); + +extern void hs_free_stable_ptr (HsStablePtr sp); +extern void hs_free_fun_ptr (HsFunPtr fp); + +extern StgPtr hs_spt_lookup(StgWord64 key1, StgWord64 key2); +extern int hs_spt_keys(StgPtr keys[], int szKeys); +extern int hs_spt_key_count (void); + +extern void hs_try_putmvar (int capability, HsStablePtr sp); + +/* -------------------------------------------------------------------------- */ + + + +#if defined(__cplusplus) +} +#endif diff --git a/includes/MachDeps.h b/includes/MachDeps.h new file mode 100644 --- /dev/null +++ b/includes/MachDeps.h @@ -0,0 +1,123 @@ +/* ----------------------------------------------------------------------------- + * + * (c) The University of Glasgow 2002 + * + * Definitions that characterise machine specific properties of basic + * types (C & Haskell) of a target platform. + * + * NB: Keep in sync with HsFFI.h and StgTypes.h. + * NB: THIS FILE IS INCLUDED IN HASKELL SOURCE! + * + * To understand the structure of the RTS headers, see the wiki: + * https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes + * + * ---------------------------------------------------------------------------*/ + +#pragma once + +/* Don't allow stage1 (cross-)compiler embed assumptions about target + * platform. When ghc-stage1 is being built by ghc-stage0 is should not + * refer to target defines. A few past examples: + * - https://gitlab.haskell.org/ghc/ghc/issues/13491 + * - https://phabricator.haskell.org/D3122 + * - https://phabricator.haskell.org/D3405 + * + * In those cases code change assumed target defines like SIZEOF_HSINT + * are applied to host platform, not target platform. + * + * So what should be used instead in STAGE=1? + * + * To get host's equivalent of SIZEOF_HSINT you can use Bits instances: + * Data.Bits.finiteBitSize (0 :: Int) + * + * To get target's values it is preferred to use runtime target + * configuration from 'targetPlatform :: DynFlags -> Platform' + * record. A few wrappers are already defined and used throughout GHC: + * wORD_SIZE :: DynFlags -> Int + * wORD_SIZE dflags = pc_WORD_SIZE (sPlatformConstants (settings dflags)) + * + * Hence we hide these macros from -DSTAGE=1 + */ +#if !defined(STAGE) || STAGE >= 2 + +/* Sizes of C types come from here... */ +#include "ghcautoconf.h" + +/* Sizes of Haskell types follow. These sizes correspond to: + * - the number of bytes in the primitive type (eg. Int#) + * - the number of bytes in the external representation (eg. HsInt) + * - the scale offset used by writeFooOffAddr# + * + * In the heap, the type may take up more space: eg. SIZEOF_INT8 == 1, + * but it takes up SIZEOF_HSWORD (4 or 8) bytes in the heap. + */ + +#define SIZEOF_HSCHAR SIZEOF_WORD32 +#define ALIGNMENT_HSCHAR ALIGNMENT_WORD32 + +#define SIZEOF_HSINT SIZEOF_VOID_P +#define ALIGNMENT_HSINT ALIGNMENT_VOID_P + +#define SIZEOF_HSWORD SIZEOF_VOID_P +#define ALIGNMENT_HSWORD ALIGNMENT_VOID_P + +#define SIZEOF_HSDOUBLE SIZEOF_DOUBLE +#define ALIGNMENT_HSDOUBLE ALIGNMENT_DOUBLE + +#define SIZEOF_HSFLOAT SIZEOF_FLOAT +#define ALIGNMENT_HSFLOAT ALIGNMENT_FLOAT + +#define SIZEOF_HSPTR SIZEOF_VOID_P +#define ALIGNMENT_HSPTR ALIGNMENT_VOID_P + +#define SIZEOF_HSFUNPTR SIZEOF_VOID_P +#define ALIGNMENT_HSFUNPTR ALIGNMENT_VOID_P + +#define SIZEOF_HSSTABLEPTR SIZEOF_VOID_P +#define ALIGNMENT_HSSTABLEPTR ALIGNMENT_VOID_P + +#define SIZEOF_INT8 SIZEOF_INT8_T +#define ALIGNMENT_INT8 ALIGNMENT_INT8_T + +#define SIZEOF_WORD8 SIZEOF_UINT8_T +#define ALIGNMENT_WORD8 ALIGNMENT_UINT8_T + +#define SIZEOF_INT16 SIZEOF_INT16_T +#define ALIGNMENT_INT16 ALIGNMENT_INT16_T + +#define SIZEOF_WORD16 SIZEOF_UINT16_T +#define ALIGNMENT_WORD16 ALIGNMENT_UINT16_T + +#define SIZEOF_INT32 SIZEOF_INT32_T +#define ALIGNMENT_INT32 ALIGNMENT_INT32_T + +#define SIZEOF_WORD32 SIZEOF_UINT32_T +#define ALIGNMENT_WORD32 ALIGNMENT_UINT32_T + +#define SIZEOF_INT64 SIZEOF_INT64_T +#define ALIGNMENT_INT64 ALIGNMENT_INT64_T + +#define SIZEOF_WORD64 SIZEOF_UINT64_T +#define ALIGNMENT_WORD64 ALIGNMENT_UINT64_T + +#if !defined(WORD_SIZE_IN_BITS) +#if SIZEOF_HSWORD == 4 +#define WORD_SIZE_IN_BITS 32 +#define WORD_SIZE_IN_BITS_FLOAT 32.0 +#else +#define WORD_SIZE_IN_BITS 64 +#define WORD_SIZE_IN_BITS_FLOAT 64.0 +#endif +#endif + +#if !defined(TAG_BITS) +#if SIZEOF_HSWORD == 4 +#define TAG_BITS 2 +#else +#define TAG_BITS 3 +#endif +#endif + +#define TAG_MASK ((1 << TAG_BITS) - 1) + +#endif /* !defined(STAGE) || STAGE >= 2 */ diff --git a/includes/Rts.h b/includes/Rts.h new file mode 100644 --- /dev/null +++ b/includes/Rts.h @@ -0,0 +1,317 @@ +/* ----------------------------------------------------------------------------- + * + * (c) The GHC Team, 1998-2009 + * + * RTS external APIs. This file declares everything that the GHC RTS + * exposes externally. + * + * To understand the structure of the RTS headers, see the wiki: + * https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes + * + * ---------------------------------------------------------------------------*/ + +#pragma once + +#if defined(__cplusplus) +extern "C" { +#endif + +/* We include windows.h very early, as on Win64 the CONTEXT type has + fields "R8", "R9" and "R10", which goes bad if we've already + #define'd those names for our own purposes (in stg/Regs.h) */ +#if defined(HAVE_WINDOWS_H) +#include +#endif + +#if !defined(IN_STG_CODE) +#define IN_STG_CODE 0 +#endif +#include "Stg.h" + +#include "HsFFI.h" +#include "RtsAPI.h" + +// Turn off inlining when debugging - it obfuscates things +#if defined(DEBUG) +# undef STATIC_INLINE +# define STATIC_INLINE static +#endif + +#include "rts/Types.h" +#include "rts/Time.h" + +#if __GNUC__ >= 3 +#define ATTRIBUTE_ALIGNED(n) __attribute__((aligned(n))) +#else +#define ATTRIBUTE_ALIGNED(n) /*nothing*/ +#endif + +// Symbols that are extern, but private to the RTS, are declared +// with visibility "hidden" to hide them outside the RTS shared +// library. +#if defined(HAS_VISIBILITY_HIDDEN) +#define RTS_PRIVATE GNUC3_ATTRIBUTE(visibility("hidden")) +#else +#define RTS_PRIVATE /* disabled: RTS_PRIVATE */ +#endif + +#if __GNUC__ >= 4 +#define RTS_UNLIKELY(p) __builtin_expect((p),0) +#else +#define RTS_UNLIKELY(p) (p) +#endif + +#if __GNUC__ >= 4 +#define RTS_LIKELY(p) __builtin_expect(!!(p), 1) +#else +#define RTS_LIKELY(p) (p) +#endif + +/* __builtin_unreachable is supported since GNU C 4.5 */ +#if __GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 5) +#define RTS_UNREACHABLE __builtin_unreachable() +#else +#define RTS_UNREACHABLE abort() +#endif + +/* Fix for mingw stat problem (done here so it's early enough) */ +#if defined(mingw32_HOST_OS) +#define __MSVCRT__ 1 +#endif + +/* Needed to get the macro version of errno on some OSs, and also to + get prototypes for the _r versions of C library functions. */ +#if !defined(_REENTRANT) +#define _REENTRANT 1 +#endif + +/* + * We often want to know the size of something in units of an + * StgWord... (rounded up, of course!) + */ +#define ROUNDUP_BYTES_TO_WDS(n) (((n) + sizeof(W_) - 1) / sizeof(W_)) + +#define sizeofW(t) ROUNDUP_BYTES_TO_WDS(sizeof(t)) + +/* ----------------------------------------------------------------------------- + Assertions and Debuggery + + CHECK(p) evaluates p and terminates with an error if p is false + ASSERT(p) like CHECK(p) if DEBUG is on, otherwise a no-op + -------------------------------------------------------------------------- */ + +void _assertFail(const char *filename, unsigned int linenum) + GNUC3_ATTRIBUTE(__noreturn__); + +#define CHECK(predicate) \ + if (predicate) \ + /*null*/; \ + else \ + _assertFail(__FILE__, __LINE__) + +#define CHECKM(predicate, msg, ...) \ + if (predicate) \ + /*null*/; \ + else \ + barf(msg, ##__VA_ARGS__) + +#if !defined(DEBUG) +#define ASSERT(predicate) /* nothing */ +#define ASSERTM(predicate,msg,...) /* nothing */ +#else +#define ASSERT(predicate) CHECK(predicate) +#define ASSERTM(predicate,msg,...) CHECKM(predicate,msg,##__VA_ARGS__) +#endif /* DEBUG */ + +/* + * Use this on the RHS of macros which expand to nothing + * to make sure that the macro can be used in a context which + * demands a non-empty statement. + */ + +#define doNothing() do { } while (0) + +#if defined(DEBUG) +#define USED_IF_DEBUG +#define USED_IF_NOT_DEBUG STG_UNUSED +#else +#define USED_IF_DEBUG STG_UNUSED +#define USED_IF_NOT_DEBUG +#endif + +#if defined(THREADED_RTS) +#define USED_IF_THREADS +#define USED_IF_NOT_THREADS STG_UNUSED +#else +#define USED_IF_THREADS STG_UNUSED +#define USED_IF_NOT_THREADS +#endif + +#define FMT_SizeT "zu" +#define FMT_HexSizeT "zx" + +/* ----------------------------------------------------------------------------- + Include everything STG-ish + -------------------------------------------------------------------------- */ + +/* System headers: stdlib.h is needed so that we can use NULL. It must + * come after MachRegs.h, because stdlib.h might define some inline + * functions which may only be defined after register variables have + * been declared. + */ +#include + +#include "rts/Config.h" + +/* Global constraints */ +#include "rts/Constants.h" + +/* Profiling information */ +#include "rts/prof/CCS.h" +#include "rts/prof/LDV.h" + +/* Parallel information */ +#include "rts/OSThreads.h" +#include "rts/SpinLock.h" + +#include "rts/Messages.h" +#include "rts/Threads.h" + +/* Storage format definitions */ +#include "rts/storage/FunTypes.h" +#include "rts/storage/InfoTables.h" +#include "rts/storage/Closures.h" +#include "rts/storage/Heap.h" +#include "rts/storage/ClosureTypes.h" +#include "rts/storage/TSO.h" +#include "stg/MiscClosures.h" /* InfoTables, closures etc. defined in the RTS */ +#include "rts/storage/Block.h" +#include "rts/storage/ClosureMacros.h" +#include "rts/storage/MBlock.h" +#include "rts/storage/GC.h" + +/* Other RTS external APIs */ +#include "rts/Parallel.h" +#include "rts/Signals.h" +#include "rts/BlockSignals.h" +#include "rts/Hpc.h" +#include "rts/Flags.h" +#include "rts/Adjustor.h" +#include "rts/FileLock.h" +#include "rts/GetTime.h" +#include "rts/Globals.h" +#include "rts/IOManager.h" +#include "rts/Linker.h" +#include "rts/Ticky.h" +#include "rts/Timer.h" +#include "rts/StablePtr.h" +#include "rts/StableName.h" +#include "rts/TTY.h" +#include "rts/Utils.h" +#include "rts/PrimFloat.h" +#include "rts/Main.h" +#include "rts/Profiling.h" +#include "rts/StaticPtrTable.h" +#include "rts/Libdw.h" +#include "rts/LibdwPool.h" + +/* Misc stuff without a home */ +DLL_IMPORT_RTS extern char **prog_argv; /* so we can get at these from Haskell */ +DLL_IMPORT_RTS extern int prog_argc; +DLL_IMPORT_RTS extern char *prog_name; + +void reportStackOverflow(StgTSO* tso); +void reportHeapOverflow(void); + +void stg_exit(int n) GNU_ATTRIBUTE(__noreturn__); + +#if !defined(mingw32_HOST_OS) +int stg_sig_install (int, int, void *); +#endif + +/* ----------------------------------------------------------------------------- + Ways + -------------------------------------------------------------------------- */ + +// Returns non-zero if the RTS is a profiling version +int rts_isProfiled(void); + +// Returns non-zero if the RTS is a dynamically-linked version +int rts_isDynamic(void); + +/* ----------------------------------------------------------------------------- + RTS Exit codes + -------------------------------------------------------------------------- */ + +/* 255 is allegedly used by dynamic linkers to report linking failure */ +#define EXIT_INTERNAL_ERROR 254 +#define EXIT_DEADLOCK 253 +#define EXIT_INTERRUPTED 252 +#define EXIT_HEAPOVERFLOW 251 +#define EXIT_KILLED 250 + +/* ----------------------------------------------------------------------------- + Miscellaneous garbage + -------------------------------------------------------------------------- */ + +#if defined(DEBUG) +#define TICK_VAR(arity) \ + extern StgInt SLOW_CALLS_##arity; \ + extern StgInt RIGHT_ARITY_##arity; \ + extern StgInt TAGGED_PTR_##arity; + +extern StgInt TOTAL_CALLS; + +TICK_VAR(1) +TICK_VAR(2) +#endif + +/* ----------------------------------------------------------------------------- + Assertions and Debuggery + -------------------------------------------------------------------------- */ + +#define IF_RTSFLAGS(c,s) if (RtsFlags.c) { s; } doNothing() + +#if defined(DEBUG) +#if IN_STG_CODE +#define IF_DEBUG(c,s) if (RtsFlags[0].DebugFlags.c) { s; } doNothing() +#else +#define IF_DEBUG(c,s) if (RtsFlags.DebugFlags.c) { s; } doNothing() +#endif +#else +#define IF_DEBUG(c,s) doNothing() +#endif + +#if defined(DEBUG) +#define DEBUG_ONLY(s) s +#else +#define DEBUG_ONLY(s) doNothing() +#endif + +#if defined(DEBUG) +#define DEBUG_IS_ON 1 +#else +#define DEBUG_IS_ON 0 +#endif + +/* ----------------------------------------------------------------------------- + Useful macros and inline functions + -------------------------------------------------------------------------- */ + +#if defined(__GNUC__) +#define SUPPORTS_TYPEOF +#endif + +#if defined(SUPPORTS_TYPEOF) +#define stg_min(a,b) ({typeof(a) _a = (a), _b = (b); _a <= _b ? _a : _b; }) +#define stg_max(a,b) ({typeof(a) _a = (a), _b = (b); _a <= _b ? _b : _a; }) +#else +#define stg_min(a,b) ((a) <= (b) ? (a) : (b)) +#define stg_max(a,b) ((a) <= (b) ? (b) : (a)) +#endif + +/* -------------------------------------------------------------------------- */ + +#if defined(__cplusplus) +} +#endif diff --git a/includes/RtsAPI.h b/includes/RtsAPI.h new file mode 100644 --- /dev/null +++ b/includes/RtsAPI.h @@ -0,0 +1,487 @@ +/* ---------------------------------------------------------------------------- + * + * (c) The GHC Team, 1998-2004 + * + * API for invoking Haskell functions via the RTS + * + * To understand the structure of the RTS headers, see the wiki: + * https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes + * + * --------------------------------------------------------------------------*/ + +#pragma once + +#if defined(__cplusplus) +extern "C" { +#endif + +#include "HsFFI.h" +#include "rts/Time.h" +#include "rts/EventLogWriter.h" + +/* + * Running the scheduler + */ +typedef enum { + NoStatus, /* not finished yet */ + Success, /* completed successfully */ + Killed, /* uncaught exception */ + Interrupted, /* stopped in response to a call to interruptStgRts */ + HeapExhausted /* out of memory */ +} SchedulerStatus; + +typedef struct StgClosure_ *HaskellObj; + +/* + * An abstract type representing the token returned by rts_lock() and + * used when allocating objects and threads in the RTS. + */ +typedef struct Capability_ Capability; + +/* + * The public view of a Capability: we can be sure it starts with + * these two components (but it may have more private fields). + */ +typedef struct CapabilityPublic_ { + StgFunTable f; + StgRegTable r; +} CapabilityPublic; + +/* ---------------------------------------------------------------------------- + RTS configuration settings, for passing to hs_init_ghc() + ------------------------------------------------------------------------- */ + +typedef enum { + RtsOptsNone, // +RTS causes an error + RtsOptsIgnore, // Ignore command line arguments + RtsOptsIgnoreAll, // Ignore command line and Environment arguments + RtsOptsSafeOnly, // safe RTS options allowed; others cause an error + RtsOptsAll // all RTS options allowed + } RtsOptsEnabledEnum; + +struct GCDetails_; + +// The RtsConfig struct is passed (by value) to hs_init_ghc(). The +// reason for using a struct is extensibility: we can add more +// fields to this later without breaking existing client code. +typedef struct { + + // Whether to interpret +RTS options on the command line + RtsOptsEnabledEnum rts_opts_enabled; + + // Whether to give RTS flag suggestions + HsBool rts_opts_suggestions; + + // additional RTS options + const char *rts_opts; + + // True if GHC was not passed -no-hs-main + HsBool rts_hs_main; + + // Whether to retain CAFs (default: false) + HsBool keep_cafs; + + // Writer a for eventlog. + const EventLogWriter *eventlog_writer; + + // Called before processing command-line flags, so that default + // settings for RtsFlags can be provided. + void (* defaultsHook) (void); + + // Called just before exiting + void (* onExitHook) (void); + + // Called on a stack overflow, before exiting + void (* stackOverflowHook) (W_ stack_size); + + // Called on heap overflow, before exiting + void (* outOfHeapHook) (W_ request_size, W_ heap_size); + + // Called when malloc() fails, before exiting + void (* mallocFailHook) (W_ request_size /* in bytes */, const char *msg); + + // Called for every GC + void (* gcDoneHook) (const struct GCDetails_ *stats); + + // Called when GC sync takes too long (+RTS --long-gc-sync=