Commit 83817d01 authored by sof's avatar sof

[project @ 1998-04-06 18:38:36 by sof]

Misc changes by Simon to emit and handle cross-module specialisations
parent 7884da81
......@@ -173,7 +173,17 @@ data TopLevelFlag
%************************************************************************
\begin{code}
data RecFlag
= Recursive
| NonRecursive
data RecFlag = Recursive
| NonRecursive
\end{code}
%************************************************************************
%* *
\subsection{Strictness indication}
%* *
%************************************************************************
\begin{code}
data StrictnessMark = MarkedStrict
| NotMarkedStrict
\end{code}
......@@ -4,4 +4,3 @@ MkId mkDataCon mkTupleCon ;
_declarations_
1 mkDataCon _:_ Name.Name -> [Id!StrictnessMark] -> [FieldLabel!FieldLabel] -> [TyVar.TyVar] -> Type.ThetaType -> [TyVar.TyVar] -> Type!ThetaType -> [Type!TauType] -> TyCon!TyCon -> Id!Id ;;
1 mkTupleCon _:_ PrelBase.Int -> Name.Name -> Type!Type -> Id!Id ;;
......@@ -16,6 +16,7 @@ module MkId (
mkImportedId,
mkUserId,
mkUserLocal, mkSysLocal,
mkSpecPragmaId,
mkDataCon, mkTupleCon,
......@@ -90,6 +91,9 @@ mkSysLocal str uniq ty loc
mkUserLocal occ uniq ty loc
= mkVanillaId (mkLocalName uniq occ loc) ty noIdInfo
mkSpecPragmaId occ uniq ty loc
= mkId (mkLocalName uniq occ loc) ty SpecPragmaId noIdInfo
mkUserId :: Name -> GenType flexi -> GenId (GenType flexi)
mkUserId name ty
= mkVanillaId name ty noIdInfo
......
......@@ -19,7 +19,7 @@ import CoreSyn
import Bag
import Kind ( hasMoreBoxityInfo, Kind{-instance-} )
import Literal ( literalType, Literal{-instance-} )
import Id ( idType, isBottomingId, dataConRepType, isDataCon, isNewCon, isAlgCon,
import Id ( idType, isBottomingId, dataConRepType, isDataCon, isAlgCon,
dataConArgTys, GenId{-instances-},
emptyIdSet, mkIdSet,
unionIdSets, elementOfIdSet, IdSet,
......@@ -27,7 +27,8 @@ import Id ( idType, isBottomingId, dataConRepType, isDataCon, isNewCon, isAlgCo
)
import Maybes ( catMaybes )
import Name ( isLocallyDefined, getSrcLoc, Name{-instance NamedThing-},
NamedThing(..) )
NamedThing(..)
)
import PprCore
import ErrUtils ( doIfSet, ghcExit )
import PrimOp ( primOpType )
......
......@@ -222,10 +222,21 @@ data Sig name
| InlineSig name -- INLINE f
SrcLoc
| MagicUnfoldingSig
name -- Associate the "name"d function with
FAST_STRING -- the compiler-builtin unfolding (known
SrcLoc -- by the String name)
| SpecInstSig (HsType name) -- (Class tys); should be a specialisation of the
-- current instance decl
SrcLoc
\end{code}
\begin{code}
sigsForMe :: (name -> Bool) -> [Sig name] -> [Sig name]
sigsForMe f sigs
= filter sig_for_me sigs
where
sig_for_me (Sig n _ _) = f n
sig_for_me (ClassOpSig n _ _ _) = f n
sig_for_me (SpecSig n _ _ _) = f n
sig_for_me (InlineSig n _) = f n
sig_for_me (SpecInstSig _ _) = False
\end{code}
\begin{code}
......@@ -252,7 +263,7 @@ ppr_sig (SpecSig var ty using _)
ppr_sig (InlineSig var _)
= hsep [text "{-# INLINE", ppr var, text "#-}"]
ppr_sig (MagicUnfoldingSig var str _)
= hsep [text "{-# MAGIC_UNFOLDING", ppr var, ptext str, text "#-}"]
ppr_sig (SpecInstSig ty _)
= hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"]
\end{code}
......@@ -284,7 +284,7 @@ instance (NamedThing name, Outputable name, Outputable pat)
%************************************************************************
%* *
\subsection[InstDecl]{An instance declaration (also, @SpecInstSig@)}
\subsection[InstDecl]{An instance declaration
%* *
%************************************************************************
......@@ -317,21 +317,6 @@ instance (NamedThing name, Outputable name, Outputable pat)
nest 4 (ppr binds) ]
\end{code}
A type for recording what instances the user wants to specialise;
called a ``Sig'' because it's sort of like a ``type signature'' for an
instance.
\begin{code}
data SpecInstSig name
= SpecInstSig name -- class
(HsType name) -- type to specialise to
SrcLoc
instance (NamedThing name, Outputable name)
=> Outputable (SpecInstSig name) where
ppr (SpecInstSig clas ty _)
= hsep [text "{-# SPECIALIZE instance", ppr clas, ppr ty, text "#-}"]
\end{code}
%************************************************************************
%* *
......
......@@ -35,7 +35,7 @@ import HsDecls ( HsDecl(..), TyDecl(..), InstDecl(..), ClassDecl(..),
DefaultDecl(..),
FixityDecl(..),
ConDecl(..), ConDetails(..), BangType(..),
IfaceSig(..), HsIdInfo, SpecDataSig(..), SpecInstSig(..),
IfaceSig(..), HsIdInfo, SpecDataSig(..),
hsDeclName
)
import HsExpr
......
......@@ -50,18 +50,9 @@ data RdrBinding
-- signatures are mysterious; we can't
-- tell if its a Sig or a ClassOpSig,
-- so we just save the pieces:
| RdrTySig [RdrName] -- vars getting sigs
RdrNameHsType -- the type
SrcLoc
-- user pragmas come in in a Sig-ish way/form...
| RdrSpecValSig [RdrNameSig]
| RdrInlineValSig RdrNameSig
| RdrMagicUnfoldingSig RdrNameSig
| RdrSpecInstSig RdrNameSpecInstSig
| RdrSpecDataSig RdrNameSpecDataSig
type SigConverter = RdrBinding {- a Sig -} -> [RdrNameSig]
| RdrSig RdrNameSig
type SigConverter = RdrNameSig -> RdrNameSig
\end{code}
\begin{code}
......
......@@ -37,20 +37,19 @@ import Util ( mapAndUnzip, panic, assertPanic )
We make a point not to throw any user-pragma ``sigs'' at
these conversion functions:
\begin{code}
cvValSig, cvClassOpSig, cvInstDeclSig :: SigConverter
cvValSig (RdrTySig vars poly_ty src_loc)
= [ Sig v poly_ty src_loc | v <- vars ]
cvValSig sig = sig
cvClassOpSig (RdrTySig vars poly_ty src_loc)
= [ ClassOpSig v Nothing poly_ty src_loc | v <- vars ]
cvInstDeclSig sig = sig
cvInstDeclSig (RdrSpecValSig sigs) = sigs
cvInstDeclSig (RdrInlineValSig sig) = [ sig ]
cvInstDeclSig (RdrMagicUnfoldingSig sig) = [ sig ]
cvClassOpSig (Sig var poly_ty src_loc) = ClassOpSig var Nothing poly_ty src_loc
cvClassOpSig sig = sig
\end{code}
%************************************************************************
%* *
\subsection[cvBinds-etc]{Converting to @HsBinds@, @MonoBinds@, etc.}
......@@ -89,12 +88,8 @@ cvMonoBindsAndSigs sf sig_cvtr fb
mangle_bind acc (RdrAndBindings fb1 fb2)
= mangle_bind (mangle_bind acc fb1) fb2
mangle_bind (b_acc, s_acc) sig@(RdrTySig _ _ _)
= (b_acc, s_acc ++ sig_cvtr sig)
mangle_bind (b_acc, s_acc) (RdrSpecValSig sig) = (b_acc, sig ++ s_acc)
mangle_bind (b_acc, s_acc) (RdrInlineValSig sig) = (b_acc, sig : s_acc)
mangle_bind (b_acc, s_acc) (RdrMagicUnfoldingSig sig) = (b_acc, sig : s_acc)
mangle_bind (b_acc, s_acc) (RdrSig sig)
= (b_acc, sig_cvtr sig : s_acc)
mangle_bind (b_acc, s_acc)
(RdrPatternBinding lousy_srcline [patbinding])
......
......@@ -31,7 +31,6 @@ module RdrHsSyn (
RdrNamePat,
RdrNameHsType,
RdrNameSig,
RdrNameSpecInstSig,
RdrNameStmt,
RdrNameTyDecl,
......@@ -91,7 +90,6 @@ type RdrNameMonoBinds = MonoBinds Unused RdrName RdrNamePat
type RdrNamePat = InPat RdrName
type RdrNameHsType = HsType RdrName
type RdrNameSig = Sig RdrName
type RdrNameSpecInstSig = SpecInstSig RdrName
type RdrNameStmt = Stmt Unused RdrName RdrNamePat
type RdrNameTyDecl = TyDecl RdrName
......
......@@ -620,15 +620,15 @@ wlk_sig_thing (U_sbind sbindids sbindid srcline)
= mkSrcLocUgn srcline $ \ src_loc ->
wlkList rdVarId sbindids `thenUgn` \ vars ->
wlkHsType sbindid `thenUgn` \ poly_ty ->
returnUgn (RdrTySig vars poly_ty src_loc)
returnUgn (foldr1 RdrAndBindings [RdrSig (Sig var poly_ty src_loc) | var <- vars])
-- value specialisation user-pragma
wlk_sig_thing (U_vspec_uprag uvar vspec_tys srcline)
= mkSrcLocUgn srcline $ \ src_loc ->
wlkVarId uvar `thenUgn` \ var ->
wlkList rd_ty_and_id vspec_tys `thenUgn` \ tys_and_ids ->
returnUgn (RdrSpecValSig [SpecSig var ty using_id src_loc
| (ty, using_id) <- tys_and_ids ])
returnUgn (foldr1 RdrAndBindings [ RdrSig (SpecSig var ty using_id src_loc)
| (ty, using_id) <- tys_and_ids ])
where
rd_ty_and_id :: ParseTree -> UgnM (RdrNameHsType, Maybe RdrName)
rd_ty_and_id pt
......@@ -639,29 +639,15 @@ wlk_sig_thing (U_vspec_uprag uvar vspec_tys srcline)
-- instance specialisation user-pragma
wlk_sig_thing (U_ispec_uprag iclas ispec_ty srcline)
= mkSrcLocUgn srcline $ \ src_loc ->
wlkTCId iclas `thenUgn` \ clas ->
wlkMonoType ispec_ty `thenUgn` \ ty ->
returnUgn (RdrSpecInstSig (SpecInstSig clas ty src_loc))
-- data specialisation user-pragma
wlk_sig_thing (U_dspec_uprag itycon dspec_tys srcline)
= mkSrcLocUgn srcline $ \ src_loc ->
wlkTCId itycon `thenUgn` \ tycon ->
wlkList rdMonoType dspec_tys `thenUgn` \ tys ->
returnUgn (RdrSpecDataSig (SpecDataSig tycon (foldl MonoTyApp (MonoTyVar tycon) tys) src_loc))
= mkSrcLocUgn srcline $ \ src_loc ->
wlkHsType ispec_ty `thenUgn` \ ty ->
returnUgn (RdrSig (SpecInstSig ty src_loc))
-- value inlining user-pragma
wlk_sig_thing (U_inline_uprag ivar srcline)
= mkSrcLocUgn srcline $ \ src_loc ->
wlkVarId ivar `thenUgn` \ var ->
returnUgn (RdrInlineValSig (InlineSig var src_loc))
-- "magic" unfolding user-pragma
wlk_sig_thing (U_magicuf_uprag ivar str srcline)
= mkSrcLocUgn srcline $ \ src_loc ->
wlkVarId ivar `thenUgn` \ var ->
returnUgn (RdrMagicUnfoldingSig (MagicUnfoldingSig var str src_loc))
returnUgn (RdrSig (InlineSig var src_loc))
\end{code}
%************************************************************************
......
......@@ -11,7 +11,7 @@ they may be affected by renaming (which isn't fully worked out yet).
\begin{code}
module RnBinds (
rnTopBinds, rnTopMonoBinds,
rnMethodBinds,
rnMethodBinds, renameSigs,
rnBinds, rnMonoBinds
) where
......@@ -20,6 +20,7 @@ module RnBinds (
import {-# SOURCE #-} RnSource ( rnHsSigType )
import HsSyn
import HsBinds ( sigsForMe )
import RdrHsSyn
import RnHsSyn
import RnMonad
......@@ -262,7 +263,7 @@ rn_mono_binds top_lev binders mbinds sigs
-- Rename the bindings, returning a MonoBindsInfo
-- which is a list of indivisible vertices so far as
-- the strongly-connected-components (SCC) analysis is concerned
rnBindSigs top_lev binders sigs `thenRn` \ siglist ->
renameSigs top_lev False binders sigs `thenRn` \ siglist ->
flattenMonoBinds siglist mbinds `thenRn` \ mbinds_info ->
-- Do the SCC analysis
......@@ -299,7 +300,7 @@ flattenMonoBinds sigs (PatMonoBind pat grhss_and_binds locn)
-- Find which things are bound in this group
let
names_bound_here = mkNameSet (collectPatBinders pat')
sigs_for_me = filter ((`elemNameSet` names_bound_here) . sig_name) sigs
sigs_for_me = sigsForMe (`elemNameSet` names_bound_here) sigs
sigs_fvs = foldr sig_fv emptyNameSet sigs_for_me
in
returnRn
......@@ -316,7 +317,7 @@ flattenMonoBinds sigs (FunMonoBind name inf matches locn)
mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, fv_lists) ->
let
fvs = unionManyNameSets fv_lists
sigs_for_me = filter ((name' ==) . sig_name) sigs
sigs_for_me = sigsForMe (name' ==) sigs
sigs_fvs = foldr sig_fv emptyNameSet sigs_for_me
in
returnRn
......@@ -437,17 +438,19 @@ mkEdges flat_info
%* *
%************************************************************************
@rnBindSigs@ checks for: (a)~more than one sig for one thing;
@renameSigs@ checks for: (a)~more than one sig for one thing;
(b)~signatures given for things not bound here; (c)~with suitably
flaggery, that all top-level things have type signatures.
\begin{code}
rnBindSigs :: TopLevelFlag
-> NameSet -- Set of names bound in this group
-> [RdrNameSig]
-> RnMS s [RenamedSig] -- List of Sig constructors
rnBindSigs top_lev binders sigs
renameSigs :: TopLevelFlag
-> Bool -- True <-> sigs for an instance decl
-- hence SPECIALISE instance prags ok
-> NameSet -- Set of names bound in this group
-> [RdrNameSig]
-> RnMS s [RenamedSig] -- List of Sig constructors
renameSigs top_lev inst_decl binders sigs
= -- Rename the signatures
mapRn renameSig sigs `thenRn` \ sigs' ->
......@@ -455,8 +458,9 @@ rnBindSigs top_lev binders sigs
-- (b) signatures for things not in this group
-- (c) optionally, bindings with no signature
let
(goodies, dups) = removeDups cmp_sig (filter (not.isUnboundName.sig_name) sigs')
not_this_group = filter (\sig -> not (sig_name sig `elemNameSet` binders)) goodies
(goodies, dups) = removeDups cmp_sig (sigsForMe (not . isUnboundName) sigs')
not_this_group = sigsForMe (not . (`elemNameSet` binders)) goodies
spec_inst_sigs = [s | s@(SpecInstSig _ _) <- goodies]
type_sig_vars = [n | Sig n _ _ <- goodies]
sigs_required = case top_lev of {TopLevel -> opt_SigsRequired; NotTopLevel -> False}
un_sigd_binders | sigs_required = nameSetToList binders `minusList` type_sig_vars
......@@ -464,6 +468,11 @@ rnBindSigs top_lev binders sigs
in
mapRn dupSigDeclErr dups `thenRn_`
mapRn unknownSigErr not_this_group `thenRn_`
(if not inst_decl then
mapRn unknownSigErr spec_inst_sigs
else
returnRn []
) `thenRn_`
mapRn (addErrRn.missingSigErr) un_sigd_binders `thenRn_`
returnRn sigs' -- bad ones and all:
......@@ -476,6 +485,11 @@ renameSig (Sig v ty src_loc)
rnHsSigType (quotes (ppr v)) ty `thenRn` \ new_ty ->
returnRn (Sig new_v new_ty src_loc)
renameSig (SpecInstSig ty src_loc)
= pushSrcLocRn src_loc $
rnHsSigType (text "A SPECIALISE instance pragma") ty `thenRn` \ new_ty ->
returnRn (SpecInstSig new_ty src_loc)
renameSig (SpecSig v ty using src_loc)
= pushSrcLocRn src_loc $
lookupBndrRn v `thenRn` \ new_v ->
......@@ -491,21 +505,16 @@ renameSig (InlineSig v src_loc)
= pushSrcLocRn src_loc $
lookupBndrRn v `thenRn` \ new_v ->
returnRn (InlineSig new_v src_loc)
renameSig (MagicUnfoldingSig v str src_loc)
= pushSrcLocRn src_loc $
lookupBndrRn v `thenRn` \ new_v ->
returnRn (MagicUnfoldingSig new_v str src_loc)
\end{code}
Checking for distinct signatures; oh, so boring
\begin{code}
cmp_sig :: RenamedSig -> RenamedSig -> Ordering
cmp_sig (Sig n1 _ _) (Sig n2 _ _) = n1 `compare` n2
cmp_sig (InlineSig n1 _) (InlineSig n2 _) = n1 `compare` n2
cmp_sig (MagicUnfoldingSig n1 _ _) (MagicUnfoldingSig n2 _ _) = n1 `compare` n2
cmp_sig (SpecSig n1 ty1 _ _) (SpecSig n2 ty2 _ _)
cmp_sig (Sig n1 _ _) (Sig n2 _ _) = n1 `compare` n2
cmp_sig (InlineSig n1 _) (InlineSig n2 _) = n1 `compare` n2
cmp_sig (SpecInstSig ty1 _) (SpecInstSig ty2 _) = cmpHsType compare ty1 ty2
cmp_sig (SpecSig n1 ty1 _ _) (SpecSig n2 ty2 _ _)
= -- may have many specialisations for one value;
-- but not ones that are exactly the same...
thenCmp (n1 `compare` n2) (cmpHsType compare ty1 ty2)
......@@ -517,14 +526,8 @@ cmp_sig other_1 other_2 -- Tags *must* be different
sig_tag (Sig n1 _ _) = (ILIT(1) :: FAST_INT)
sig_tag (SpecSig n1 _ _ _) = ILIT(2)
sig_tag (InlineSig n1 _) = ILIT(3)
sig_tag (MagicUnfoldingSig n1 _ _) = ILIT(4)
sig_tag (SpecInstSig _ _) = ILIT(5)
sig_tag _ = panic# "tag(RnBinds)"
sig_name (Sig n _ _) = n
sig_name (ClassOpSig n _ _ _) = n
sig_name (SpecSig n _ _ _) = n
sig_name (InlineSig n _) = n
sig_name (MagicUnfoldingSig n _ _) = n
\end{code}
%************************************************************************
......@@ -536,24 +539,25 @@ sig_name (MagicUnfoldingSig n _ _) = n
\begin{code}
dupSigDeclErr (sig:sigs)
= pushSrcLocRn loc $
addErrRn (sep [ptext SLIT("more than one"),
ptext what_it_is, ptext SLIT("given for"),
quotes (ppr (sig_name sig))])
addErrRn (sep [ptext SLIT("Duplicate"),
ptext what_it_is <> colon,
ppr sig])
where
(what_it_is, loc) = sig_doc sig
unknownSigErr sig
= pushSrcLocRn loc $
addErrRn (sep [ptext flavour, ptext SLIT("but no definition for"),
quotes (ppr (sig_name sig))])
addErrRn (sep [ptext SLIT("Misplaced"),
ptext what_it_is <> colon,
ppr sig])
where
(flavour, loc) = sig_doc sig
(what_it_is, loc) = sig_doc sig
sig_doc (Sig _ _ loc) = (SLIT("type signature"),loc)
sig_doc (ClassOpSig _ _ _ loc) = (SLIT("class-method type signature"), loc)
sig_doc (SpecSig _ _ _ loc) = (SLIT("SPECIALIZE pragma"),loc)
sig_doc (SpecSig _ _ _ loc) = (SLIT("SPECIALISE pragma"),loc)
sig_doc (InlineSig _ loc) = (SLIT("INLINE pragma"),loc)
sig_doc (MagicUnfoldingSig _ _ loc) = (SLIT("MAGIC_UNFOLDING pragma"),loc)
sig_doc (SpecInstSig _ loc) = (SLIT("SPECIALISE instance pragma"),loc)
missingSigErr var
= sep [ptext SLIT("Definition but no type signature for"), quotes (ppr var)]
......
......@@ -44,7 +44,6 @@ type RenamedPat = InPat Name
type RenamedHsType = HsType Name
type RenamedRecordBinds = HsRecordBinds Unused Name RenamedPat
type RenamedSig = Sig Name
type RenamedSpecInstSig = SpecInstSig Name
type RenamedStmt = Stmt Unused Name RenamedPat
type RenamedTyDecl = TyDecl Name
......
......@@ -18,7 +18,7 @@ import RnHsSyn
import HsCore
import CmdLineOpts ( opt_IgnoreIfacePragmas )
import RnBinds ( rnTopBinds, rnMethodBinds )
import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs )
import RnEnv ( bindTyVarsRn, lookupBndrRn, lookupOccRn, lookupImplicitOccRn, bindLocalsRn,
newDfunName, checkDupOrQualNames, checkDupNames,
newLocallyDefinedGlobalName, newImportedGlobalName, ifaceFlavour,
......@@ -26,9 +26,10 @@ import RnEnv ( bindTyVarsRn, lookupBndrRn, lookupOccRn, lookupImplicitOccRn, bi
import RnMonad
import Name ( Name, OccName(..), occNameString, prefixOccName,
ExportFlag(..), Provenance(..), NameSet,
ExportFlag(..), Provenance(..), NameSet, mkNameSet,
elemNameSet, nameOccName, NamedThing(..)
)
import BasicTypes ( TopLevelFlag(..) )
import FiniteMap ( lookupFM )
import Id ( GenId{-instance NamedThing-} )
import IdInfo ( FBTypeInfo, ArgUsageInfo )
......@@ -173,7 +174,7 @@ rnDecl (ClD (ClassDecl context cname tyvars sigs mbinds pragmas tname dname src_
where
cls_doc = text "the declaration for class" <+> ppr cname
sig_doc = text "the signatures for class" <+> ppr cname
meth_doc = text "the default-methods for class" <+> ppr cname
meth_doc = text "the default-methods for class" <+> ppr cname
sig_rdr_names_w_locs = [(op,locn) | ClassOpSig op _ _ locn <- sigs]
meth_rdr_names_w_locs = bagToList (collectMonoBinders mbinds)
......@@ -239,7 +240,10 @@ rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun src_loc))
-- NB meth_names can be qualified!
checkDupNames meth_doc meth_names `thenRn_`
rnMethodBinds mbinds `thenRn` \ mbinds' ->
mapRn rn_uprag uprags `thenRn` \ new_uprags ->
let
binders = mkNameSet (map fst (bagToList (collectMonoBinders mbinds')))
in
renameSigs NotTopLevel True binders uprags `thenRn` \ new_uprags ->
let
-- We use the class name and the name of the first
......@@ -278,27 +282,6 @@ rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun src_loc))
where
meth_doc = text "the bindings in an instance declaration"
meth_names = bagToList (collectMonoBinders mbinds)
rn_uprag (SpecSig op ty using locn)
= pushSrcLocRn src_loc $
lookupBndrRn op `thenRn` \ op_name ->
rnHsSigType (quotes (ppr op)) ty `thenRn` \ new_ty ->
rn_using using `thenRn` \ new_using ->
returnRn (SpecSig op_name new_ty new_using locn)
rn_uprag (InlineSig op locn)
= pushSrcLocRn locn $
lookupBndrRn op `thenRn` \ op_name ->
returnRn (InlineSig op_name locn)
rn_uprag (MagicUnfoldingSig op str locn)
= pushSrcLocRn locn $
lookupBndrRn op `thenRn` \ op_name ->
returnRn (MagicUnfoldingSig op_name str locn)
rn_using Nothing = returnRn Nothing
rn_using (Just v) = lookupOccRn v `thenRn` \ new_v ->
returnRn (Just new_v)
\end{code}
%*********************************************************
......
......@@ -22,7 +22,7 @@ import CmdLineOpts ( opt_D_dump_occur_anal, SimplifierSwitch(..) )
import CoreSyn
import Digraph ( stronglyConnCompR, SCC(..) )
import Id ( idWantsToBeINLINEd, addNoInlinePragma, nukeNoInlinePragma,
omitIfaceSigForId,
omitIfaceSigForId, isSpecPragmaId,
idType, idUnique, Id,
emptyIdSet, unionIdSets, mkIdSet,
elementOfIdSet,
......@@ -790,7 +790,7 @@ tagBinder usage binder =
usage_of usage binder
| isExported binder
| isExported binder || isSpecPragmaId binder
= noBinderInfo -- Visible-elsewhere things count as many
| otherwise
= case (lookupIdEnv usage binder) of
......
......@@ -14,7 +14,7 @@ module Specialise (
import MkId ( mkUserLocal )
import Id ( Id, DictVar, idType,
getIdSpecialisation, setIdSpecialisation,
getIdSpecialisation, setIdSpecialisation, isSpecPragmaId,
IdSet, mkIdSet, addOneToIdSet, intersectIdSets, isEmptyIdSet,
emptyIdSet, unionIdSets, minusIdSet, unitIdSet, elementOfIdSet,
......@@ -58,10 +58,9 @@ infixr 9 `thenSM`
%************************************************************************
These notes describe how we implement specialisation to eliminate
overloading, and optionally to eliminate unboxed polymorphism, and
full polymorphism.
overloading.
The specialisation pass is a partial evaluator which works on Core
The specialisation pass works on Core
syntax, complete with all the explicit dictionary application,
abstraction and construction as added by the type checker. The
existing type checker remains largely as it is.
......@@ -125,12 +124,12 @@ and create a local instance of f, defined thus:
f@t1/t2 = <f_rhs> t1 t2 d1 d2
(f_rhs presumably has some big lambdas and dictionary lambdas, so lots
of simplification will now result.) Then we should recursively do
everything again.
The new id has its own unique, but its print-name (if exported) has
an explicit representation of the instance types t1/t2.
f_rhs presumably has some big lambdas and dictionary lambdas, so lots
of simplification will now result. However we don't actually *do* that
simplification. Rather, we leave it for the simplifier to do. If we
*did* do it, though, we'd get more call instances from the specialised
RHS. We can work out what they are by instantiating the call-instance
set from f's RHS with the types t1, t2.
Add this new id to f's IdInfo, to record that f has a specialised version.
......@@ -157,8 +156,8 @@ becomes
in
fl
We still have recusion for non-overloadd functions which we
speciailise, but the recursive call should get speciailised to the
We still have recusion for non-overloaded functions which we
speciailise, but the recursive call should get specialised to the
same recursive version.
......@@ -240,22 +239,23 @@ polymorphic versions. Thus:
f@t1/ = /\b -> <f_rhs> t1 b d1 d2
This seems pretty simple, and a Good Thing.
We do this.
Polymorphism 3 -- Unboxed
~~~~~~~~~~~~~~
If we are speciailising at unboxed types we must speciailise
regardless of the overloading constraint. In the exaple above it is
worth speciailising at types Int/Int#, Int/Bool# and a/Int#, Int#/Int#
etc.
Dictionary floating
~~~~~~~~~~~~~~~~~~~
Consider this
Note that specialising an overloaded type at an uboxed type requires
an unboxed instance -- we cannot default to an unspecialised version!
f a (d::Num a) = let g = ...
in
...(let d1::Ord a = Num.Ord.sel a d in g a d1)...
Here, g is only called at one type, but the dictionary isn't in scope at the
definition point for g. Usually the type checker would build a
definition for d1 which enclosed g, but the transformation system
might have moved d1's defn inward. Solution: float dictionary bindings
outwards along with call instances.
Dictionary floating
~~~~~~~~~~~~~~~~~~~
Consider
f x = let g p q = p==q
......@@ -284,11 +284,6 @@ at the defn of g. Instead, we have to float out the (new) defn of deq
to widen its scope. Notice that this floating can't be done in advance -- it only
shows up when specialisation is done.
DELICATE MATTER: the way we tell a dictionary binding is by looking to
see if it has a Dict type. If the type has been "undictify'd", so that
it looks like a tuple, then the dictionary binding won't be floated, and