Commit a7ecdf96 authored by simonpj's avatar simonpj

[project @ 2005-07-19 16:44:50 by simonpj]

WARNING: this is a big commit.  You might want 
	to wait a few days before updating, in case I've 
	broken something.

	However, if any of the changes are what you wanted,
	please check it out and test!

This commit does three main things:

1. A re-organisation of the way that GHC handles bindings in HsSyn.
   This has been a bit of a mess for quite a while.  The key new
   types are

	-- Bindings for a let or where clause
	data HsLocalBinds id
	  = HsValBinds (HsValBinds id)
	  | HsIPBinds  (HsIPBinds id)
	  | EmptyLocalBinds

	-- Value bindings (not implicit parameters)
	data HsValBinds id
	  = ValBindsIn  -- Before typechecking
		(LHsBinds id) [LSig id]	-- Not dependency analysed
					-- Recursive by default

	  | ValBindsOut	-- After typechecking
		[(RecFlag, LHsBinds id)]-- Dependency analysed

2. Implement Mark Jones's idea of increasing polymoprhism
   by using type signatures to cut the strongly-connected components
   of a recursive group.  As a consequence, GHC no longer insists
   on the contexts of the type signatures of a recursive group
   being identical.

   This drove a significant change: the renamer no longer does dependency
   analysis.  Instead, it attaches a free-variable set to each binding,
   so that the type checker can do the dep anal.  Reason: the typechecker
   needs to do *two* analyses:
	one to find the true mutually-recursive groups
		(which we need so we can build the right CoreSyn)
	one to find the groups in which to typecheck, taking
		account of type signatures

