...
 
Commits (8)
......@@ -56,6 +56,7 @@ import GHC.Data.Bitmap
import OrdList
import Maybes
import VarEnv
import PrelNames ( unsafeEqualityProofName )
import Data.List
import Foreign
......@@ -634,11 +635,12 @@ schemeE d s p exp@(AnnTick (Breakpoint _id _fvs) _rhs)
-- ignore other kinds of tick
schemeE d s p (AnnTick _ (_, rhs)) = schemeE d s p rhs
-- no alts: scrut is guaranteed to diverge
schemeE d s p (AnnCase (_,scrut) _ _ []) = schemeE d s p scrut
-- no alts: scrut is guaranteed to diverge
-- handle pairs with one void argument (e.g. state token)
schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)])
| isUnboxedTupleCon dc -- handles pairs with one void argument (e.g. state token)
| isUnboxedTupleCon dc
-- Convert
-- case .... of x { (# V'd-thing, a #) -> ... }
-- to
......@@ -655,11 +657,13 @@ schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)])
_ -> Nothing
= res
-- handle unit tuples
schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1], rhs)])
| isUnboxedTupleCon dc
, typePrimRep (idType bndr) `lengthAtMost` 1 -- handles unit tuples
, typePrimRep (idType bndr) `lengthAtMost` 1
= doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr)
-- handle nullary tuples
schemeE d s p (AnnCase scrut bndr _ alt@[(DEFAULT, [], _)])
| isUnboxedTupleType (idType bndr)
, Just ty <- case typePrimRep (idType bndr) of
......@@ -983,6 +987,7 @@ doCase
doCase d s p (_,scrut) bndr alts is_unboxed_tuple
| typePrimRep (idType bndr) `lengthExceeds` 1
= multiValException
| otherwise
= do
dflags <- getDynFlags
......@@ -1883,6 +1888,7 @@ bcView :: AnnExpr' Var ann -> Maybe (AnnExpr' Var ann)
-- b) type applications
-- c) casts
-- d) ticks (but not breakpoints)
-- e) case unsafeEqualityProof of UnsafeRefl -> e ==> e
-- Type lambdas *can* occur in random expressions,
-- whereas value lambdas cannot; that is why they are nuked here
bcView (AnnCast (_,e) _) = Just e
......@@ -1890,8 +1896,19 @@ bcView (AnnLam v (_,e)) | isTyVar v = Just e
bcView (AnnApp (_,e) (_, AnnType _)) = Just e
bcView (AnnTick Breakpoint{} _) = Nothing
bcView (AnnTick _other_tick (_,e)) = Just e
bcView (AnnCase (_,e) _ _ alts) -- Handle unsafe equality proof
| AnnVar id <- bcViewLoop e
, idName id == unsafeEqualityProofName
, [(_, _, (_, rhs))] <- alts
= Just rhs
bcView _ = Nothing
bcViewLoop :: AnnExpr' Var ann -> AnnExpr' Var ann
bcViewLoop e =
case bcView e of
Nothing -> e
Just e' -> bcViewLoop e'
isVAtom :: AnnExpr' Var ann -> Bool
isVAtom e | Just e' <- bcView e = isVAtom e'
isVAtom (AnnVar v) = isVoidArg (bcIdArgRep v)
......
......@@ -301,7 +301,6 @@ toIfaceCoercionX fr co
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
......
......@@ -46,6 +46,7 @@ import ForeignCall
import Demand ( isUsedOnce )
import PrimOp ( PrimCall(..), primOpWrapperId )
import SrcLoc ( mkGeneralSrcSpan )
import PrelNames ( unsafeEqualityProofName )
import Data.List.NonEmpty (nonEmpty, toList)
import Data.Maybe (fromMaybe)
......@@ -404,11 +405,23 @@ coreToStgExpr (Case scrut _ _ [])
-- runtime system error function.
coreToStgExpr (Case scrut bndr _ alts) = do
coreToStgExpr e0@(Case scrut bndr _ alts) = do
alts2 <- extendVarEnvCts [(bndr, LambdaBound)] (mapM vars_alt alts)
scrut2 <- coreToStgExpr scrut
return (StgCase scrut2 bndr (mkStgAltType bndr alts) alts2)
let stg = StgCase scrut2 bndr (mkStgAltType bndr alts) alts2
-- See (U2) in Note [Implementing unsafeCoerce] in base:Unsafe.Coerce
case scrut2 of
StgApp id [] | idName id == unsafeEqualityProofName ->
case alts2 of
[(_, [_co], rhs)] ->
return rhs
_ ->
pprPanic "coreToStgExpr" $
text "Unexpected unsafe equality case expression:" $$ ppr e0 $$
text "STG:" $$ ppr stg
_ -> return stg
where
vars_alt :: (AltCon, [Var], CoreExpr) -> CtsM (AltCon, [Var], StgExpr)
vars_alt (con, binders, rhs)
| DataAlt c <- con, c == unboxedUnitDataCon
= -- This case is a bit smelly.
......
This diff is collapsed.
......@@ -574,7 +574,7 @@ let-binding. When abs_sig = True
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
These properties are exploited in GHC.HsToCore.Binds.dsAbsBinds to
generate code without a let-binding.
Note [ABExport wrapper]
......
......@@ -210,10 +210,10 @@ information from an `HsGroup`.
One might wonder why we even bother separating top-level fixity signatures
into two places at all. That is, why not just take the fixity signatures
from `hs_tyclds` and put them into `hs_fixds` so that they are all in one
location? This ends up causing problems for `DsMeta.repTopDs`, which translates
each fixity signature in `hs_fixds` and `hs_tyclds` into a Template Haskell
`Dec`. If there are any duplicate signatures between the two fields, this will
result in an error (#17608).
location? This ends up causing problems for `GHC.HsToCore.Quote.repTopDs`,
which translates each fixity signature in `hs_fixds` and `hs_tyclds` into a
Template Haskell `Dec`. If there are any duplicate signatures between the two
fields, this will result in an error (#17608).
-}
-- | Haskell Group
......
......@@ -577,8 +577,8 @@ data RecordUpdTc = RecordUpdTc
-- | HsWrap appears only in typechecker output
-- Invariant: The contained Expr is *NOT* itself an HsWrap.
-- See Note [Detecting forced eta expansion] in DsExpr. This invariant
-- is maintained by GHC.Hs.Utils.mkHsWrap.
-- See Note [Detecting forced eta expansion] in GHC.HsToCore.Expr.
-- This invariant is maintained by GHC.Hs.Utils.mkHsWrap.
-- hs_syn is something like HsExpr or HsCmd
data HsWrap hs_syn = HsWrap HsWrapper -- the wrapper
(hs_syn GhcTc) -- the thing that is wrapped
......@@ -2693,7 +2693,7 @@ data HsMatchContext p
-- (Just b) | Just _ <- x = e
-- | otherwise = e'
| RecUpd -- ^Record update [used only in DsExpr to
| RecUpd -- ^Record update [used only in GHC.HsToCore.Expr to
-- tell matchWrapper what sort of
-- runtime error message to generate]
......
......@@ -199,7 +199,7 @@ found to have.
-}
-- Comparison operations are needed when grouping literals
-- for compiling pattern-matching (module MatchLit)
-- for compiling pattern-matching (module GHC.HsToCore.Match.Literal)
instance (Eq (XXOverLit p)) => Eq (HsOverLit p) where
(OverLit _ val1 _) == (OverLit _ val2 _) = val1 == val2
(XOverLit val1) == (XOverLit val2) = val1 == val2
......
......@@ -425,7 +425,7 @@ data HsRecField' id arg = HsRecField {
--
-- 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'.
-- unambiguous updates can be represented by 'GHC.HsToCore.Quote.repUpdFields'.
--
-- For example, suppose we have:
--
......
......@@ -759,7 +759,7 @@ mkLHsWrap :: HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc
mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e)
-- | Avoid @'HsWrap' co1 ('HsWrap' co2 _)@ and @'HsWrap' co1 ('HsPar' _ _)@
-- See Note [Detecting forced eta expansion] in "DsExpr"
-- See Note [Detecting forced eta expansion] in "GHC.HsToCore.Expr"
mkHsWrap :: HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap co_fn e | isIdHsWrapper co_fn = e
mkHsWrap co_fn (XExpr (HsWrap co_fn' e)) = mkHsWrap (co_fn <.> co_fn') e
......@@ -935,7 +935,7 @@ BUT we have a special case when abs_sig is true;
-- | 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.
-- information, see Note [Strict binds check] is GHC.HsToCore.Binds.
isUnliftedHsBind :: HsBind GhcTc -> Bool -- works only over typechecked binds
isUnliftedHsBind bind
| AbsBinds { abs_exports = exports, abs_sig = has_sig } <- bind
......@@ -1103,17 +1103,17 @@ collect_lpat p bndrs
go (XPat {}) = bndrs
{-
Note [Dictionary binders in ConPatOut] See also same Note in DsArrows
Note [Dictionary binders in ConPatOut] See also same Note in GHC.HsToCore.Arrows
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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
more in the desugarer; for example, GHC.HsToCore.Utils.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
Desugaring of arrow case expressions needs these bindings (see GHC.HsToCore.Arrows
and arrowcase1), but SPJ (Jan 2007) says it's safer for it to use its
own pat-binder-collector:
......@@ -1127,7 +1127,7 @@ 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.
So in mkSelectorBinds in GHC.HsToCore.Utils, we want just m,n as the variables bound.
-}
hsGroupBinders :: HsGroup GhcRn -> [Name]
......
......@@ -12,15 +12,15 @@ Desugaring arrow commands
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
module DsArrows ( dsProcExpr ) where
module GHC.HsToCore.Arrows ( dsProcExpr ) where
#include "HsVersions.h"
import GhcPrelude
import Match
import DsUtils
import DsMonad
import GHC.HsToCore.Match
import GHC.HsToCore.Utils
import GHC.HsToCore.Monad
import GHC.Hs hiding (collectPatBinders, collectPatsBinders,
collectLStmtsBinders, collectLStmtBinders,
......@@ -33,8 +33,8 @@ import qualified GHC.Hs.Utils as HsUtils
-- So WATCH OUT; check each use of split*Ty functions.
-- Sigh. This is a pain.
import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds,
dsSyntaxExpr )
import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds,
dsSyntaxExpr )
import TcType
import Type ( splitPiTy )
......@@ -43,7 +43,7 @@ import CoreSyn
import CoreFVs
import CoreUtils
import MkCore
import DsBinds (dsHsWrapper)
import GHC.HsToCore.Binds (dsHsWrapper)
import Id
import ConLike
......
......@@ -17,20 +17,22 @@ lower levels it is preserved with @let@/@letrec@s).
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,
dsHsWrapper, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds, dsMkUserRule
) where
module GHC.HsToCore.Binds
( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec
, dsHsWrapper, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds, dsMkUserRule
)
where
#include "HsVersions.h"
import GhcPrelude
import {-# SOURCE #-} DsExpr( dsLExpr )
import {-# SOURCE #-} Match( matchWrapper )
import {-# SOURCE #-} GHC.HsToCore.Expr ( dsLExpr )
import {-# SOURCE #-} GHC.HsToCore.Match ( matchWrapper )
import DsMonad
import DsGRHSs
import DsUtils
import GHC.HsToCore.Monad
import GHC.HsToCore.GuardedRHSs
import GHC.HsToCore.Utils
import GHC.HsToCore.PmCheck ( needToRunPmCheck, addTyCsDs, checkGuardMatches )
import GHC.Hs -- lots of things
......@@ -565,7 +567,7 @@ if there is no variable in the pattern desugaring looks like
in x `seq` body
In order to force the Ids in the binding group they are passed around
in the dsHsBind family of functions, and later seq'ed in DsExpr.ds_val_bind.
in the dsHsBind family of functions, and later seq'ed in GHC.HsToCore.Expr.ds_val_bind.
Consider a recursive group like this
......@@ -632,11 +634,11 @@ The restrictions are:
2. Unlifted binds must also be banged. (There is no trouble to compile an unbanged
unlifted bind, but an unbanged bind looks lazy, and we don't want users to be
surprised by the strictness of an unlifted bind.) Checked in first clause
of DsExpr.ds_val_bind.
of GHC.HsToCore.Expr.ds_val_bind.
3. Unlifted binds may not have polymorphism (#6078). (That is, no quantified type
variables or constraints.) Checked in first clause
of DsExpr.ds_val_bind.
of GHC.HsToCore.Expr.ds_val_bind.
4. Unlifted binds may not be recursive. Checked in second clause of ds_val_bind.
......
module DsBinds where
import DsMonad ( DsM )
import CoreSyn ( CoreExpr )
module GHC.HsToCore.Binds where
import GHC.HsToCore.Monad ( DsM )
import CoreSyn ( CoreExpr )
import TcEvidence (HsWrapper)
dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
......@@ -10,7 +10,7 @@
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
module Coverage (addTicksToBinds, hpcInitCode) where
module GHC.HsToCore.Coverage (addTicksToBinds, hpcInitCode) where
import GhcPrelude as Prelude
......
......@@ -6,7 +6,7 @@
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
module ExtractDocs (extractDocs) where
module GHC.HsToCore.Docs (extractDocs) where
import GhcPrelude
import Bag
......
......@@ -13,27 +13,30 @@ Desugaring expressions.
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
module DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds
, dsValBinds, dsLit, dsSyntaxExpr
, dsHandleMonadicFailure ) where
module GHC.HsToCore.Expr
( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds
, dsValBinds, dsLit, dsSyntaxExpr
, dsHandleMonadicFailure
)
where
#include "HsVersions.h"
import GhcPrelude
import Match
import MatchLit
import DsBinds
import DsGRHSs
import DsListComp
import DsUtils
import DsArrows
import DsMonad
import GHC.HsToCore.Match
import GHC.HsToCore.Match.Literal
import GHC.HsToCore.Binds
import GHC.HsToCore.GuardedRHSs
import GHC.HsToCore.ListComp
import GHC.HsToCore.Utils
import GHC.HsToCore.Arrows
import GHC.HsToCore.Monad
import GHC.HsToCore.PmCheck ( checkGuardMatches )
import Name
import NameEnv
import FamInstEnv( topNormaliseType )
import DsMeta
import GHC.HsToCore.Quote
import GHC.Hs
-- NB: The desugarer, which straddles the source and Core worlds, sometimes
......@@ -119,7 +122,7 @@ ds_val_bind (NonRecursive, hsbinds) body
-- below. Then pattern-match would fail. Urk.)
, isUnliftedHsBind bind
= putSrcSpanDs loc $
-- see Note [Strict binds checks] in DsBinds
-- see Note [Strict binds checks] in GHC.HsToCore.Binds
if is_polymorphic bind
then errDsCoreExpr (poly_bind_err bind)
-- data Ptr a = Ptr Addr#
......@@ -155,7 +158,7 @@ ds_val_bind (NonRecursive, hsbinds) body
text "Probable fix: add a type signature"
ds_val_bind (is_rec, binds) _body
| anyBag (isUnliftedHsBind . unLoc) binds -- see Note [Strict binds checks] in DsBinds
| anyBag (isUnliftedHsBind . unLoc) binds -- see Note [Strict binds checks] in GHC.HsToCore.Binds
= ASSERT( isRec is_rec )
errDsCoreExpr $
hang (text "Recursive bindings for unlifted types aren't allowed:")
......@@ -228,7 +231,7 @@ dsUnliftedBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)
{-
************************************************************************
* *
\subsection[DsExpr-vars-and-cons]{Variables, constructors, literals}
* Variables, constructors, literals *
* *
************************************************************************
-}
......@@ -247,7 +250,7 @@ dsLExpr (L loc e)
-- | Variant of 'dsLExpr' that ensures that the result is not levity
-- polymorphic. This should be used when the resulting expression will
-- be an argument to some other function.
-- See Note [Levity polymorphism checking] in DsMonad
-- See Note [Levity polymorphism checking] in GHC.HsToCore.Monad
-- See Note [Levity polymorphism invariants] in CoreSyn
dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr
dsLExprNoLP (L loc e)
......@@ -875,7 +878,7 @@ dsExplicitList elt_ty Nothing xs
-- Don't generate builds when the [] constructor will do
|| not (gopt Opt_EnableRewriteRules dflags) -- Rewrite rules off
-- Don't generate a build if there are no rules to eliminate it!
-- See Note [Desugaring RULE left hand sides] in Desugar
-- See Note [Desugaring RULE left hand sides] in GHC.HsToCore
then return $ mkListExpr elt_ty xs'
else mkBuildExpr elt_ty (mk_build_list xs') }
where
......@@ -910,7 +913,7 @@ dsArithSeq expr (FromThenTo from thn to)
{-
Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're
handled in DsListComp). Basically does the translation given in the
handled in GHC.HsToCore.ListComp). Basically does the translation given in the
Haskell 98 report:
-}
......
module DsExpr where
import GHC.Hs ( HsExpr, LHsExpr, LHsLocalBinds, LPat, SyntaxExpr )
import DsMonad ( DsM, MatchResult )
import CoreSyn ( CoreExpr )
import GHC.Hs.Extension ( GhcTc)
module GHC.HsToCore.Expr where
import GHC.Hs ( HsExpr, LHsExpr, LHsLocalBinds, LPat, SyntaxExpr )
import GHC.HsToCore.Monad ( DsM, MatchResult )
import CoreSyn ( CoreExpr )
import GHC.Hs.Extension ( GhcTc)
dsExpr :: HsExpr GhcTc -> DsM CoreExpr
dsLExpr, dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr
......
......@@ -9,13 +9,15 @@ Desugaring foreign calls
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module DsCCall
( dsCCall
, mkFCall
, unboxArg
, boxResult
, resultWrapper
) where
module GHC.HsToCore.Foreign.Call
( dsCCall
, mkFCall
, unboxArg
, boxResult
, resultWrapper
)
where
#include "HsVersions.h"
......@@ -24,13 +26,13 @@ import GhcPrelude
import CoreSyn
import DsMonad
import GHC.HsToCore.Monad
import CoreUtils
import MkCore
import MkId
import ForeignCall
import DataCon
import DsUtils
import GHC.HsToCore.Utils
import TcType
import Type
......
......@@ -3,7 +3,7 @@
(c) The AQUA Project, Glasgow University, 1998
Desugaring foreign declarations (see also DsCCall).
Desugaring foreign declarations (see also GHC.HsToCore.Foreign.Call).
-}
{-# LANGUAGE CPP #-}
......@@ -13,7 +13,7 @@ Desugaring foreign declarations (see also DsCCall).
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module DsForeign ( dsForeigns ) where
module GHC.HsToCore.Foreign.Decl ( dsForeigns ) where
#include "HsVersions.h"
import GhcPrelude
......@@ -22,8 +22,8 @@ import TcRnMonad -- temp
import CoreSyn
import DsCCall
import DsMonad
import GHC.HsToCore.Foreign.Call
import GHC.HsToCore.Monad
import GHC.Hs
import DataCon
......@@ -72,7 +72,7 @@ is the same as
f :: prim_args -> IO prim_res
f a1 ... an = _ccall_ nm cc a1 ... an
\end{verbatim}
so we reuse the desugaring code in @DsCCall@ to deal with these.
so we reuse the desugaring code in @GHC.HsToCore.Foreign.Call@ to deal with these.
-}
type Binding = (Id, CoreExpr) -- No rec/nonrec structure;
......@@ -739,7 +739,7 @@ typeTyCon ty
| Just (tc, _) <- tcSplitTyConApp_maybe (unwrapType ty)
= tc
| otherwise
= pprPanic "DsForeign.typeTyCon" (ppr ty)
= pprPanic "GHC.HsToCore.Foreign.Decl.typeTyCon" (ppr ty)
insertRetAddr :: DynFlags -> CCallConv
-> [(SDoc, SDoc, Type, CmmType)]
......@@ -793,7 +793,7 @@ getPrimTyOf ty
ASSERT(dataConSourceArity data_con == 1)
ASSERT2(isUnliftedType prim_ty, ppr prim_ty)
prim_ty
_other -> pprPanic "DsForeign.getPrimTyOf" (ppr ty)
_other -> pprPanic "GHC.HsToCore.Foreign.Decl.getPrimTyOf" (ppr ty)
where
rep_ty = unwrapType ty
......
......@@ -9,14 +9,14 @@ Matching guarded right-hand-sides (GRHSs)
{-# LANGUAGE CPP #-}
{-# LANGUAGE ViewPatterns #-}
module DsGRHSs ( dsGuarded, dsGRHSs, dsGRHS, isTrueLHsExpr ) where
module GHC.HsToCore.GuardedRHSs ( dsGuarded, dsGRHSs, dsGRHS, isTrueLHsExpr ) where
#include "HsVersions.h"
import GhcPrelude
import {-# SOURCE #-} DsExpr ( dsLExpr, dsLocalBinds )
import {-# SOURCE #-} Match ( matchSinglePatVar )
import {-# SOURCE #-} GHC.HsToCore.Expr ( dsLExpr, dsLocalBinds )
import {-# SOURCE #-} GHC.HsToCore.Match ( matchSinglePatVar )
import GHC.Hs
import MkCore
......@@ -26,8 +26,8 @@ import CoreUtils (bindNonRec)
import BasicTypes (Origin(FromSource))
import DynFlags
import GHC.HsToCore.PmCheck (needToRunPmCheck, addTyCsDs, addPatTmCs, addScrutTmCs)
import DsMonad
import DsUtils
import GHC.HsToCore.Monad
import GHC.HsToCore.Utils
import Type ( Type )
import Util
import SrcLoc
......
......@@ -10,28 +10,28 @@ Desugaring list comprehensions, monad comprehensions and array comprehensions
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
module DsListComp ( dsListComp, dsMonadComp ) where
module GHC.HsToCore.ListComp ( dsListComp, dsMonadComp ) where
#include "HsVersions.h"
import GhcPrelude
import {-# SOURCE #-} DsExpr ( dsHandleMonadicFailure, dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr )
import {-# SOURCE #-} GHC.HsToCore.Expr ( dsHandleMonadicFailure, dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr )
import GHC.Hs
import TcHsSyn
import CoreSyn
import MkCore
import DsMonad -- the monadery used in the desugarer
import DsUtils
import GHC.HsToCore.Monad -- the monadery used in the desugarer
import GHC.HsToCore.Utils
import DynFlags
import CoreUtils
import Id
import Type
import TysWiredIn
import Match
import GHC.HsToCore.Match
import PrelNames
import SrcLoc
import Outputable
......@@ -154,7 +154,7 @@ dsTransStmt _ = panic "dsTransStmt: Not given a TransStmt"
{-
************************************************************************
* *
\subsection[DsListComp-ordinary]{Ordinary desugaring of list comprehensions}
* Ordinary desugaring of list comprehensions *
* *
************************************************************************
......@@ -308,7 +308,7 @@ deBindComp pat core_list1 quals core_list2 = do
{-
************************************************************************
* *
\subsection[DsListComp-foldr-build]{Foldr/Build desugaring of list comprehensions}
* Foldr/Build desugaring of list comprehensions *
* *
************************************************************************
......
......@@ -15,14 +15,17 @@ The @match@ function
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
module Match ( match, matchEquations, matchWrapper, matchSimply
, matchSinglePat, matchSinglePatVar ) where
module GHC.HsToCore.Match
( match, matchEquations, matchWrapper, matchSimply
, matchSinglePat, matchSinglePatVar
)
where
#include "HsVersions.h"
import GhcPrelude
import {-#SOURCE#-} DsExpr (dsLExpr, dsSyntaxExpr)
import {-#SOURCE#-} GHC.HsToCore.Expr (dsLExpr, dsSyntaxExpr)
import BasicTypes ( Origin(..) )
import DynFlags
......@@ -35,16 +38,16 @@ import CoreSyn
import Literal
import CoreUtils
import MkCore
import DsMonad
import DsBinds
import DsGRHSs
import DsUtils
import GHC.HsToCore.Monad
import GHC.HsToCore.Binds
import GHC.HsToCore.GuardedRHSs
import GHC.HsToCore.Utils
import Id
import ConLike
import DataCon
import PatSyn
import MatchCon
import MatchLit
import GHC.HsToCore.Match.Constructor
import GHC.HsToCore.Match.Literal
import Type
import Coercion ( eqCoercion )
import TyCon( isNewTyCon )
......@@ -105,7 +108,7 @@ is an embryonic @CoreExpr@ with a ``hole'' at the end for the
final ``else expression''.
\end{itemize}
There is a data type, @EquationInfo@, defined in module @DsMonad@.
There is a data type, @EquationInfo@, defined in module @GHC.HsToCore.Monad@.
An experiment with re-ordering this information about equations (in
particular, having the patterns available in column-major order)
......@@ -162,7 +165,7 @@ sometimes use that Id in a local binding or as a case binder. So it
should not have an External name; Lint rejects non-top-level binders
with External names (#13043).
See also Note [Localise pattern binders] in DsUtils
See also Note [Localise pattern binders] in GHC.HsToCore.Utils
-}
type MatchId = Id -- See Note [Match Ids]
......@@ -717,7 +720,7 @@ matchWrapper
\begin{itemize}
\item @do@ patterns, but if the @do@ can fail
it creates another equation if the match can fail
(see @DsExpr.doDo@ function)
(see @GHC.HsToCore.Expr.doDo@ function)
\item @let@ patterns, are treated by @matchSimply@
List Comprension Patterns, are treated by @matchSimply@ also
\end{itemize}
......
module Match where
module GHC.HsToCore.Match where
import GhcPrelude
import Var ( Id )
import TcType ( Type )
import DsMonad ( DsM, EquationInfo, MatchResult )
import GHC.HsToCore.Monad ( DsM, EquationInfo, MatchResult )
import CoreSyn ( CoreExpr )
import GHC.Hs ( LPat, HsMatchContext, MatchGroup, LHsExpr )
import GHC.Hs.Extension ( GhcRn, GhcTc )
......
......@@ -12,21 +12,21 @@ Pattern-matching constructors
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module MatchCon ( matchConFamily, matchPatSyn ) where
module GHC.HsToCore.Match.Constructor ( matchConFamily, matchPatSyn ) where
#include "HsVersions.h"
import GhcPrelude
import {-# SOURCE #-} Match ( match )
import {-# SOURCE #-} GHC.HsToCore.Match ( match )
import GHC.Hs
import DsBinds
import GHC.HsToCore.Binds
import ConLike
import BasicTypes ( Origin(..) )
import TcType
import DsMonad
import DsUtils
import GHC.HsToCore.Monad
import GHC.HsToCore.Utils
import MkCore ( mkCoreLets )
import Util
import Id
......
......@@ -11,23 +11,25 @@ Pattern-matching literal patterns
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module MatchLit ( dsLit, dsOverLit, hsLitKey
, tidyLitPat, tidyNPat
, matchLiterals, matchNPlusKPats, matchNPats
, warnAboutIdentities
, warnAboutOverflowedOverLit, warnAboutOverflowedLit
, warnAboutEmptyEnumerations
) where
module GHC.HsToCore.Match.Literal
( dsLit, dsOverLit, hsLitKey
, tidyLitPat, tidyNPat
, matchLiterals, matchNPlusKPats, matchNPats
, warnAboutIdentities
, warnAboutOverflowedOverLit, warnAboutOverflowedLit
, warnAboutEmptyEnumerations
)
where
#include "HsVersions.h"
import GhcPrelude
import {-# SOURCE #-} Match ( match )
import {-# SOURCE #-} DsExpr ( dsExpr, dsSyntaxExpr )
import {-# SOURCE #-} GHC.HsToCore.Match ( match )
import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr, dsSyntaxExpr )
import DsMonad
import DsUtils
import GHC.HsToCore.Monad
import GHC.HsToCore.Utils
import GHC.Hs
......@@ -64,8 +66,8 @@ import Data.Proxy
************************************************************************
* *
Desugaring literals
[used to be in DsExpr, but DsMeta needs it,
and it's nice to avoid a loop]
[used to be in GHC.HsToCore.Expr, but GHC.HsToCore.Quote needs it,
and it's nice to avoid a loop]
* *
************************************************************************
......
......@@ -3,14 +3,14 @@
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
@DsMonad@: monadery used in desugaring
Monadery used in desugaring
-}
{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an orphan
{-# LANGUAGE ViewPatterns #-}
module DsMonad (
module GHC.HsToCore.Monad (
DsM, mapM, mapAndUnzipM,
initDs, initDsTc, initTcDsForSolver, initDsWithModGuts, fixDs,
foldlM, foldrM, whenGOptM, unsetGOptM, unsetWOptM, xoptM,
......@@ -108,7 +108,7 @@ data EquationInfo
-- ^ The patterns for an equation
--
-- NB: We have /already/ applied 'decideBangHood' to
-- these patterns. See Note [decideBangHood] in "DsUtils"
-- these patterns. See Note [decideBangHood] in GHC.HsToCore.Utils
, eqn_orig :: Origin
-- ^ Was this equation present in the user source?
......@@ -314,7 +314,7 @@ At one point, I (Richard) thought we could check in the zonker, but it's hard
to know where precisely are the abstracted variables and the arguments. So
we check in the desugarer, the only place where we can see the Core code and
still report respectable syntax to the user. This covers the vast majority
of cases; see calls to DsMonad.dsNoLevPoly and friends.
of cases; see calls to GHC.HsToCore.Monad.dsNoLevPoly and friends.
Levity polymorphism is also prohibited in the types of binders, and the
desugarer checks for this in GHC-generated Ids. (The zonker handles
......@@ -322,7 +322,7 @@ the user-writted ids in zonkIdBndr.) This is done in newSysLocalDsNoLP.
The newSysLocalDs variant is used in the vast majority of cases where
the binder is obviously not levity polymorphic, omitting the check.
It would be nice to ASSERT that there is no levity polymorphism here,
but we can't, because of the fixM in DsArrows. It's all OK, though:
but we can't, because of the fixM in GHC.HsToCore.Arrows. It's all OK, though:
Core Lint will catch an error here.
However, the desugarer is the wrong place for certain checks. In particular,
......@@ -357,7 +357,7 @@ newSysLocalDsNoLP = mk_local (fsLit "ds")
-- this variant should be used when the caller can be sure that the variable type
-- is not levity-polymorphic. It is necessary when the type is knot-tied because
-- of the fixM used in DsArrows. See Note [Levity polymorphism checking]
-- of the fixM used in GHC.HsToCore.Arrows. See Note [Levity polymorphism checking]
newSysLocalDs = mkSysLocalM (fsLit "ds")
newFailLocalDs = mkSysLocalM (fsLit "fail")
-- the fail variable is used only in a situation where we can tell that
......
......@@ -47,16 +47,16 @@ import Var (EvVar)
import Coercion
import TcEvidence
import TcType (evVarPred)
import {-# SOURCE #-} DsExpr (dsExpr, dsLExpr, dsSyntaxExpr)
import {-# SOURCE #-} DsBinds (dsHsWrapper)
import DsUtils (selectMatchVar)
import MatchLit (dsLit, dsOverLit)
import DsMonad
import {-# SOURCE #-} GHC.HsToCore.Expr (dsExpr, dsLExpr, dsSyntaxExpr)
import {-# SOURCE #-} GHC.HsToCore.Binds (dsHsWrapper)
import GHC.HsToCore.Utils (selectMatchVar)
import GHC.HsToCore.Match.Literal (dsLit, dsOverLit)
import GHC.HsToCore.Monad
import Bag
import OrdList
import TyCoRep
import Type
import DsUtils (isTrueLHsExpr)
import GHC.HsToCore.Utils (isTrueLHsExpr)
import Maybes
import qualified GHC.LanguageExtensions as LangExt
......@@ -482,7 +482,7 @@ translatePat fam_insts x pat = case pat of
translateConPatOut fam_insts x con arg_tys ex_tvs dicts ps
NPat ty (L _ olit) mb_neg _ -> do
-- See Note [Literal short cut] in MatchLit.hs
-- See Note [Literal short cut] in GHC.HsToCore.Match.Literal.hs
-- We inline the Literal short cut for @ty@ here, because @ty@ is more
-- precise than the field of OverLitTc, which is all that dsOverLit (which
-- normally does the literal short cut) can look at. Also @ty@ matches the
......@@ -982,8 +982,8 @@ checkGrdTree guards deltas = do
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When checking a match it would be great to have all type and term information
available so we can get more precise results. For this reason we have functions
`addDictsDs' and `addTmVarCsDs' in DsMonad that store in the environment type and
term constraints (respectively) as we go deeper.
`addDictsDs' and `addTmVarCsDs' in GHC.HsToCore.Monad that store in the
environment type and term constraints (respectively) as we go deeper.
The type constraints we propagate inwards are collected by `collectEvVarsPats'
in GHC.Hs.Pat. This handles bug #4139 ( see example
......
......@@ -66,7 +66,7 @@ import Unify (tcMatchTy)
import TcRnTypes (completeMatchConLikes)
import Coercion
import MonadUtils hiding (foldlM)
import DsMonad hiding (foldlM)
import GHC.HsToCore.Monad hiding (foldlM)
import FamInst
import FamInstEnv
......
......@@ -22,25 +22,25 @@
-- a Royal Pain (triggers other recompilation).
-----------------------------------------------------------------------------
module DsMeta( dsBracket ) where
module GHC.HsToCore.Quote( dsBracket ) where
#include "HsVersions.h"
import GhcPrelude
import {-# SOURCE #-} DsExpr ( dsExpr )
import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr )
import MatchLit
import DsMonad
import GHC.HsToCore.Match.Literal
import GHC.HsToCore.Monad
import qualified Language.Haskell.TH as TH
import GHC.Hs
import PrelNames
-- To avoid clashes with DsMeta.varName we must make a local alias for
-- OccName.varName we do this by removing varName from the import of
-- OccName above, making a qualified instance of OccName and using
-- OccNameAlias.varName where varName ws previously used in this file.
-- To avoid clashes with GHC.HsToCore.Quote.varName we must make a local alias
-- for OccName.varName. We do this by removing varName from the import of OccName
-- above, making a qualified instance of OccName and using OccNameAlias.varName
-- where varName ws previously used in this file.
import qualified OccName( isDataOcc, isVarOcc, isTcOcc )
import Module
......@@ -72,7 +72,7 @@ import Class
import HscTypes ( MonadThings )
import DataCon
import Var
import DsBinds
import GHC.HsToCore.Binds
import GHC.TypeLits
import Data.Kind (Constraint)
......@@ -2105,7 +2105,7 @@ globalVar name
mk_varg | OccName.isDataOcc name_occ = mkNameG_dName
| OccName.isVarOcc name_occ = mkNameG_vName
| OccName.isTcOcc name_occ = mkNameG_tcName
| otherwise = pprPanic "DsMeta.globalVar" (ppr name)
| otherwise = pprPanic "GHC.HsToCore.Quote.globalVar" (ppr name)
lookupType :: Name -- Name of type constructor (e.g. (M TH.Exp))
-> MetaM Type -- The type
......
......@@ -4,7 +4,7 @@
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module DsUsage (
module GHC.HsToCore.Usage (
-- * Dependency/fingerprinting code (used by GHC.Iface.Utils)
mkUsageInfo, mkUsedNames, mkDependencies
) where
......
......@@ -14,7 +14,7 @@ This module exports some utility functions of no great interest.
{-# LANGUAGE ViewPatterns #-}
-- | Utility functions for constructing Core syntax, principally for desugaring
module DsUtils (
module GHC.HsToCore.Utils (
EquationInfo(..),
firstPat, shiftEqns,
......@@ -46,14 +46,14 @@ module DsUtils (
import GhcPrelude
import {-# SOURCE #-} Match ( matchSimply )
import {-# SOURCE #-} DsExpr ( dsLExpr )
import {-# SOURCE #-} GHC.HsToCore.Match ( matchSimply )
import {-# SOURCE #-} GHC.HsToCore.Expr ( dsLExpr )
import GHC.Hs
import TcHsSyn
import TcType( tcSplitTyConApp )
import CoreSyn
import DsMonad
import GHC.HsToCore.Monad
import CoreUtils
import MkCore
......@@ -172,7 +172,7 @@ In fact, even CoreSubst.simplOptExpr will do this, and simpleOptExpr
runs on the output of the desugarer, so all is well by the end of
the desugaring pass.
See also Note [MatchIds] in Match.hs
See also Note [MatchIds] in GHC.HsToCore.Match
************************************************************************
* *
......@@ -668,7 +668,7 @@ mkSelectorBinds :: [[Tickish Id]] -- ^ ticks to add, possibly
-> CoreExpr -- ^ Expression to which the pattern is bound
-> DsM (Id,[(Id,CoreExpr)])
-- ^ Id the rhs is bound to, for desugaring strict
-- binds (see Note [Desugar Strict binds] in DsBinds)
-- binds (see Note [Desugar Strict binds] in GHC.HsToCore.Binds)
-- and all the desugared binds
mkSelectorBinds ticks pat val_expr
......@@ -923,10 +923,10 @@ and
This adjustment is done by decideBangHood,
* Just before constructing an EqnInfo, in Match
* Just before constructing an EqnInfo, in GHC.HsToCore.Match
(matchWrapper and matchSinglePat)
* When desugaring a pattern-binding in DsBinds.dsHsBind
* When desugaring a pattern-binding in GHC.HsToCore.Binds.dsHsBind
Note that it is /not/ done recursively. See the -XStrict
spec in the user manual.
......
......@@ -25,7 +25,7 @@ import BooleanFormula
import Class ( FunDep )
import CoreUtils ( exprType )
import ConLike ( conLikeName )
import Desugar ( deSugarExpr )
import GHC.HsToCore ( deSugarExpr )
import FieldLabel
import GHC.Hs
import HscTypes
......
......@@ -360,7 +360,9 @@ data IfaceUnfolding
-- Possibly could eliminate the Bool here, the information
-- is also in the InlinePragma.
| IfCompulsory IfaceExpr -- Only used for default methods, in fact
| IfCompulsory IfaceExpr -- default methods and unsafeCoerce#
-- for more about unsafeCoerce#, see
-- Note [Wiring in unsafeCoerce#] in Desugar
| IfInlineRule Arity -- INLINE pragmas
Bool -- OK to inline even if *un*-saturated
......@@ -1618,7 +1620,6 @@ freeNamesIfCoercion (IfaceAxiomRuleCo _ax cos)
= fnList freeNamesIfCoercion cos
freeNamesIfProv :: IfaceUnivCoProv -> NameSet
freeNamesIfProv IfaceUnsafeCoerceProv = emptyNameSet
freeNamesIfProv (IfacePhantomProv co) = freeNamesIfCoercion co
freeNamesIfProv (IfaceProofIrrelProv co) = freeNamesIfCoercion co
freeNamesIfProv (IfacePluginProv _) = emptyNameSet
......
......@@ -454,8 +454,15 @@ trimId :: Id -> Id
trimId id
| not (isImplicitId id)
= id `setIdInfo` vanillaIdInfo
`setIdUnfolding` unfolding
| otherwise
= id
where
unfolding
| isCompulsoryUnfolding (idUnfolding id)
= idUnfolding id
| otherwise
= noUnfolding
{- Note [Drop wired-in things]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -1195,8 +1202,11 @@ tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold
--------- Unfolding ------------
unf_info = unfoldingInfo idinfo
unfold_info | show_unfold = tidyUnfolding rhs_tidy_env unf_info unf_from_rhs
| otherwise = minimal_unfold_info
unfold_info
| isCompulsoryUnfolding unf_info || show_unfold
= tidyUnfolding rhs_tidy_env unf_info unf_from_rhs
| otherwise
= minimal_unfold_info
minimal_unfold_info = zapUnfolding unf_info
unf_from_rhs = mkTopUnfolding dflags is_bot tidy_rhs
is_bot = isBottomingSig final_sig
......
......@@ -237,6 +237,12 @@ data IfaceTyConSort = IfaceNormalTyCon -- ^ a regular tycon
-- only: see Note [Equality predicates in IfaceType]
deriving (Eq)
instance Outputable IfaceTyConSort where
ppr IfaceNormalTyCon = text "normal"
ppr (IfaceTupleTyCon n sort) = ppr sort <> colon <> ppr n
ppr (IfaceSumTyCon n) = text "sum:" <> ppr n
ppr IfaceEqualityTyCon = text "equality"
{- Note [Free tyvars in IfaceType]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Nowadays (since Nov 16, 2016) we pretty-print a Type by converting to
......@@ -350,8 +356,7 @@ data IfaceCoercion
| IfaceHoleCo CoVar -- ^ See Note [Holes in IfaceCoercion]
data IfaceUnivCoProv
= IfaceUnsafeCoerceProv
| IfacePhantomProv IfaceCoercion
= IfacePhantomProv IfaceCoercion
| IfaceProofIrrelProv IfaceCoercion
| IfacePluginProv String
......@@ -525,7 +530,6 @@ substIfaceType env ty
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
......@@ -1559,11 +1563,6 @@ 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
......@@ -1607,8 +1606,6 @@ ppr_role r = underscore <> pp_role
------------------
pprIfaceUnivCoProv :: IfaceUnivCoProv -> SDoc
pprIfaceUnivCoProv IfaceUnsafeCoerceProv
= text "unsafe"
pprIfaceUnivCoProv (IfacePhantomProv co)
= text "phantom" <+> pprParendIfaceCoercion co
pprIfaceUnivCoProv (IfaceProofIrrelProv co)
......@@ -1620,6 +1617,11 @@ pprIfaceUnivCoProv (IfacePluginProv s)
instance Outputable IfaceTyCon where
ppr tc = pprPromotionQuote tc <> ppr (ifaceTyConName tc)
instance Outputable IfaceTyConInfo where
ppr (IfaceTyConInfo { ifaceTyConIsPromoted = prom
, ifaceTyConSort = sort })
= angleBrackets $ ppr prom <> comma <+> ppr sort
pprPromotionQuote :: IfaceTyCon -> SDoc
pprPromotionQuote tc =
pprPromotionQuoteI $ ifaceTyConIsPromoted $ ifaceTyConInfo tc
......@@ -1951,26 +1953,24 @@ instance Binary IfaceCoercion where
_ -> panic ("get IfaceCoercion " ++ show tag)
instance Binary IfaceUnivCoProv where
put_ bh IfaceUnsafeCoerceProv = putByte bh 1
put_ bh (IfacePhantomProv a) = do
putByte bh 2
putByte bh 1
put_ bh a
put_ bh (IfaceProofIrrelProv a) = do
putByte bh 3
putByte bh 2
put_ bh a
put_ bh (IfacePluginProv a) = do
putByte bh 4
putByte bh 3
put_ bh a
get bh = do
tag <- getByte bh
case tag of
1 -> return $ IfaceUnsafeCoerceProv
2 -> do a <- get bh
1 -> do a <- get bh
return $ IfacePhantomProv a
3 -> do a <- get bh
2 -> do a <- get bh
return $ IfaceProofIrrelProv a
4 -> do a <- get bh
3 -> do a <- get bh
return $ IfacePluginProv a
_ -> panic ("get IfaceUnivCoProv " ++ show tag)
......
......@@ -68,7 +68,7 @@ import GHC.Iface.Load
import GHC.CoreToIface
import FlagChecker
import DsUsage ( mkUsageInfo, mkUsedNames, mkDependencies )
import GHC.HsToCore.Usage ( mkUsageInfo, mkUsedNames, mkDependencies )
import Id
import Annotations
import CoreSyn
......@@ -109,7 +109,7 @@ import Fingerprint
import Exception
import UniqSet
import Packages
import ExtractDocs
import GHC.HsToCore.Docs
import Control.Monad
import Data.Function
......
......@@ -1249,7 +1249,6 @@ tcIfaceCo = go
go_var = tcIfaceLclId
tcIfaceUnivCoProv :: IfaceUnivCoProv -> IfL UnivCoProvenance
tcIfaceUnivCoProv IfaceUnsafeCoerceProv = return UnsafeCoerceProv
tcIfaceUnivCoProv (IfacePhantomProv kco) = PhantomProv <$> tcIfaceCo kco
tcIfaceUnivCoProv (IfaceProofIrrelProv kco) = ProofIrrelProv <$> tcIfaceCo kco
tcIfaceUnivCoProv (IfacePluginProv str) = return $ PluginProv str
......@@ -1465,12 +1464,23 @@ tcIdInfo ignore_prags toplvl name ty info = do
-- we start; default assumption is that it has CAFs
let init_info | if_boot lcl_env = vanillaIdInfo `setUnfoldingInfo` BootUnfolding
| otherwise = vanillaIdInfo
if ignore_prags
then return init_info
else case info of
NoInfo -> return init_info
HasInfo info -> foldlM tcPrag init_info info
case info of
NoInfo -> return init_info
HasInfo info -> let needed = needed_prags info in
foldlM tcPrag init_info needed
where
needed_prags :: [IfaceInfoItem] -> [IfaceInfoItem]
needed_prags items
| not ignore_prags = items
| otherwise = filter need_prag items
need_prag :: IfaceInfoItem -> Bool
-- compulsory unfoldings are really compulsory.
-- See wrinkle in Note [Wiring in unsafeCoerce#] in Desugar
need_prag (HsUnfold _ (IfCompulsory {})) = True
need_prag _ = False
tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo
tcPrag info HsNoCafRefs = return (info `setCafInfo` NoCafRefs)
tcPrag info (HsArity arity) = return (info `setArityInfo` arity)
......@@ -1493,7 +1503,7 @@ tcJoinInfo IfaceNotJoinPoint = Nothing
tcUnfolding :: TopLevelFlag -> Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding
tcUnfolding toplvl name _ info (IfCoreUnfold stable if_expr)
= do { dflags <- getDynFlags
; mb_expr <- tcPragExpr toplvl name if_expr
; mb_expr <- tcPragExpr False toplvl name if_expr
; let unf_src | stable = InlineStable
| otherwise = InlineRhs
; return $ case mb_expr of
......@@ -1507,13 +1517,13 @@ tcUnfolding toplvl name _ info (IfCoreUnfold stable if_expr)
-- Strictness should occur before unfolding!
strict_sig = strictnessInfo info
tcUnfolding toplvl name _ _ (IfCompulsory if_expr)
= do { mb_expr <- tcPragExpr toplvl name if_expr
= do { mb_expr <- tcPragExpr True toplvl name if_expr
; return (case mb_expr of
Nothing -> NoUnfolding
Just expr -> mkCompulsoryUnfolding expr) }
tcUnfolding toplvl name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr)
= do { mb_expr <- tcPragExpr toplvl name if_expr
= do { mb_expr <- tcPragExpr False toplvl name if_expr
; return (case mb_expr of
Nothing -> NoUnfolding
Just expr -> mkCoreUnfolding InlineStable True expr guidance )}
......@@ -1535,17 +1545,20 @@ For unfoldings we try to do the job lazily, so that we never type check
an unfolding that isn't going to be looked at.
-}
tcPragExpr :: TopLevelFlag -> Name -> IfaceExpr -> IfL (Maybe CoreExpr)
tcPragExpr toplvl name expr
tcPragExpr :: Bool -- Is this unfolding compulsory?
-- See Note [Checking for levity polymorphism] in CoreLint
-> TopLevelFlag -> Name -> IfaceExpr -> IfL (Maybe CoreExpr)
tcPragExpr is_compulsory toplvl name expr
= forkM_maybe doc $ do
core_expr' <- tcIfaceExpr expr
-- Check for type consistency in the unfolding
-- See Note [Linting Unfoldings from Interfaces]
when (isTopLevel toplvl) $ whenGOptM Opt_DoCoreLinting $ do
when (isTopLevel toplvl) $
whenGOptM Opt_DoCoreLinting $ do
in_scope <- get_in_scope
dflags <- getDynFlags
case lintUnfolding dflags noSrcLoc in_scope core_expr' of
case lintUnfolding is_compulsory dflags noSrcLoc in_scope core_expr' of
Nothing -> return ()
Just fail_msg -> do { mod <- getIfModule
; pprPanic "Iface Lint failure"
......@@ -1555,7 +1568,8 @@ tcPragExpr toplvl name expr
, text "Iface expr =" <+> ppr expr ]) }
return core_expr'
where
doc = text "Unfolding of" <+> ppr name
doc = ppWhen is_compulsory (text "Compulsory") <+>
text "Unfolding of" <+> ppr name
get_in_scope :: IfL VarSet -- Totally disgusting; but just for linting
get_in_scope
......@@ -1686,7 +1700,7 @@ tcIfaceTyCon (IfaceTyCon name info)
= do { thing <- tcIfaceGlobal name
; return $ case ifaceTyConIsPromoted info of
NotPromoted -> tyThingTyCon thing
IsPromoted -> promoteDataCon $ tyThingDataCon thing }
IsPromoted -> promoteDataCon $ tyThingDataCon thing }
tcIfaceCoAxiom :: Name -> IfL (CoAxiom Branched)
tcIfaceCoAxiom name = do { thing <- tcIfaceImplicit name
......
......@@ -704,7 +704,7 @@ postProcessStmtsForApplicativeDo ctxt stmts
; let is_do_expr | DoExpr <- ctxt = True
| otherwise = False
-- don't apply the transformation inside TH brackets, because
-- DsMeta does not handle ApplicativeDo.
-- GHC.HsToCore.Quote does not handle ApplicativeDo.
; in_th_bracket <- isBrackStage <$> getStage
; if ado_is_on && is_do_expr && not in_th_bracket
then do { traceRn "ppsfa" (ppr stmts)
......@@ -984,7 +984,7 @@ lookupStmtNamePoly ctxt name
-- | Is this a context where we respect RebindableSyntax?
-- but ListComp are never rebindable
-- Neither is ArrowExpr, which has its own desugarer in DsArrows
-- Neither is ArrowExpr, which has its own desugarer in GHC.HsToCore.Arrows
rebindableContext :: HsStmtContext GhcRn -> Bool
rebindableContext ctxt = case ctxt of
ListComp -> False
......@@ -1511,7 +1511,7 @@ ApplicativeDo touches a few phases in the compiler:
* Desugarer: Any do-block which contains applicative statements is desugared
as outlined above, to use the Applicative combinators.
Relevant module: DsExpr
Relevant module: GHC.HsToCore.Expr
-}
......
......@@ -105,9 +105,9 @@ import Data.Map (Map)
import qualified Data.Map as Map
import StringBuffer (stringToStringBuffer)
import Control.Monad
import GHC.Exts
import Data.Array
import Exception
import Unsafe.Coerce ( unsafeCoerce )
import TcRnDriver ( runTcInteractive, tcRnType, loadUnqualIfaces )
import TcHsSyn ( ZonkFlexi (SkolemiseFlexi) )
......@@ -1225,7 +1225,7 @@ dynCompileExpr expr = do
to_dyn_expr = mkHsApp (L loc . HsVar noExtField . L loc $ getRdrName toDynName)
parsed_expr
hval <- compileParsedExpr to_dyn_expr
return (unsafeCoerce# hval :: Dynamic)
return (unsafeCoerce hval :: Dynamic)
-----------------------------------------------------------------------------
-- show a module and it's source/object filenames
......@@ -1254,7 +1254,7 @@ obtainTermFromVal hsc_env bound force ty x
= throwIO (InstallationError
"this operation requires -fno-external-interpreter")
| otherwise
= cvObtainTerm hsc_env bound force ty (unsafeCoerce# x)
= cvObtainTerm hsc_env bound force ty (unsafeCoerce x)
obtainTermFromId :: HscEnv -> Int -> Bool -> Id -> IO Term
obtainTermFromId hsc_env bound force id = do
......
......@@ -54,7 +54,7 @@ import Hooks
import Control.Monad ( when, unless )
import Data.Maybe ( mapMaybe )
import GHC.Exts ( unsafeCoerce# )
import Unsafe.Coerce ( unsafeCoerce )
-- | Loads the plugins specified in the pluginModNames field of the dynamic
-- flags. Should be called after command line arguments are parsed, but before
......@@ -222,7 +222,7 @@ lessUnsafeCoerce :: DynFlags -> String -> a -> IO b
lessUnsafeCoerce dflags context what = do
debugTraceMsg dflags 3 $ (text "Coercing a value in") <+> (text context) <>
(text "...")
output <- evaluate (unsafeCoerce# what)
output <- evaluate (unsafeCoerce what)
debugTraceMsg dflags 3 (text "Successfully evaluated coercion")
return output
......
......@@ -1594,8 +1594,9 @@ The hsSyn representation of parsed source explicitly contains all the original
parens, as written in the source.
When a Template Haskell (TH) splice is evaluated, the original splice is first
renamed and type checked and then finally converted to core in DsMeta. This core
is then run in the TH engine, and the result comes back as a TH AST.
renamed and type checked and then finally converted to core in
GHC.HsToCore.Quote. This core is then run in the TH engine, and the result
<