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))
......
......@@ -8,12 +8,12 @@ in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at
lower levels it is preserved with @let@/@letrec@s).
\begin{code}
module DsBinds ( dsHsBinds, dsHsNestedBinds, AutoScc(..) ) where
module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, AutoScc(..) ) where
#include "HsVersions.h"
import {-# SOURCE #-} DsExpr( dsLExpr )
import {-# SOURCE #-} DsExpr( dsLExpr, dsExpr )
import {-# SOURCE #-} Match( matchWrapper )
import DsMonad
......@@ -26,17 +26,23 @@ import CoreUtils ( exprType, mkInlineMe, mkSCC )
import StaticFlags ( opt_AutoSccsOnAllToplevs,
opt_AutoSccsOnExportedToplevs )
import OccurAnal ( occurAnalyseExpr )
import CostCentre ( mkAutoCC, IsCafCC(..) )
import Id ( idType, idName, isExportedId, isSpecPragmaId, Id )
import NameSet
import VarSet
import Id ( Id, idType, idName, isExportedId, mkLocalId, setInlinePragma )
import Rules ( addIdSpecialisations, mkLocalRule )
import Var ( Var, isGlobalId )
import VarEnv
import Type ( mkTyVarTy, substTyWith )
import TysWiredIn ( voidTy )
import Outputable
import SrcLoc ( Located(..) )
import Maybe ( isJust )
import Maybes ( isJust, catMaybes, orElse )
import Bag ( bagToList )
import BasicTypes ( Activation(..), isAlwaysActive )
import Monad ( foldM )
import FastString ( mkFastString )
import List ( (\\) )
import Util ( mapSnd )
\end{code}
%************************************************************************
......@@ -46,16 +52,17 @@ import Monad ( foldM )
%************************************************************************
\begin{code}
dsHsNestedBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)]
dsHsNestedBinds binds = dsHsBinds NoSccs binds []
dsTopLHsBinds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
dsTopLHsBinds auto_scc binds = ds_lhs_binds auto_scc binds
dsHsBinds :: AutoScc -- scc annotation policy (see below)
-> LHsBinds Id
-> [(Id,CoreExpr)] -- Put this on the end (avoid quadratic append)
-> DsM [(Id,CoreExpr)] -- Result
dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)]
dsLHsBinds binds = ds_lhs_binds NoSccs binds
dsHsBinds auto_scc binds rest
= foldM (dsLHsBind auto_scc) rest (bagToList binds)
------------------------
ds_lhs_binds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
-- scc annotation policy (see below)
ds_lhs_binds auto_scc binds = foldM (dsLHsBind auto_scc) [] (bagToList binds)
dsLHsBind :: AutoScc
-> [(Id,CoreExpr)] -- Put this on the end (avoid quadratic append)
......@@ -75,25 +82,14 @@ dsHsBind auto_scc rest (VarBind var expr)
-- Dictionary bindings are always VarMonoBinds, so
-- we only need do this here
addDictScc var core_expr `thenDs` \ core_expr' ->
returnDs ((var, core_expr') : rest)
let
-- Gross hack to prevent inlining into SpecPragmaId rhss
-- Consider fromIntegral = fromInteger . toInteger
-- spec1 = fromIntegral Int Float
-- Even though fromIntegral is small we don't want to inline
-- it inside spec1, so that we collect the specialised call
-- Solution: make spec1 an INLINE thing.
core_expr'' = mkInline (isSpecPragmaId var) core_expr'
in
returnDs ((var, core_expr'') : rest)
dsHsBind auto_scc rest (FunBind (L _ fun) _ matches)
dsHsBind auto_scc rest (FunBind (L _ fun) _ matches _)
= matchWrapper (FunRhs (idName fun)) matches `thenDs` \ (args, body) ->
addAutoScc auto_scc (fun, mkLams args body) `thenDs` \ pair ->
returnDs (pair : rest)
dsHsBind auto_scc rest (PatBind pat grhss ty)
dsHsBind auto_scc rest (PatBind pat grhss ty _)
= dsGuarded grhss ty `thenDs` \ body_expr ->
mkSelectorBinds pat body_expr `thenDs` \ sel_binds ->
mappM (addAutoScc auto_scc) sel_binds `thenDs` \ sel_binds ->
......@@ -103,67 +99,133 @@ dsHsBind auto_scc rest (PatBind pat grhss ty)
-- For the (rare) case when there are some mixed-up
-- dictionary bindings (for which a Rec is convenient)
-- we reply on the enclosing dsBind to wrap a Rec around.
dsHsBind auto_scc rest (AbsBinds [] [] exports inlines binds)
= dsHsBinds (addSccs auto_scc exports) binds []`thenDs` \ core_prs ->
dsHsBind auto_scc rest (AbsBinds [] [] exports binds)
= ds_lhs_binds (addSccs auto_scc exports) binds `thenDs` \ core_prs ->
let
core_prs' = addLocalInlines exports inlines core_prs
exports' = [(global, Var local) | (_, global, local) <- exports]
core_prs' = addLocalInlines exports core_prs
exports' = [(global, Var local) | (_, global, local, _) <- exports]
in
returnDs (core_prs' ++ exports' ++ rest)
-- Another common case: one exported variable
-- Non-recursive bindings come through this way
dsHsBind auto_scc rest
(AbsBinds all_tyvars dicts exps@[(tyvars, global, local)] inlines binds)
(AbsBinds all_tyvars dicts exports@[(tyvars, global, local, prags)] binds)
= ASSERT( all (`elem` tyvars) all_tyvars )
dsHsBinds (addSccs auto_scc exps) binds [] `thenDs` \ core_prs ->
ds_lhs_binds (addSccs auto_scc exports) binds `thenDs` \ core_prs ->
let
-- Always treat the binds as recursive, because the typechecker
-- makes rather mixed-up dictionary bindings
core_bind = Rec core_prs
-- The mkInline does directly what the
-- addLocalInlines do in the other cases
export' = (global, mkInline (idName global `elemNameSet` inlines) $
mkLams tyvars $ mkLams dicts $
Let core_bind (Var local))
inline_env = mkVarEnv [(global, prag) | prag <- prags, isInlinePrag prag]
in
returnDs (export' : rest)
mappM (dsSpec all_tyvars dicts tyvars global local core_bind)
prags `thenDs` \ mb_specs ->
let
(spec_binds, rules) = unzip (catMaybes mb_specs)
global' = addIdSpecialisations global rules
rhs' = mkLams tyvars $ mkLams dicts $ Let core_bind (Var local)
in
returnDs (addInlineInfo inline_env (global', rhs') : spec_binds ++ rest)
dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports inlines binds)
= dsHsBinds (addSccs auto_scc exports) binds []`thenDs` \ core_prs ->
let
dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
= ds_lhs_binds (addSccs auto_scc exports) binds `thenDs` \ core_prs ->
let
-- Rec because of mixed-up dictionary bindings
core_bind = Rec (addLocalInlines exports inlines core_prs)
core_bind = Rec (addLocalInlines exports core_prs)
tup_expr = mkTupleExpr locals
tup_ty = exprType tup_expr
poly_tup_expr = mkLams all_tyvars $ mkLams dicts $
Let core_bind tup_expr
locals = [local | (_, _, local) <- exports]
locals = [local | (_, _, local, _) <- exports]
local_tys = map idType locals
in
newSysLocalDs (exprType poly_tup_expr) `thenDs` \ poly_tup_id ->
let
dict_args = map Var dicts
mk_bind ((tyvars, global, local), n) -- locals !! n == local
mk_bind ((tyvars, global, local, prags), n) -- locals !! n == local
= -- Need to make fresh locals to bind in the selector, because
-- some of the tyvars will be bound to voidTy
newSysLocalsDs (map substitute local_tys) `thenDs` \ locals' ->
newSysLocalDs (substitute tup_ty) `thenDs` \ tup_id ->
returnDs (global, mkLams tyvars $ mkLams dicts $
mkTupleSelector locals' (locals' !! n) tup_id $
mkApps (mkTyApps (Var poly_tup_id) ty_args) dict_args)
mapM (dsSpec all_tyvars dicts tyvars global local core_bind)
prags `thenDs` \ mb_specs ->
let
(spec_binds, rules) = unzip (catMaybes mb_specs)
global' = addIdSpecialisations global rules
rhs = mkLams tyvars $ mkLams dicts $
mkTupleSelector locals' (locals' !! n) tup_id $
mkApps (mkTyApps (Var poly_tup_id) ty_args) dict_args
in
returnDs ((global', rhs) : spec_binds)
where
mk_ty_arg all_tyvar | all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
| otherwise = voidTy
ty_args = map mk_ty_arg all_tyvars
substitute = substTyWith all_tyvars ty_args
in
mappM mk_bind (exports `zip` [0..]) `thenDs` \ export_binds ->
mappM mk_bind (exports `zip` [0..]) `thenDs` \ export_binds_s ->
-- don't scc (auto-)annotate the tuple itself.
returnDs ((poly_tup_id, poly_tup_expr) : (export_binds ++ rest))
returnDs ((poly_tup_id, poly_tup_expr) : (concat export_binds_s ++ rest))
-- Example:
-- f :: (Eq a, Ix b) => a -> b -> b
--
-- AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds
--
-- SpecPrag (/\b.\(d:Ix b). f Int b dInt d)
-- (forall b. Ix b => Int -> b -> b)
--
-- Rule: forall b,(d:Ix b). f Int b dInt d = f_spec b d
--
-- Spec bind: f_spec = Let f = /\ab \(d1:Eq a)(d2:Ix b). let binds in f_mono
-- /\b.\(d:Ix b). in f Int b dInt d
dsSpec all_tvs dicts tvs poly_id mono_id mono_bind (InlinePrag {})
= return Nothing
dsSpec all_tvs dicts tvs poly_id mono_id mono_bind
(SpecPrag spec_expr spec_ty const_dicts)
= do { let poly_name = idName poly_id
; spec_name <- newLocalName (idName poly_id)
; ds_spec_expr <- dsExpr spec_expr
; let (bndrs, body) = collectBinders ds_spec_expr