3. Implement non-ground SPECIALISE pragmas, as promised, and as
   requested by Remi and Ross.  Certainly, this should fix the 
   current problem with GHC, namely that if you have
	g :: Eq a => a -> b -> b
   then you can now specialise thus
	SPECIALISE g :: Int -> b -> b
    (This didn't use to work.)

   However, it goes further than that.  For example:
	f :: (Eq a, Ix b) => a -> b -> b
   then you can make a partial specialisation
	SPECIALISE f :: (Eq a) => a -> Int -> Int

    In principle, you can specialise f to *any* type that is
    "less polymorphic" (in the sense of subsumption) than f's 
    actual type.  Such as
	SPECIALISE f :: Eq a => [a] -> Int -> Int
    But I haven't tested that.

    I implemented this by doing the specialisation in the typechecker
    and desugarer, rather than leaving around the strange SpecPragmaIds,
    for the specialiser to find.  Indeed, SpecPragmaIds have vanished 
    altogether (hooray).

    Pragmas in general are handled more tidily.  There's a new
    data type HsBinds.Prag, which lives in an AbsBinds, and carries
    pragma info from the typechecker to the desugarer.


Smaller things

- The loop in the renamer goes via RnExpr, instead of RnSource.
  (That makes it more like the type checker.)

- I fixed the thing that was causing 'check_tc' warnings to be 
  emitted.
parent 8a9aba1f
......@@ -22,7 +22,7 @@ module BasicTypes(
Fixity(..), FixityDirection(..),
defaultFixity, maxPrecedence,
negateFixity,
negateFixity, funTyFixity,
compareFixity,
IPName(..), ipNameName, mapIPName,
......@@ -155,11 +155,10 @@ instance Outputable FixityDirection where
maxPrecedence = (9::Int)
defaultFixity = Fixity maxPrecedence InfixL
negateFixity :: Fixity
negateFixity = Fixity negatePrecedence InfixL -- Precedence of unary negate is wired in as infixl 6!
negatePrecedence :: Int
negatePrecedence = 6
negateFixity, funTyFixity :: Fixity
-- Wired-in fixities
negateFixity = Fixity 6 InfixL -- Fixity of unary negate
funTyFixity = Fixity 0 InfixR -- Fixity of '->'
\end{code}
Consider
......
......@@ -8,7 +8,7 @@ module Id (
Id, DictId,
-- Simple construction
mkGlobalId, mkLocalId, mkSpecPragmaId, mkLocalIdWithInfo,
mkGlobalId, mkLocalId, mkLocalIdWithInfo,
mkSysLocal, mkSysLocalUnencoded, mkUserLocal, mkVanillaGlobal,
mkTemplateLocals, mkTemplateLocalsNum, mkWildId, mkTemplateLocal,
mkWorkerId, mkExportedLocalId,
......@@ -24,8 +24,8 @@ module Id (
zapLamIdInfo, zapDemandIdInfo,
-- Predicates
isImplicitId, isDeadBinder,
isSpecPragmaId, isExportedId, isLocalId, isGlobalId,
isImplicitId, isDeadBinder, isDictId,
isExportedId, isLocalId, isGlobalId,
isRecordSelector,
isClassOpId_maybe,
isPrimOpId, isPrimOpId_maybe,
......@@ -83,7 +83,7 @@ module Id (
import CoreSyn ( Unfolding, CoreRule )
import BasicTypes ( Arity )
import Var ( Id, DictId,
isId, isExportedId, isSpecPragmaId, isLocalId,
isId, isExportedId, isLocalId,
idName, idType, idUnique, idInfo, isGlobalId,
setIdName, setIdType, setIdUnique,
setIdExported, setIdNotExported,
......@@ -91,10 +91,11 @@ import Var ( Id, DictId,
maybeModifyIdInfo,
globalIdDetails
)
import qualified Var ( mkLocalId, mkGlobalId, mkSpecPragmaId, mkExportedLocalId )
import qualified Var ( mkLocalId, mkGlobalId, mkExportedLocalId )
import TyCon ( FieldLabel, TyCon )
import Type ( Type, typePrimRep, addFreeTyVars, seqType,
splitTyConApp_maybe, PrimRep )
import TcType ( isDictTy )
import TysPrim ( statePrimTyCon )
import IdInfo
......@@ -147,9 +148,6 @@ where it can easily be found.
mkLocalIdWithInfo :: Name -> Type -> IdInfo -> Id
mkLocalIdWithInfo name ty info = Var.mkLocalId name (addFreeTyVars ty) info
mkSpecPragmaId :: Name -> Type -> Id
mkSpecPragmaId name ty = Var.mkSpecPragmaId name (addFreeTyVars ty) vanillaIdInfo
mkExportedLocalId :: Name -> Type -> Id
mkExportedLocalId name ty = Var.mkExportedLocalId name (addFreeTyVars ty) vanillaIdInfo
......@@ -229,17 +227,6 @@ idPrimRep id = typePrimRep (idType id)
%* *
%************************************************************************
The @SpecPragmaId@ exists only to make Ids that are
on the *LHS* of bindings created by SPECIALISE pragmas;
eg: s = f Int d
The SpecPragmaId is never itself mentioned; it
exists solely so that the specialiser will find
the call to f, and make specialised version of it.
The SpecPragmaId binding is discarded by the specialiser
when it gathers up overloaded calls.
Meanwhile, it is not discarded as dead code.
\begin{code}
recordSelectorFieldLabel :: Id -> (TyCon, FieldLabel)
recordSelectorFieldLabel id = case globalIdDetails id of
......@@ -278,6 +265,9 @@ isDataConWorkId_maybe id = case globalIdDetails id of
DataConWorkId con -> Just con
other -> Nothing
isDictId :: Id -> Bool
isDictId id = isDictTy (idType id)
idDataCon :: Id -> DataCon
-- Get from either the worker or the wrapper to the DataCon
-- Currently used only in the desugarer
......
......@@ -442,6 +442,9 @@ type InlinePragInfo = Activation
--
-- If there was an INLINE pragma, then as a separate matter, the
-- RHS will have been made to look small with a CoreSyn Inline Note
-- The default InlinePragInfo is AlwaysActive, so the info serves
-- entirely as a way to inhibit inlining until we want it
\end{code}
......
......@@ -7,7 +7,7 @@
module NameEnv (
NameEnv, mkNameEnv,
emptyNameEnv, unitNameEnv, nameEnvElts,
extendNameEnv_C, extendNameEnvList_C, extendNameEnv, extendNameEnvList,
extendNameEnv_C, extendNameEnv_Acc, extendNameEnv, extendNameEnvList,
foldNameEnv, filterNameEnv,
plusNameEnv, plusNameEnv_C,
lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, delListFromNameEnv,
......@@ -34,7 +34,7 @@ emptyNameEnv :: NameEnv a
mkNameEnv :: [(Name,a)] -> NameEnv a
nameEnvElts :: NameEnv a -> [a]
extendNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a
extendNameEnvList_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
......@@ -54,7 +54,7 @@ foldNameEnv = foldUFM
mkNameEnv = listToUFM
nameEnvElts = eltsUFM
extendNameEnv_C = addToUFM_C
extendNameEnvList_C = addListToUFM_C
extendNameEnv_Acc = addToUFM_Acc
extendNameEnv = addToUFM
plusNameEnv = plusUFM
plusNameEnv_C = plusUFM_C
......
......@@ -19,15 +19,14 @@ module Var (
Id, DictId,
idName, idType, idUnique, idInfo, modifyIdInfo, maybeModifyIdInfo,
setIdName, setIdUnique, setIdType, setIdInfo, lazySetIdInfo,
setIdExported, setIdNotExported, zapSpecPragmaId,
setIdExported, setIdNotExported,
globalIdDetails, globaliseId,
mkLocalId, mkExportedLocalId, mkSpecPragmaId,
mkGlobalId,
mkLocalId, mkExportedLocalId, mkGlobalId,
isTyVar, isTcTyVar, isId, isLocalVar, isLocalId,
isGlobalId, isExportedId, isSpecPragmaId,
isGlobalId, isExportedId,
mustHaveLocalBinding
) where
......@@ -91,9 +90,7 @@ data Var
data LocalIdDetails
= NotExported -- Not exported
| Exported -- Exported
| SpecPragma -- Not exported, but not to be discarded either
-- It's unclean that this is so deeply built in
-- Exported and SpecPragma Ids are kept alive;
-- Exported Ids are kept alive;
-- NotExported things may be discarded as dead code.
\end{code}
......@@ -225,11 +222,6 @@ setIdNotExported :: Id -> Id
-- We can only do this to LocalIds
setIdNotExported id = ASSERT( isLocalId id ) id { lclDetails = NotExported }
zapSpecPragmaId :: Id -> Id
zapSpecPragmaId id
| isSpecPragmaId id = id {lclDetails = NotExported}
| otherwise = id
globaliseId :: GlobalIdDetails -> Id -> Id
-- If it's a local, make it global
globaliseId details id = GlobalId { varName = varName id,
......@@ -287,16 +279,13 @@ mkLocalId name ty info = mk_local_id name ty NotExported info
mkExportedLocalId :: Name -> Type -> IdInfo -> Id
mkExportedLocalId name ty info = mk_local_id name ty Exported info
mkSpecPragmaId :: Name -> Type -> IdInfo -> Id
mkSpecPragmaId name ty info = mk_local_id name ty SpecPragma info
\end{code}
\begin{code}
isTyVar, isTcTyVar :: Var -> Bool
isId, isLocalVar, isLocalId :: Var -> Bool
isGlobalId, isExportedId, isSpecPragmaId :: Var -> Bool
mustHaveLocalBinding :: Var -> Bool
isTyVar, isTcTyVar :: Var -> Bool
isId, isLocalVar, isLocalId :: Var -> Bool
isGlobalId, isExportedId :: Var -> Bool
mustHaveLocalBinding :: Var -> Bool
isTyVar (TyVar {}) = True
isTyVar (TcTyVar {}) = True
......@@ -333,12 +322,8 @@ isExportedId (GlobalId {}) = True
isExportedId (LocalId {lclDetails = details})
= case details of
Exported -> True
SpecPragma -> True
other -> False
isExportedId other = False
isSpecPragmaId (LocalId {lclDetails = SpecPragma}) = True
isSpecPragmaId other = False
\end{code}
\begin{code}
......
......@@ -37,7 +37,7 @@ import StaticFlags ( opt_UF_CreationThreshold, opt_UF_UseThreshold,
import DynFlags ( DynFlags, DynFlag(..), dopt )
import CoreSyn
import PprCore ( pprCoreExpr )
import OccurAnal ( occurAnalyseGlobalExpr )
import OccurAnal ( occurAnalyseExpr )
import CoreUtils ( exprIsValue, exprIsCheap, exprIsTrivial )
import Id ( Id, idType, isId,
idUnfolding, globalIdDetails
......@@ -69,7 +69,7 @@ import GLAEXTS ( Int# )
mkTopUnfolding expr = mkUnfolding True {- Top level -} expr
mkUnfolding top_lvl expr
= CoreUnfolding (occurAnalyseGlobalExpr expr)
= CoreUnfolding (occurAnalyseExpr expr)
top_lvl
(exprIsValue expr)
......@@ -89,7 +89,7 @@ mkUnfolding top_lvl expr
-- it gets fixed up next round
mkCompulsoryUnfolding expr -- Used for things that absolutely must be unfolded
= CompulsoryUnfolding (occurAnalyseGlobalExpr expr)
= CompulsoryUnfolding (occurAnalyseExpr expr)
\end{code}
......
......@@ -22,7 +22,7 @@ import Var ( Var )
import Id ( Id, idType, isDataConWorkId_maybe, idLBVarInfo, idArity,
idInfo, idInlinePragma, idOccInfo,
globalIdDetails, isGlobalId, isExportedId,
isSpecPragmaId, idNewDemandInfo
idNewDemandInfo
)
import Var ( TyVar, isTyVar, tyVarKind )
import IdInfo ( IdInfo, megaSeqIdInfo,
......@@ -317,7 +317,6 @@ pprIdBndr id = ppr id <+>
pprIdDetails :: Id -> SDoc
pprIdDetails id | isGlobalId id = ppr (globalIdDetails id)
| isExportedId id = ptext SLIT("[Exported]")
| isSpecPragmaId id = ptext SLIT("[SpecPrag]")
| otherwise = empty
ppIdInfo :: Id -> IdInfo -> SDoc
......
......@@ -13,27 +13,24 @@ import StaticFlags ( opt_SccProfilingOn )
import DriverPhases ( isHsBoot )
import HscTypes ( ModGuts(..), HscEnv(..),
Dependencies(..), TypeEnv, IsBootInterface )
import HsSyn ( RuleDecl(..), RuleBndr(..), HsExpr(..), LHsExpr,
HsBindGroup(..), LRuleDecl, HsBind(..) )
import HsSyn ( RuleDecl(..), RuleBndr(..), LHsExpr, LRuleDecl )
import TcRnTypes ( TcGblEnv(..), ImportAvails(..) )
import MkIface ( mkUsageInfo )
import Id ( Id, setIdExported, idName )
import Name ( Name, isExternalName, nameIsLocalOrFrom, nameOccName )
import CoreSyn
import PprCore ( pprRules, pprCoreExpr )
import CoreSubst ( substExpr, mkSubst )
import DsMonad
import DsExpr ( dsLExpr )
import DsBinds ( dsHsBinds, AutoScc(..) )
import DsBinds ( dsTopLHsBinds, decomposeRuleLhs, AutoScc(..) )
import DsForeign ( dsForeigns )
import DsExpr () -- Forces DsExpr to be compiled; DsBinds only
-- depends on DsExpr.hi-boot.
import Module ( Module, moduleEnvElts, delModuleEnv, moduleFS )
import RdrName ( GlobalRdrEnv )
import NameSet
import VarEnv
import VarSet
import Bag ( Bag, isEmptyBag, emptyBag, bagToList )
import Bag ( Bag, isEmptyBag, emptyBag )
import Rules ( roughTopNames )
import CoreLint ( showPass, endPass )
import CoreFVs ( ruleRhsFreeVars, exprsFreeNames )
......@@ -43,8 +40,9 @@ import ErrUtils ( doIfSet, dumpIfSet_dyn, pprBagOfWarnings,
import ListSetOps ( insertList )
import Outputable
import UniqSupply ( mkSplitUniqSupply )
import SrcLoc ( Located(..), unLoc )
import SrcLoc ( Located(..) )
import DATA_IOREF ( readIORef )
import Maybes ( catMaybes )
import FastString
import Util ( sortLe )
\end{code}
......@@ -82,14 +80,12 @@ deSugar hsc_env
-- Desugar the program
; ((all_prs, ds_rules, ds_fords), warns)
<- initDs hsc_env mod rdr_env type_env $ do
{ core_prs <- dsHsBinds auto_scc binds []
{ core_prs <- dsTopLHsBinds auto_scc binds
; (ds_fords, foreign_prs) <- dsForeigns fords
; let all_prs = foreign_prs ++ core_prs
local_bndrs = mkVarSet (map fst all_prs)
; ds_rules <- mappM (dsRule mod local_bndrs) rules
; return (all_prs, ds_rules, ds_fords) }
; return (all_prs, catMaybes ds_rules, ds_fords) }
-- If warnings are considered errors, leave.
; if errorsFound dflags (warns, emptyBag)
......@@ -263,49 +259,37 @@ ppr_ds_rules rules
%************************************************************************
\begin{code}
dsRule :: Module -> IdSet -> LRuleDecl Id -> DsM CoreRule
dsRule :: Module -> IdSet -> LRuleDecl Id -> DsM (Maybe CoreRule)
dsRule mod in_scope (L loc (HsRule name act vars lhs rhs))
= putSrcSpanDs loc $
do { let (dict_binds, body)
= case unLoc lhs of
(HsLet [HsBindGroup dbs _ _] body) -> (dbs, body)
other -> (emptyBag, lhs)
ds_dict_bind (L _ (VarBind id rhs))
= do { rhs' <- dsLExpr rhs ; returnDs (id,rhs') }
; dict_binds' <- mappM ds_dict_bind (bagToList dict_binds)
; body' <- dsLExpr body
; rhs' <- dsLExpr rhs
do { let bndrs = [var | RuleBndr (L _ var) <- vars]
; lhs' <- dsLExpr lhs
; rhs' <- dsLExpr rhs
; case decomposeRuleLhs bndrs lhs' of {
Nothing -> do { dsWarn msg; return Nothing } ;
Just (bndrs', fn_id, args) -> do
-- Substitute the dict bindings eagerly,
-- and take the body apart into a (f args) form
; let bndrs = [var | RuleBndr (L _ var) <- vars]
in_scope' = mkInScopeSet (extendVarSetList in_scope bndrs)
subst = mkSubst in_scope' emptyVarEnv (mkVarEnv id_pairs)
id_pairs = [(id, substExpr subst rhs) | (id,rhs) <- dict_binds']
-- Note recursion here... substitution won't terminate
-- if there is genuine recursion... which there isn't
body'' = substExpr subst body'
(fn, args) = case collectArgs body'' of
(Var fn_id, args) -> (idName fn_id, args)
other -> pprPanic "dsRule" (ppr lhs)
local_rule = nameIsLocalOrFrom mod fn
{ let local_rule = nameIsLocalOrFrom mod fn_name
-- NB we can't use isLocalId in the orphan test,
-- because isLocalId isn't true of class methods
lhs_names = fn : nameSetToList (exprsFreeNames args)
fn_name = idName fn_id
lhs_names = fn_name : nameSetToList (exprsFreeNames args)
-- No need to delete bndrs, because
-- exprsFreeNams finds only External names
-- exprsFreeNames finds only External names
orph = case filter (nameIsLocalOrFrom mod) lhs_names of
(n:ns) -> Just (nameOccName n)
[] -> Nothing
; return (Rule { ru_name = name, ru_fn = fn, ru_act = act,
ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs',
ru_rough = roughTopNames args,
ru_local = local_rule, ru_orph = orph })
}
rule = Rule { ru_name = name, ru_fn = fn_name, ru_act = act,
ru_bndrs = bndrs', ru_args = args, ru_rhs = rhs',
ru_rough = roughTopNames args,
ru_local = local_rule, ru_orph = orph }
; return (Just rule)
} } }
where
msg = hang (ptext SLIT("RULE left-hand side too complicated to desugar; ignored"))
2 (ppr lhs)
\end{code}
......@@ -24,7 +24,7 @@ import TcHsSyn ( hsPatType )
-- So WATCH OUT; check each use of split*Ty functions.
-- Sigh. This is a pain.
import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLet )
import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLocalBinds )
import TcType ( Type, tcSplitAppTy, mkFunTy )
import Type ( mkTyConApp, funArgTy )
......@@ -555,14 +555,14 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp (MatchGroup matches match_
dsCmd ids local_vars env_ids stack res_ty (HsLet binds body)
= let
defined_vars = mkVarSet (map unLoc (collectGroupBinders binds))
defined_vars = mkVarSet (map unLoc (collectLocalBinders binds))
local_vars' = local_vars `unionVarSet` defined_vars
in
dsfixCmd ids local_vars' stack res_ty body
`thenDs` \ (core_body, free_vars, env_ids') ->
mappM newSysLocalDs stack `thenDs` \ stack_ids ->
-- build a new environment, plus the stack, using the let bindings
dsLet binds (buildEnvStack env_ids' stack_ids)
dsLocalBinds binds (buildEnvStack env_ids' stack_ids)
`thenDs` \ core_binds ->
-- match the old environment and stack against the input
matchEnvStack env_ids stack_ids core_binds
......@@ -798,7 +798,7 @@ dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd _ _)
dsCmdStmt ids local_vars env_ids out_ids (LetStmt binds)
-- build a new environment using the let bindings
= dsLet binds (mkTupleExpr out_ids) `thenDs` \ core_binds ->
= dsLocalBinds binds (mkTupleExpr out_ids) `thenDs` \ core_binds ->
-- match the old environment against the input
matchEnvStack env_ids [] core_binds `thenDs` \ core_map ->
returnDs (do_arr ids
......@@ -1009,7 +1009,7 @@ leavesMatch (L _ (Match pats _ (GRHSs grhss binds)))
= let
defined_vars = mkVarSet (collectPatsBinders pats)
`unionVarSet`
mkVarSet (map unLoc (collectGroupBinders binds))
mkVarSet (map unLoc (collectLocalBinders binds))
in
[(expr,
mkVarSet (map unLoc (collectLStmtsBinders stmts))
......
This diff is collapsed.
......@@ -2,4 +2,5 @@ module DsExpr where
dsExpr :: HsExpr.HsExpr Var.Id -> DsMonad.DsM CoreSyn.CoreExpr
dsLExpr :: HsExpr.LHsExpr Var.Id -> DsMonad.DsM CoreSyn.CoreExpr
dsLet :: [HsBinds.HsBindGroup Var.Id] -> CoreSyn.CoreExpr -> DsMonad.DsM CoreSyn.CoreExpr
dsLocalBinds :: HsBinds.HsLocalBinds Var.Id -> CoreSyn.CoreExpr -> DsMonad.DsM CoreSyn.CoreExpr
dsValBinds :: HsBinds.HsValBinds Var.Id -> CoreSyn.CoreExpr -> DsMonad.DsM CoreSyn.CoreExpr
......@@ -4,14 +4,14 @@
\section[DsExpr]{Matching expressions (Exprs)}
\begin{code}
module DsExpr ( dsExpr, dsLExpr, dsLet, dsLit ) where
module DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsValBinds, dsLit ) where
#include "HsVersions.h"
import Match ( matchWrapper, matchSimply, matchSinglePat )
import MatchLit ( dsLit, dsOverLit )
import DsBinds ( dsHsNestedBinds )
import DsBinds ( dsLHsBinds )
import DsGRHSs ( dsGuarded )
import DsListComp ( dsListComp, dsPArrComp )
import DsUtils ( mkErrorAppDs, mkStringExpr, mkConsExpr, mkNilExpr,
......@@ -76,24 +76,34 @@ This must be transformed to a case expression and, if the type has
more than one constructor, may fail.
\begin{code}
dsLet :: [HsBindGroup Id] -> CoreExpr -> DsM CoreExpr
dsLet groups body = foldlDs dsBindGroup body (reverse groups)
dsBindGroup :: CoreExpr -> HsBindGroup Id -> DsM CoreExpr
dsBindGroup body (HsIPBinds binds)
= foldlDs dsIPBind body binds
dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr
dsLocalBinds EmptyLocalBinds body = return body
dsLocalBinds (HsValBinds binds) body = dsValBinds binds body
dsLocalBinds (HsIPBinds binds) body = dsIPBinds binds body
-------------------------
dsValBinds :: HsValBinds Id -> CoreExpr -> DsM CoreExpr
dsValBinds (ValBindsOut binds) body = foldrDs ds_val_bind body binds
-------------------------
dsIPBinds (IPBinds ip_binds dict_binds) body
= do { prs <- dsLHsBinds dict_binds
; let inner = foldr (\(x,r) e -> Let (NonRec x r) e) body prs
; foldrDs ds_ip_bind inner ip_binds }
where
dsIPBind body (L _ (IPBind n e))
= dsLExpr e `thenDs` \ e' ->
returnDs (Let (NonRec (ipNameName n) e') body)
ds_ip_bind (L _ (IPBind n e)) body
= dsLExpr e `thenDs` \ e' ->
returnDs (Let (NonRec (ipNameName n) e') body)
-------------------------
ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr
-- Special case for bindings which bind unlifted variables
-- We need to do a case right away, rather than building
-- a tuple and doing selections.
-- Silently ignore INLINE pragmas...
dsBindGroup body bind@(HsBindGroup hsbinds sigs is_rec)
| [L _ (AbsBinds [] [] exports inlines binds)] <- bagToList hsbinds,
or [isUnLiftedType (idType g) | (_, g, l) <- exports]
-- Silently ignore INLINE and SPECIALISE pragmas...
ds_val_bind (is_rec, hsbinds) body
| [L _ (AbsBinds [] [] exports binds)] <- bagToList hsbinds,
or [isUnLiftedType (idType g) | (_, g, _, _) <- exports]
= ASSERT (case is_rec of {NonRecursive -> True; other -> False})
-- Unlifted bindings are always non-recursive
-- and are always a Fun or Pat monobind
......@@ -102,32 +112,32 @@ dsBindGroup body bind@(HsBindGroup hsbinds sigs is_rec)
-- could be dict binds in the 'binds'. (See the notes
-- below. Then pattern-match would fail. Urk.)
let
body_w_exports = foldr bind_export body exports
bind_export (tvs, g, l) body = ASSERT( null tvs )
bindNonRec g (Var l) body
body_w_exports = foldr bind_export body exports
bind_export (tvs, g, l, _) body = ASSERT( null tvs )
bindNonRec g (Var l) body
mk_error_app pat = mkErrorAppDs iRREFUT_PAT_ERROR_ID
(exprType body)
(showSDoc (ppr pat))
in
case bagToList binds of
[L loc (FunBind (L _ fun) _ matches)]
[L loc (FunBind (L _ fun) _ matches _)]
-> putSrcSpanDs loc $
matchWrapper (FunRhs (idName fun)) matches `thenDs` \ (args, rhs) ->
ASSERT( null args ) -- Functions aren't lifted
returnDs (bindNonRec fun rhs body_w_exports)
[L loc (PatBind pat grhss ty)]
[L loc (PatBind pat grhss ty _)]
-> putSrcSpanDs loc $
dsGuarded grhss ty `thenDs` \ rhs ->
mk_error_app pat `thenDs` \ error_expr ->
matchSimply rhs PatBindRhs pat body_w_exports error_expr
other -> pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)
other -> pprPanic "dsLet: unlifted" (pprLHsBinds hsbinds $$ ppr body)
-- Ordinary case for bindings
dsBindGroup body (HsBindGroup binds sigs is_rec)
= dsHsNestedBinds binds `thenDs` \ prs ->
ds_val_bind (is_rec, binds) body
= dsLHsBinds binds `thenDs` \ prs ->
returnDs (Let (Rec prs) body)
-- Use a Rec regardless of is_rec.
-- Why? Because it allows the binds to be all
......@@ -263,7 +273,7 @@ dsExpr (HsCase discrim matches)
dsExpr (HsLet binds body)
= dsLExpr body `thenDs` \ body' ->
dsLet binds body'
dsLocalBinds binds body'
-- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
-- because the interpretation of `stmts' depends on what sort of thing it is.
......@@ -589,7 +599,7 @@ dsDo stmts body result_ty
go (LetStmt binds : stmts)
= do { rest <- go stmts
; dsLet binds rest }
; dsLocalBinds binds rest }
go (BindStmt pat rhs bind_op fail_op : stmts)
= do { body <- go stmts
......@@ -644,7 +654,7 @@ dsMDo tbl stmts body result_ty
go (LetStmt binds : stmts)
= do { rest <- go stmts
; dsLet binds rest }
; dsLocalBinds binds rest }
go (ExprStmt rhs _ rhs_ty : stmts)
= do { rhs2 <- dsLExpr rhs
......@@ -670,7 +680,7 @@ dsMDo tbl stmts body result_ty
go (new_bind_stmt : let_stmt : stmts)
where
new_bind_stmt = mkBindStmt (mk_tup_pat later_pats) mfix_app
let_stmt = LetStmt [HsBindGroup binds [] Recursive]
let_stmt = LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)]))
-- Remove the later_ids that appear (without fancy coercions)
......
\begin{code}
module DsExpr where
import HsSyn ( HsExpr, LHsExpr, HsBindGroup )
import HsSyn ( HsExpr, LHsExpr, HsLocalBinds )
import Var ( Id )
import DsMonad ( DsM )
import CoreSyn ( CoreExpr )
dsExpr :: HsExpr Id -> DsM CoreExpr
dsLExpr :: LHsExpr Id -> DsM CoreExpr
dsLet :: [HsBindGroup Id] -> CoreExpr -> DsM CoreExpr
dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr
\end{code}
......@@ -80,11 +80,13 @@ dsForeigns []
dsForeigns fos
= foldlDs combine (ForeignStubs empty empty [] [], []) fos
where
combine (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f)
(L loc (ForeignImport id _ spec depr))
combine stubs (L loc decl) = putSrcSpanDs loc (combine1 stubs decl)
combine1 (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f)
(ForeignImport id _ spec depr)
= traceIf (text "fi start" <+> ppr id) `thenDs` \ _ ->
dsFImport (unLoc id) spec `thenDs` \ (bs, h, c, mbhd) ->
warnDepr depr loc `thenDs` \ _ ->
warnDepr depr `thenDs` \ _ ->
traceIf (text "fi end" <+> ppr id) `thenDs` \ _ ->
returnDs (ForeignStubs (h $$ acc_h)
(c $$ acc_c)
......@@ -92,11 +94,11 @@ dsForeigns fos
acc_feb,
bs ++ acc_f)
combine (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f)
(L loc (ForeignExport (L _ id) _ (CExport (CExportStatic ext_nm cconv)) depr))
combine1 (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f)
(ForeignExport (L _ id) _ (CExport (CExportStatic ext_nm cconv)) depr)
= dsFExport id (idType id)
ext_nm cconv False `thenDs` \(h, c, _, _) ->
warnDepr depr loc `thenDs` \_ ->
warnDepr depr `thenDs` \_ ->
returnDs (ForeignStubs (h $$ acc_h) (c $$ acc_c) acc_hdrs (id:acc_feb),
acc_f)
......@@ -105,8 +107,8 @@ dsForeigns fos
| e `elem` ls = ls
| otherwise = e:ls
warnDepr False _ = returnDs ()
warnDepr True loc = dsWarn (loc, msg)
warnDepr False = returnDs ()
warnDepr True = dsWarn msg
where
msg = ptext SLIT("foreign declaration uses deprecated non-standard syntax")
\end{code}
......
......@@ -8,7 +8,7 @@ module DsGRHSs ( dsGuarded, dsGRHSs ) where
#include "HsVersions.h"
import {-# SOURCE #-} DsExpr ( dsLExpr, dsLet )
import {-# SOURCE #-} DsExpr ( dsLExpr, dsLocalBinds )
import {-# SOURCE #-} Match ( matchSinglePat )
import HsSyn ( Stmt(..), HsExpr(..), GRHSs(..), GRHS(..),
......@@ -59,7 +59,7 @@ dsGRHSs hs_ctx pats (GRHSs grhss binds) rhs_ty
= mappM (dsGRHS hs_ctx pats rhs_ty) grhss `thenDs` \ match_results ->
let
match_result1 = foldr1 combineMatchResults match_results
match_result2 = adjustMatchResultDs (dsLet binds) match_result1
match_result2 = adjustMatchResultDs (dsLocalBinds binds) match_result1
-- NB: nested dsLet inside matchResult
in
returnDs match_result2
......@@ -105,7 +105,7 @@ matchGuards (ExprStmt expr _ _ : stmts) ctx rhs rhs_ty
matchGuards (LetStmt binds : stmts) ctx rhs rhs_ty
= matchGuards stmts ctx rhs rhs_ty `thenDs` \ match_result ->
returnDs (adjustMatchResultDs (dsLet binds) match_result)
returnDs (adjustMatchResultDs (dsLocalBinds binds) match_result)
-- NB the dsLet occurs inside the match_result
-- Reason: dsLet takes the body expression as its argument
-- so we can't desugar the bindings without the
......
......@@ -8,7 +8,7 @@ module DsListComp ( dsListComp, dsPArrComp ) where
#include "HsVersions.h"
import {-# SOURCE #-} DsExpr ( dsLExpr, dsLet )
import {-# SOURCE #-} DsExpr ( dsLExpr, dsLocalBinds )
import BasicTypes ( Boxity(..) )
import HsSyn
......@@ -183,7 +183,7 @@ deListComp (ExprStmt guard _ _ : quals) body list -- rule B above
-- [e | let B, qs] = let B in [e | qs]
deListComp (LetStmt binds : quals) body list
= deListComp quals body list `thenDs` \ core_rest ->
dsLet binds core_rest
dsLocalBinds binds core_rest
deListComp (BindStmt pat list1 _ _ : quals) body core_list2 -- rule A' above
= dsLExpr list1 `thenDs` \ core_list1 ->
......@@ -307,7 +307,7 @@ dfListComp c_id n_id (ExprStmt guard _ _ : quals) body
dfListComp c_id n_id (LetStmt binds : quals) body
-- new in 1.3, local bindings
= dfListComp c_id n_id quals body `thenDs` \ core_rest ->
dsLet binds core_rest
dsLocalBinds binds core_rest
dfListComp c_id n_id (BindStmt pat list1 _ _ : quals) body
-- evaluate the two lists
......@@ -420,11 +420,11 @@ dePArrComp (BindStmt p e _ _ : qs) body pa cea =
--
dePArrComp (LetStmt ds : qs) body pa cea =
dsLookupGlobalId mapPName `thenDs` \mapP ->
let xs = map unLoc (collectGroupBinders ds)
let xs = map unLoc (collectLocalBinders ds)
ty'cea = parrElemType cea
in
newSysLocalDs ty'cea `thenDs` \v ->
dsLet ds (mkCoreTup (map Var xs)) `thenDs` \clet ->
dsLocalBinds ds (mkCoreTup (map Var xs)) `thenDs` \clet ->
newSysLocalDs (exprType clet) `thenDs` \let'v ->
let projBody = mkDsLet (NonRec let'v clet) $
mkCoreTup [Var v, Var let'v]
......
......@@ -56,8 +56,7 @@ import BasicTypes ( isBoxed )
import Outputable
import Bag ( bagToList )
import FastString ( unpackFS )
import ForeignCall ( Safety(..), ForeignCall(..), CCallConv(..),
CCallTarget(..) )
import ForeignCall ( Safety(..), CCallConv(..), CCallTarget(..) )
import Monad ( zipWithM )
import List ( sortBy )
......@@ -112,12 +111,12 @@ repTopDs group
decls <- addBinds ss (do {
val_ds <- mapM rep_bind_group (hs_valds group) ;
val_ds <- rep_val_binds (hs_valds group) ;
tycl_ds <- mapM repTyClD (hs_tyclds group) ;
inst_ds <- mapM repInstD' (hs_instds group) ;
for_ds <- mapM repForD (hs_fords group) ;
-- more needed
return (de_loc $ sort_by_loc $ concat val_ds ++ catMaybes tycl_ds ++ inst_ds ++ for_ds) }) ;
return (de_loc $ sort_by_loc $ val_ds ++ catMaybes tycl_ds ++ inst_ds ++ for_ds) }) ;
decl_ty <- lookupType decQTyConName ;
let { core_list = coreList' decl_ty decls } ;
......@@ -132,7 +131,7 @@ repTopDs group
groupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
hs_fords = foreign_decls })
-- Collect the binders of a Group
= collectGroupBinders val_decls ++
= collectHsValBinders val_decls ++
[n | d <- tycl_decls, n <- tyClDeclNames (unLoc d)] ++
[n | L _ (ForeignImport n _ _ _) <- foreign_decls]
......@@ -205,16 +204,16 @@ repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,
cxt1 <- repLContext cxt ;
sigs1 <- rep_sigs sigs ;
binds1 <- rep_binds meth_binds ;
fds1 <- repLFunDeps fds;
fds1 <- repLFunDeps fds;
decls1 <- coreList decQTyConName (sigs1 ++ binds1) ;
bndrs1 <- coreList nameTyConName bndrs ;